在距离矩阵中查找边较短的三角形答案

【问题标题】：Find triangles with shorter edges in a distance matrix在距离矩阵中查找边较短的三角形
【发布时间】：2019-03-04 08:51:27
【问题描述】：

我试图在距离矩阵中找到直接路径比通过另一个点更长的三角形。目标是减少全连接图中的边数。该函数适用于较小的 n 值，但对于较大的值则较慢。我试图找出如何加快这个过程。

我曾希望通过将数据保留为矩阵并对其进行操作，从而使过程矢量化并且非常快，但是，事实并非如此。

我尝试使用lineprof 并点击进入较低的功能，但我不明白它在告诉我什么。不知道igraph里面有没有什么功能可以帮上忙？

library(purrr);library(magrittr); library(lineprof);library(shiny)

#The function used to find triangles
RemoveTri <- function(s){
  Smat<- col(s) 
  RemoveEdge <- 1:ncol(s) %>%
  map(~{
  print(.x)
    LogicMat <- s + s[,.x][Smat] < (s[,.x]) #I used this method to avoid transposing
    matrix(data = rowSums(LogicMat, na.rm = TRUE ) > 0, ncol = 1) #TRUE means edge can be removed
  }) %>%
  do.call(cbind,.)
  s[RemoveEdge] <- NA
return(s)
}

#This function just creates a dataframe
CreateData <- function(n, seed){
  set.seed(seed)
  s <- matrix(rnorm(n^2), n) #%>% cor
  s <- s +abs(min(s))+0.001
  s[lower.tri(s)] = t(s)[lower.tri(s)]
  diag(s) <- 0
  return(s)
 }

#Using a small amount of data
s <- CreateData(100, 876)
RemoveTri(s)

#using a larger amount of data
s2 <- CreateData(4000, 876)
RemoveTri(s2)

l <- lineprof(RemoveTri(s))
shine(l)

【问题讨论】：

当然，边数随着节点数的平方而增加。任何算法都可能需要检查所有边是否消除，因此时间会随着 n² 的增加而增加。你得到的反应比这慢吗？例如，您应该预计当 n=4000 时，它应该是 n=100 的 1600 倍。

标签： r matrix igraph adjacency-matrix

【解决方案1】：

由于矩阵是对称的，只需计算下三角矩阵即可加快处理速度。通过这样做，我们可以将计算次数从 $n^3$ 减少到
$\frac{n}{6}(2n^2+3n+1)$ 给出 $\frac{(2n+1)(n+1)}{6n^2}$ 的比率，结果约为 2 /3 减少 n 较大时的总计算次数。

调整后的功能如下。

此函数启动缓慢，随着计算的行数增加而加速。在 n 值较小时，由于额外的开销，它比原始函数慢，但当 n 大于几百时，它会变得更快。

RemoveTri  <- function(s){
      Smat <- col(s) 

      RemoveEdge <- 1:ncol(s) %>%
      map(~{
        print(.x)
        TargetRows <- .x:ncol(s)
        LogicMat <- s[TargetRows,TargetRows, drop = F] + s[TargetRows,.x][Smat[1:length(TargetRows),1:length(TargetRows)]]  < s[TargetRows,.x]


        matrix(data = c(rep(NA, .x-1),rowSums(LogicMat, na.rm = TRUE ) > 0), ncol = 1) #TRUE means edge should be removed

      }) %>%
      do.call(cbind,.)

      RemoveEdge[upper.tri(RemoveEdge)]  <- t(RemoveEdge)[upper.tri(RemoveEdge)]

      s[RemoveEdge] <- NA 

    s

}

【讨论】：