Question

我正在寻找加速此算法的方法。

我的情况如下。我有一个拥有25,000个用户和6个习惯的数据集。我的目标是为25,000个用户开发层次化群集。我在一个16核，128GB RAM的服务器上运行它。我花了3个星期只为10,000名用户在我的服务器上不停地使用6个核心来计算这个距离矩阵。你可以想象这对我的研究来说太长了。

对于6种习惯中的每一种，我都创建了概率质量分布（PMF）。 PMF每个habbit的大小（列）可能不同。有些习惯有10列，大约有256列，所有这些都取决于具有最多不合时宜行为的用户。

我的算法的第一步是开发距离矩阵。我使用Hellinger距离来计算距离，这与使用例如的一些包裹相反。 cathersian /曼哈顿。我确实需要Hellinger距离，请参阅https://en.wikipedia.org/wiki/Hellinger_distance

我目前尝试的是通过应用多核处理来加速算法，每个处理6个习惯在一个单独的核心上。两件可能对加速有利的事情

（1）C实现 - 但我不知道如何做到这一点（我不是C程序员）如果这对C实现有帮助，你能帮助我吗？

（2）通过自己连接在桌子上制作一个carthesian产品，并使所有行和那里的行进行逐行计算。有一点，R在默认情况下会给出错误，例如： data.table。有什么建议吗？

还有其他想法吗？

最诚挚的问候Jurjen

# example for 1 habit with 100 users and a PMF of 5 columns
Habit1<-data.frame(col1=abs(rnorm(100)),
               col2=abs(c(rnorm(20),runif(50),rep(0.4,20),sample(seq(0.01,0.99,by=0.01),10))),
               col3=abs(c(rnorm(30),runif(30),rep(0.4,10),sample(seq(0.01,0.99,by=0.01),30))), 
               col4=abs(c(rnorm(10),runif(10),rep(0.4,20),sample(seq(0.01,0.99,by=0.01),60))),
               col5=abs(c(rnorm(50),runif(10),rep(0.4,10),sample(seq(0.01,0.99,by=0.01),30))))

  # give all users a username same as rowname 
  rownames(Habit1)<- c(1:100)

  # actual calculation  
  Result<-calculatedistances(Habit1)



         HellingerDistance <-function(x){
           #takes two equal sized vectors and calculates the hellinger distance between the vectors

           # hellinger distance function
           return(sqrt(sum(((sqrt(x[1,]) - sqrt(x[2,]))^2)))/sqrt(2))

         }


       calculatedistances <- function(x){
         # takes a dataframe of user IID in the first column and a set of N values per user thereafter 

         # first set all NA to 0
         x[is.na(x)] <- 0



         #create matrix of 2 subsets based on rownumber
         # 1 first the diagronal with 
         D<-cbind(matrix(rep(1:nrow(x),each=2),nrow=2),combn(1:nrow(x), 2))

         # create a dataframe with hellinger distances
         B <<-data.frame(first=rownames(x)[D[1,]],
                        second=rownames(x)[D[2,]],
                        distance=apply(D, 2, function(y) HellingerDistance(x[ y,]))
         )


         # reshape dataframe into a matrix with users on x and y axis
         B<<-reshape(B, direction="wide", idvar="second", timevar="first")

         # convert wide table to distance table object
         d <<- as.dist(B[,-1], diag = FALSE)
         attr(d, "Labels") <- B[, 1]
         return(d)

       }

Answer 1

优化代码的第一件事是分析。通过分析您提供的代码，似乎主要的瓶颈是HashMap函数。

改进算法。在HellingerDistance函数中，可以看出在计算每对的距离时，每次都会重新计算平方根，这是浪费时间。所以这里是改进版本，HellingerDistance是新函数，它首先计算calculatedistances1的平方根并使用新x来计算Hellinger距离，可以看到新版本速度提高40％。
改善数据结构。我还注意到原始HellingerDistanceSqrt函数中的x是一个过载太多的calulatedistance，因此我将其转换为data.frame的矩阵，这使代码更快超过一个数量级。

最后，新的as.matrix比我机器上的原始版本快70倍。

calculatedistances1

Answer 2

我知道这不是一个完整的答案，但这个建议太长了，无法发表评论。

以下是我将如何使用data.table来加快这一过程。它的方式，这个代码仍然没有达到你要求的可能，因为我不完全确定你想要什么，但希望这将清楚地说明如何从这里开始。

另外，您可能需要查看HellingerDist{distrEx}函数来计算Hellinger距离。

library(data.table)

# convert Habit1 into a data.table
  setDT(Habit1)

# assign ids instead of working with rownames
  Habit1[, id := 1:100] 

# replace NAs with 0
  for (j in seq_len(ncol(Habit1)))
    set(Habit1, which(is.na(Habit1[[j]])),j,0)

# convert all values to numeric
  for (k in seq_along(Habit1)) set(Habit1, j = k, value = as.numeric(Habit1[[k]]))


# get all possible combinations of id pairs in long format
  D <- cbind(matrix(rep(1:nrow(Habit1),each=2),nrow=2),combn(1:nrow(Habit1), 2))
  D <- as.data.table(D)
  D <- transpose(D)


# add to this dataset the probability mass distribution (PMF) of each id V1 and V2
# this solution dynamically adapts to number of columns in each Habit dataset
  colnumber <- ncol(Habit1) - 1
  cols <- paste0('i.col',1:colnumber) 

  D[Habit1, c(paste0("id1_col",1:colnumber)) := mget(cols ), on=.(V1 = id)]
  D[Habit1, c(paste0("id2_col",1:colnumber)) := mget(cols ), on=.(V2 = id)]


# [STATIC] calculate hellinger distance 
D[, H := sqrt(sum(((sqrt(c(id1_col1,  id1_col2,  id1_col3,  id1_col4,   id1_col5)) - sqrt(c(id2_col1,  id2_col2,  id2_col3,  id2_col4,   id2_col5)))^2)))/sqrt(2) , by = .(V1, V2)]

现在，如果您希望灵活设置每个habit数据集中的列数：

# get names of columns
  part1 <- names(D)[names(D) %like% "id1"]
  part2 <- names(D)[names(D) %like% "id2"]

# calculate distance 
  D[, H2 := sqrt(sum(((sqrt( .SD[, ..part1] ) - sqrt( .SD[, ..part2] ))^2)))/sqrt(2) , by = .(V1,V2) ]

现在，为了更快的距离计算

# change 1st colnames to avoid conflict 
  names(D)[1:2] <- c('x', 'y')

# [dynamic] calculate hellinger distance
  D[melt(D, measure = patterns("^id1", "^id2"), value.name = c("v", "f"))[
  , sqrt(sum(((sqrt( v ) - sqrt( f ))^2)))/sqrt(2), by=.(x,y)], H3 := V1,  on = .(x,y)]

# same results
#> identical(D$H, D$H2, D$H3)
#> [1] TRUE

加速R算法计算Hellinger距离的距离矩阵

2 个答案: