Question

JSD矩阵是基于Jensen-Shannon divergence的分布的相似性矩阵。给定矩阵m哪些行呈现分布，我们希望找到每个分布之间的JSD距离。得到的JSD矩阵是一个方形矩阵，其维数为nrow（m）x nrow（m）。这是三角矩阵，其中每个元素包含m中两行之间的JSD值。

JSD可以通过以下R函数计算：

JSD<- function(x,y) sqrt(0.5 * (sum(x*log(x/((x+y)/2))) + sum(y*log(y/((x+y)/2)))))

其中x，y是矩阵m中的行。

我在R中尝试了不同的JSD矩阵计算算法，以找出最快的算法。令我惊讶的是，具有两个嵌套循环的算法比不同的矢量化版本（并行化或非并行化）执行得更快。我对结果不满意。你能找到比我游戏更好的解决方案吗？

library(parallel)
library(plyr)
library(doParallel)
library(foreach)

nodes <- detectCores()
cl <- makeCluster(4)
registerDoParallel(cl)

m <- runif(24000, min = 0, max = 1)
m <- matrix(m, 24, 1000)
prob_dist <- function(x) t(apply(x, 1, prop.table))
JSD<- function(x,y) sqrt(0.5 * (sum(x*log(x/((x+y)/2))) + sum(y*log(y/((x+y)/2)))))
m <- t(prob_dist(m))
m[m==0] <- 0.000001

具有两个嵌套循环的算法：

dist.JSD_2 <- function(inMatrix) {
  matrixColSize <- ncol(inMatrix)
  resultsMatrix <- matrix(0, matrixColSize, matrixColSize)
  for(i in 2:matrixColSize) {
    for(j in 1:(i-1)) { 
      resultsMatrix[i,j]=JSD(inMatrix[,i], inMatrix[,j])
    }
  }
  return(resultsMatrix) 
}

外部算法：

dist.JSD_3 <- function(inMatrix) {
  matrixColSize <- ncol(inMatrix)
  resultsMatrix <- outer(1:matrixColSize,1:matrixColSize, FUN = Vectorize( function(i,j) JSD(inMatrix[,i], inMatrix[,j])))   
  return(resultsMatrix)
}

使用combn和apply的算法：

dist.JSD_4 <- function(inMatrix) {
  matrixColSize <- ncol(inMatrix)
  ind <- combn(matrixColSize, 2)
  out <- apply(ind, 2, function(x) JSD(inMatrix[,x[1]], inMatrix[,x[2]]))
  a <- rbind(ind, out)
  resultsMatrix <- sparseMatrix(a[1,], a[2,], x=a[3,], dims=c(matrixColSize, matrixColSize))
  return(resultsMatrix)
}

带有combn和aaply的算法：

dist.JSD_5 <- function(inMatrix) {
  matrixColSize <- ncol(inMatrix)
  ind <- combn(matrixColSize, 2)
  out <- aaply(ind, 2, function(x) JSD(inMatrix[,x[1]], inMatrix[,x[2]]))
  a <- rbind(ind, out)
  resultsMatrix <- sparseMatrix(a[1,], a[2,], x=a[3,], dims=c(matrixColSize, matrixColSize))
  return(resultsMatrix)
}

性能测试：

mbm = microbenchmark(
  two_loops = dist.JSD_2(m),
  outer = dist.JSD_3(m),
  combn_apply = dist.JSD_4(m),
  combn_aaply = dist.JSD_5(m),
  times = 10
)
ggplot2::autoplot(mbm)

benchmark plot

> summary(mbm)
         expr      min       lq     mean   median
1   two_loops 18.30857 18.68309 23.50231 18.77303
2       outer 38.93112 40.98369 42.44783 42.16858
3 combn_apply 20.45740 20.90747 21.49122 21.35042
4 combn_aaply 55.61176 56.77545 59.37358 58.93953
        uq      max neval cld
1 18.87891 65.34197    10 a  
2 42.85978 48.82437    10  b 
3 22.06277 22.98803    10 a  
4 62.26417 64.77407    10   c

Answer 1

这是我对dist.JSD_2

的实施

dist0 <- function(m) {
    ncol <- ncol(m)
    result <- matrix(0, ncol, ncol)
    for (i in 2:ncol) {
        for (j in 1:(i-1)) {
            x <- m[,i]; y <- m[,j]
            result[i, j] <-
                sqrt(0.5 * (sum(x * log(x / ((x + y) / 2))) +
                            sum(y * log(y / ((x + y) / 2)))))
        }
    }
    result
}

通常的步骤是用矢量化版本替换迭代计算。我将sqrt(0.5 * ...)从循环内部移动到循环外部，在循环内部将result应用于向量result。

我意识到sum(x * log(x / (x + y) / 2))可以写成sum(x * log(2 * x)) - sum(x * log(x + y))。每个条目计算一次总和，但可以为每列计算一次。它也来自循环，值的向量（每列一个元素）计算为colSums(m * log(2 * m))。

内循环内的剩余项是sum((x + y) * log(x + y))。对于给定的i值，我们可以通过在所有相关的y列中将其作为矩阵运算进行矢量化来权衡空间速度

j <- seq_len(i - 1L)
xy <- m[, i] + m[, j, drop=FALSE]
xylogxy[i, j] <- colSums(xy * log(xy))

最终结果是

dist4 <- function(m) {
    ncol <- ncol(m)

    xlogx <- matrix(colSums(m * log(2 * m)), ncol, ncol)
    xlogx2 <- xlogx + t(xlogx)
    xlogx2[upper.tri(xlogx2, diag=TRUE)] <- 0

    xylogxy <- matrix(0, ncol, ncol)
    for (i in seq_len(ncol)[-1]) {
        j <- seq_len(i - 1L)
        xy <- m[, i] + m[, j, drop=FALSE]
        xylogxy[i, j] <- colSums(xy * log(xy))
    }

    sqrt(0.5 * (xlogx2 - xylogxy))
}

产生与原始

在数值上相等（但不完全相同）的结果

> all.equal(dist0(m), dist4(m))
[1] TRUE

并且快了2.25倍

> microbenchmark(dist0(m), dist4(m), dist.JSD_cpp2(m), times=10)
Unit: milliseconds
             expr      min       lq     mean   median       uq      max neval
         dist0(m) 48.41173 48.42569 49.26072 48.68485 49.48116 51.64566    10
         dist4(m) 20.80612 20.90934 21.34555 21.09163 21.96782 22.32984    10
 dist.JSD_cpp2(m) 28.95351 29.11406 29.43474 29.23469 29.78149 30.37043    10

你仍然会等待大约10个小时，尽管这似乎意味着一个非常大的问题。该算法似乎是列数的二次方，但这里的列数与行数相比较小（24），所以我想知道正在处理的数据的实际大小是多少？需要计算ncol *（ncol - 1）/ 2距离。

进一步提高性能的原始方法是并行评估，以下实现使用parallel::mclapply()

dist4p <- function(m, ..., mc.cores=detectCores()) {
    ncol <- ncol(m)

    xlogx <- matrix(colSums(m * log(2 * m)), ncol, ncol)
    xlogx2 <- xlogx + t(xlogx)
    xlogx2[upper.tri(xlogx2, diag=TRUE)] <- 0

    xx <- mclapply(seq_len(ncol)[-1], function(i, m) {
        j <- seq_len(i - 1L)
        xy <- m[, i] + m[, j, drop=FALSE]
        colSums(xy * log(xy))
    }, m, ..., mc.cores=mc.cores)

    xylogxy <- matrix(0, ncol, ncol)
    xylogxy[upper.tri(xylogxy, diag=FALSE)] <- unlist(xx)

    sqrt(0.5 * (xlogx2 - t(xylogxy)))
}

我的笔记本电脑有8个标称内核，1000个列我有

> system.time(xx <- dist4p(m1000))
   user  system elapsed 
 48.909   1.939   8.043

建议我在8秒的时钟内获得48秒的处理器时间。该算法仍然是二次的，因此对于完整问题，这可能会将总计算时间减少到大约1小时。内存可能会成为多核计算机上的问题，其中所有进程都在竞争相同的内存池;可能需要选择mc.cores小于可用数量。

对于较大的ncol，获得更好性能的方法是避免计算完整的距离集。根据数据的性质，过滤重复列可能是有意义的，或过滤信息列（例如，方差最大），或......适当的策略需要有关列代表什么和目标的更多信息用于距离矩阵。 “我和其他公司的公司有多相似？”可以在不计算全距离矩阵的情况下回答，只需要一行，所以如果询问的问题相对于公司总数的次数很少，那么可能没有必要计算全距离矩阵？另一个策略可能是通过以下方式减少要聚集的公司数量：（1）使用主成分分析简化1000行测量，（2）对所有50k公司进行kmeans聚类以识别1000个质心，以及（3）使用插值测量和Jensen-Shannon之间的距离用于聚类。

Answer 2

我确信有比以下方法更好的方法，但只需将JSD和sum替换为log函数本身就可以轻松转换为Rcpp函数相当于Rcpp糖，并使用std::sqrt代替R base::sqrt。

#include <Rcpp.h>

// [[Rcpp::export]]
double cppJSD(const Rcpp::NumericVector& x, const Rcpp::NumericVector& y) {
  return std::sqrt(0.5 * (Rcpp::sum(x * Rcpp::log(x/((x+y)/2))) +
                          Rcpp::sum(y * Rcpp::log(y/((x+y)/2)))));
}

我只使用您的dist.JST_2方法进行了测试（因为它是速度最快的版本），但无论实现如何，使用cppJSD代替JSD时都会看到改进：

R> microbenchmark::microbenchmark(
    two_loops = dist.JSD_2(m),
    cpp = dist.JSD_cpp(m),
    times=100L)
Unit: milliseconds
      expr      min       lq     mean   median       uq      max neval
 two_loops 41.25142 41.34755 42.75926 41.45956 43.67520 49.54250   100
       cpp 36.41571 36.52887 37.49132 36.60846 36.98887 50.91866   100

修改实际上，您的dist.JSD_2函数本身可以很容易地转换为Rcpp函数以进一步加速：

// [[Rcpp::export("dist.JSD_cpp2")]] Rcpp::NumericMatrix foo(const Rcpp::NumericMatrix& inMatrix) { size_t cols = inMatrix.ncol(); Rcpp::NumericMatrix result(cols, cols); for (size_t i = 1; i < cols; i++) { for (size_t j = 0; j < i; j++) { result(i,j) = cppJSD(inMatrix(Rcpp::_, i), inMatrix(Rcpp::_, j)); } } return result; }

（其中cppJSD在与上述相同的.cpp文件中定义。以下是时间安排：

R> microbenchmark::microbenchmark( two_loops = dist.JSD_2(m), partial_cpp = dist.JSD_cpp(m), full_cpp = dist.JSD_cpp2(m), times=100L) Unit: milliseconds expr min lq mean median uq max neval two_loops 41.25879 41.36729 42.95183 41.84999 44.08793 54.54610 100 partial_cpp 36.45802 36.62463 37.69742 36.99679 37.96572 44.26446 100 full_cpp 32.00263 32.12584 32.82785 32.20261 32.63554 38.88611 100

dist.JSD_2 <- function(inMatrix) { matrixColSize <- ncol(inMatrix) resultsMatrix <- matrix(0, matrixColSize, matrixColSize) for(i in 2:matrixColSize) { for(j in 1:(i-1)) { resultsMatrix[i,j]=JSD(inMatrix[,i], inMatrix[,j]) } } return(resultsMatrix) } ## dist.JSD_cpp <- function(inMatrix) { matrixColSize <- ncol(inMatrix) resultsMatrix <- matrix(0, matrixColSize, matrixColSize) for(i in 2:matrixColSize) { for(j in 1:(i-1)) { resultsMatrix[i,j]=cppJSD(inMatrix[,i], inMatrix[,j]) } } return(resultsMatrix) }

m <- runif(24000, min = 0, max = 1) m <- matrix(m, 24, 1000) prob_dist <- function(x) t(apply(x, 1, prop.table)) JSD <- function(x,y) sqrt(0.5 * (sum(x*log(x/((x+y)/2))) + sum(y*log(y/((x+y)/2))))) m <- t(prob_dist(m)) m[m==0] <- 0.000001

哪个R实现提供了最快的JSD矩阵计算？

2 个答案: