Попарные Дейкстры с ранним окончанием по количеству прыжков в R

Question

Я ищу наиболее вычислительный и дружественный к памяти подход к вычислению конкретных записей матрицы расстояний D, полученных с помощью попарного алгоритма Дейкстры в R. Точнее, мне нужен только D [i, j], если счетчик прыжков (невзвешенный) ) расстояние между узлом i и узлом j составляет самое большее конкретное целое число k (сам D [i, j] может быть вычислен как взвешенная длина кратчайшего пути, для которой количество прыжков может быть больше k). D должен быть закодирован как разреженная матрица для эффективности памяти.

Мне было интересно, была ли проделана некоторая работа по этому вопросу или существует эффективный подход к оптимизации текущих функций igraph для учета этого ограничения. Например, ранний выход в парном алгоритме Дейкстры может реально повысить эффективность решения моей проблемы.

Я сам пытался сделать это как можно более эффективным, но пока безуспешно. Некоторые первые попытки проиллюстрированы ниже.

library(igraph)
library(Matrix)
library(spam)

# Hope this to the more efficient one
bounded_hop_pairG_1 <- function(G, k=2){
  to <- ego(G, order=k)
  D <- sparseMatrix(i=unlist(lapply(1:length(V(G)), function(v) rep(v, length(to[[v]])))),
                    j=unlist(to),
                    x=unlist(lapply(1:length(V(G)), function(v) distances(G, v=v, to=to[[v]]))))
  return(D)
}

# Hope this to be the less efficient one
bounded_hop_pairG_2 <- function(G, k=2){
  D <- distances(G)
  D[distances(G, weight=NA) > k] <- 0
  return(as.spam(D))
}

# Sample graph
set.seed(42)
G <- sample_bipartite(500, 500, p=0.1)
E(G)$weight <- runif(length(E(G)))

# Check whether 'distances' actually implements early termination
start_time <- Sys.time()
d1 <- distances(G, v=1)
end_time <- Sys.time()
print(end_time - start_time)
# Time difference of 0.00497961 secs

start_time <- Sys.time()
d2 <- distances(G, v=1, to=521)
end_time <- Sys.time()
print(end_time - start_time)
# Time difference of 0.002238274 secs (consistently smaller than above)

start_time <- Sys.time()
D1 <- bounded_hop_pairG_1(G)
end_time <- Sys.time()
print(end_time - start_time)
# Time difference of 2.671333 secs

start_time <- Sys.time()
D2 <- bounded_hop_pairG_2(G)
end_time <- Sys.time()
print(end_time - start_time)
# Time difference of 1.101419 secs

Хотя я подозреваю, что моя первая функция применяет раннее завершение и никогда не хранит полную матрицу парных расстояний, она, по-видимому, намного менее эффективна, чем моя вторая функция (которая также выполняет полное невзвешенное вычисление парных расстояний) с точки зрения вычислительного времени. Следовательно, я надеялся, что кто-нибудь сможет указать наиболее эффективный способ реализации первой функции в R.

Answer 1

вы можете попробовать пакет cppRouting , доступный через github.Он предоставляет такие функции, как get_distance_matrix (), которые могут использовать все ядра.

library(cppRouting)
library(igraph)
library(spam)
library(Matrix)
# Sample graph
set.seed(42)
G <- sample_bipartite(500, 500, p=0.1)
E(G)$weight <- runif(length(E(G)))

#Graph to data frame 
G2<-as_long_data_frame(G)

#Weighted graph
graph1<-makegraph(G2[,1:3],directed = F)

#Unweighted graph
graph2<-makegraph(cbind(G2[,1:2],rep(1,nrow(G2))),directed = F)
nodes<-unique(c(G2$from,G2$to)) %>% sort

myfunc<-function(Gr1,Gr2,nd,k=2,cores=FALSE){
test<-get_distance_matrix(graph,nd,nd,allcores = cores)
test2<-get_distance_matrix(graph2,nd,nd,allcores = cores)
test[test2>k]<-0
return(as.spam(test))
}

#Your first function
system.time(
D1 <- bounded_hop_pairG_1(G)
)
#2.18s

#Your second function
system.time(
D2 <- bounded_hop_pairG_2(G)
)
#1.01s

#One core
system.time(
D3 <- myfunc(graph1,graph2,nodes))
#0.69s

#Parallel
system.time(
D4 <- myfunc(graph1,graph2,nodes,cores=TRUE))
#0.32s

Если вы действительно хотите остановить алгоритм при достижении k-узлов и немного разбираться в C ++, кажется, что немного простоизмените оригинальный алгоритм Дейкстры, затем используйте его через Rcpp.