igraph基于edge属性的最短路径

Question

我正在尝试获取图形的最短路径，但要基于其边缘ID。 因此，具有以下图形：

library(igraph)

set.seed(45)
g <- erdos.renyi.game(25, 1/10, directed = TRUE)
E(g)$id <- sample(1:3, length(E(g)), replace = TRUE)

shortest_paths(g, 1, V(g))函数查找从节点1到所有其他节点的所有最短路径。 但是，我不仅要通过遵循测地线距离，而且还要通过测地线距离与最小边id的变化之间的混合来进行计算。 例如，如果这将是火车网络，并且边缘ID将代表火车。 我想计算如何使用最短路径从节点A到所有其他节点，但要改变火车的时间最少。

Answer 1

好的，我认为我有一个可行的解决方案，尽管代码有些难看。 基本算法（我们称其为gs（i，j））是这样的：如果我们想找到从i到j（gs（i，j））的最短火车路程，我们：

1. 考虑所有火车，找到从i到j的最短路径。 如果此路径的长度为0或1，则返回该路径（没有路径或1列火车上的路径）
2. 通过“火车”将图分解（通过边缘划分子图），以便分别考虑每个火车网络，并找到每个火车网络中i和j之间的最短路径
3. 如果有一列火车将您从i带到j，请返回i和j之间停靠最少的火车路线，否则
4. 如果没有单列火车从i到j行驶，则呼叫gs（i，j-1），其中（j-1）是i和j在整个网络上的最短路径中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的路径为length-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

我确定有一个更严格的解决方案，您可能需要稍微优化一下代码。 例如，我只是意识到，如果全图上的最短路径只有两个节点，我不会立即停止该函数-这样做可以避免不必要的计算！ 这是一个有趣的问题，我希望能发布一些其他答案。

由reprex包 （v0.2.0）创建于2018-05-11。

Answer 2

这是我对这个问题的看法。 一些注意事项：

1） all_simple_paths在大型或高度连接的图上无法很好地缩放
2）我偏爱最少的更改，这意味着具有两个更改且距离为40的路径将击败具有三个更改且距离为3的路径。
4）我可以想象如果在一个id上没有路径的情况下，如果更改数量和距离更改优先级，则可以采用更快的方法

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)


##Option 1:
rst <- all_simple_paths(g, from = 1, to = 18, mode = "out")
rst <- lapply(rst, as_ids)
rst1 <- lapply(rst, function(x) c(x[1], rep(x[2:(length(x)-1)],
                                            each=2), x[length(x)]))
rst2 <- lapply(rst1, function(x) data.frame(eid = get.edge.ids(graph=g, vp = x),
                                    train=E(g)$id[get.edge.ids(graph=g, vp = x)]))

rst3 <- data.frame(pathID=seq_along(rst), 
                   changes=sapply(rst2, function(x) length(rle(x$train)$lengths)), 
                   dist=sapply(rst2, nrow))

spath <- rst3[order(rst3$changes, rst3$dist), ][1,1]

#Vertex IDs
rst[[spath]]
#[1]  1 23  8 18

plot(g, edge.color = E(g)$id, vertex.color=ifelse(V(g) %in% rst[[spath]], "firebrick", "gray80"), 
     edge.arrow.size=0.5)