ОК. Думаю, у меня есть рабочее решение, хотя код немного уродливый. Основной алгоритм (назовем его gs (i, j)) выглядит следующим образом: если мы хотим найти кратчайшее путешествие на поезде от i до j (gs (i, j)), мы:
- найти кратчайший путь от i до j с учетом всех поездов. если этот путь имеет длину 0 или 1, верните его (нет пути или пути на 1 поезде)
- разделить график на «поезда» (подмножество графиков по ребрам), чтобы рассмотреть каждую сеть поездов отдельно, и найти кратчайший путь между i и j в каждой отдельной сети поездов
- если один поезд доставит вас от i до j, верните маршрут поезда с наименьшим количеством остановок между i и j, иначе
- если ни один поезд не идет от i до j, то вызовите gs (i, j-1), где (j-1) - остановка перед j на кратчайшем пути между i и j в полной сети.
Итак, в основном, мы смотрим, может ли это сделать один поезд, и если это невозможно, мы вызываем функцию рекурсивно, ища, может ли один поезд доставить вас до остановки до последней остановки и т. Д. И т. Д.
library(igraph)
# First your data
set.seed(45)
g <- erdos.renyi.game(25, 1/10, directed = TRUE)
E(g)$id <- sample(1:3, length(E(g)), replace = TRUE)
plot(g, edge.color = E(g)$id)
# The function takes as arguments the graph, and the id of the vertex
# you want to go from/to. It should work for a vector of
# destinations but I have not rigorously tested it so proceed with
# caution!
get.shortest.routes <- function(g, from, to){
train.routes <- lapply(unique(E(g)$id), function(id){subgraph.edges(g, eids = which(E(g)$id==id), delete.vertices = F)})
target.sp <- shortest_paths(g, from = from, to = to, output = 'vpath')$vpath
single.train.paths <- lapply(train.routes, function(gs){shortest_paths(gs, from = from, to = to, output = 'vpath')$vpath})
for (i in length(target.sp)){
if (length(target.sp[[i]]>1)) {
cands <- lapply(single.train.paths, function(l){l[[i]]})
if (sum(unlist(lapply(cands, length)))!=0) {
cands <- cands[lapply(cands, length)!=0]
cands <- cands[lapply(cands, length)==min(unlist(lapply(cands, length)))]
target.sp[[i]] <- cands[[1]]
} else {
target.sp[[i]] <- c(get.shortest.routes(g, from = as.numeric(target.sp[[i]][1]),
to = as.numeric(target.sp[[i]][(length(target.sp[[i]]) - 1)]))[[1]],
get.shortest.routes(g, from = as.numeric(target.sp[[i]][(length(target.sp[[i]]) - 1)]),
to = as.numeric(target.sp[[i]][length(target.sp[[i]])]))[[1]][-1])
}
}
}
target.sp
}
ОК, теперь давайте запустим несколько тестов. Если вы покоситесь на график выше, вы увидите, что путь от вершины 5 до вершины 21 составляет длину 2, если вы садитесь на два поезда, но вы можете добраться туда на 1 поезде, если вы проходите через дополнительную станцию. Наша новая функция должна возвращать более длинный путь:
shortest_paths(g, 5, 21)$vpath
#> [[1]]
#> + 3/25 vertices, from b014eb9:
#> [1] 5 13 21
get.shortest.routes(g, 5, 21)
#> Warning in shortest_paths(gs, from = from, to = to, output = "vpath"): At
#> structural_properties.c:745 :Couldn't reach some vertices
#> Warning in shortest_paths(gs, from = from, to = to, output = "vpath"): At
#> structural_properties.c:745 :Couldn't reach some vertices
#> [[1]]
#> + 4/25 vertices, from c22246c:
#> [1] 5 13 15 21
Давайте сделаем действительно простой график, на котором мы уверены, что хотим видеть: здесь мы должны получить 1-2-4-5 вместо 1-3-5:
df <- data.frame(from = c(1, 1, 2, 3, 4), to = c(2, 3, 4, 5, 5))
g1 <- graph_from_data_frame(df)
E(g1)$id <- c(1, 2, 1, 3, 1)
plot(g1, edge.color = E(g1)$id)
get.shortest.routes(g1, 1, 5)
#> Warning in shortest_paths(gs, from = from, to = to, output = "vpath"): At
#> structural_properties.c:745 :Couldn't reach some vertices
#> Warning in shortest_paths(gs, from = from, to = to, output = "vpath"): At
#> structural_properties.c:745 :Couldn't reach some vertices
#> [[1]]
#> + 4/5 vertices, named, from c406649:
#> [1] 1 2 4 5
Я уверен, что есть более строгое решение, и вы, вероятно, захотите немного оптимизировать код. Например, я только что понял, что не остановлю функцию немедленно, если кратчайший путь на полном графе имеет только два узла - это позволит избежать ненужных вычислений! Это была забавная проблема, я надеюсь, что другие ответы будут опубликованы.
Создано в 2018-05-11 пакетом Представ (v0.2.0).