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

我正在寻找一种方法来加速这个算法

我的情况如下。我有一个数据集，有25000个用户，有6个习惯。我的目标是为25000个用户开发一个分层集群。我在一台16核128GB内存的服务器上运行这个程序。 我花了3周的时间，仅10000名用户在我的服务器上不间断地使用6个核心来计算这个距离矩阵。你可以想象，这对我的研究来说太长了

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

我的算法的第一步是建立一个距离矩阵。我使用Hellinger距离来计算距离，这与一些使用cathersian/Manhattan的软件包相反。我需要海林格距离，明白吗

我目前尝试的是通过应用多核进程来加速算法，每个进程在一个单独的核上有6个习惯。两件事可能有助于加速

（1） C实现-但我不知道如何做（我不是C程序员）如果这有帮助的话，你能在C实现上帮助我吗

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

还有其他想法吗

向朱仁问好

# 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)

       }

#一个习惯的示例，有100个用户，PMF有5列
Habit1优化代码的第一件事是评测。通过分析您提供的代码，似乎主要的瓶颈是
HellingerDistance
函数


改进算法。在
HellingerDistance
函数中，可以看到，当计算每对的距离时，每次都要重新计算平方根，这完全是浪费时间。因此，这里是改进版，
CalculatedInstances1
是新函数，它首先计算
x
的平方根，然后使用新的
HellingerDistanceSqrt
计算Hellinger距离，可以看出新版本的速度提高了40%

改进数据结构。我还注意到原始
calulateddistance
函数中的
x
是一个
data.frame
重载过多，因此我通过
as.matrix
将其转换为一个矩阵，这使得代码速度快了一个数量级以上


最后，新的
CalculateInstances1
比我机器上的原始版本快70多倍

# 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)

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))

}

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

    # hellinger distance function
    return(sqrt(sum(((sqrtx[1,] - sqrtx[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)

}


calculatedistances1 <- 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

    x <- sqrt(as.matrix(x))



    #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) HellingerDistanceSqrt(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)

}

# actual calculation
system.time(Result<-calculatedistances(Habit1))
system.time(Result1<-calculatedistances1(Habit1))
identical(Result, Result1)

#一个习惯的示例，有100个用户，PMF有5列
Habit1我知道这不是一个完整的答案，但这个建议太长，无法发表评论

下面是我将如何使用
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)]

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

# 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

#更改第一列名称以避免冲突
名称（D）[1:2]相同（D$H，D$H2，D$H3）
#>[1]是的
我建议（1）将矩阵更改为
long
格式，（2）使用
data.table
计算成对观察值之间的距离，（3）必要时将结果转换回
wide
格式的矩阵。谢谢你的回答，我不完全理解你的解决方案，也不理解链接中的示例。该链接显示了空间距离的解决方案，而不是Hellinger距离。1.数据的长格式是习惯性的，这就是你的意思吗？2.如何最好地实现
数据。表
以计算成对观测值之间的差异？感谢您的回答R中有一个
hellinger
函数。您考虑过使用它吗？我考虑过这个函数，但是正态
hellinger
函数是分布函数，而不是离散分布本身。因此，我必须编写自己的函数。但是谢谢你的建议。谢谢你的回答。我今晚会努力实现这个。我查看了
HellingerDist{distrEx}
函数，但在这个过程中的某个地方，我决定使用我自己的函数，问题是我记得为什么。我现在尝试实现您的解决方案，但实际上它并没有完全满足我的需要。我确实对你的代码有一些问题。如何使
列表（I.col1、I.col2、I.col3、I.col4、I.col5）
动态？我需要这个，因为有些习惯有256个值，而另一些可能只有10个。算法需要是动态的。其次，建议的
H
确实不正确，也应该是动态的。是否可以选择从
id[n]\u col[n]
创建一个矩阵，并将其传递给另一个解决方案中的Hellinger距离函数？感谢第一个问题的解决
感谢公司成立。我的l（尚未优化的版本）现在可以在11分钟内为10000个用户运行，而不是3周。
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）
可以通过相同的
mget（）
函数进行动态设置，不是吗？我已经做了一些更改以处理您的评论。检查结果是否与您原来的方法相同。同样感谢您的回答。我确实忘了分析函数。一旦函数通过了一些测试结果，我就实现了它，并在整个数据集上运行它。结果是我不想干扰计算过程，所以我一直等到它结束
# 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