R中非常大的矩阵计算有效

Question

我是 R 的新手。我有一个包含 139 列和超过 46.5k 行的数据集。我已经测量了数据集中行之间的成对余弦相似度矩阵，其中一行将与其他行的其余行进行比较，并将在下一次迭代期间被排除，并且该过程将针对数据集的其余部分继续进行。此实现适用于小样本数据集，例如有 500 行。但是，当我尝试对整个数据集（46k）执行此操作时，它会变得很糟糕（我已经等了将近 30 个小时运行代码但没有输出）。到目前为止，这是我的实现：

library(reshape2)
library(lsa)


psm_sample <- read.csv("psm_final_sample.csv")
numRows = nrow(psm_sample)


##################################

normalize <- function(x) {
  return ( (2 * ((x - min(x)) / (max(x) - min(x))) ) - 1 )
}

##################################
cat_normalize <- function(x) {

  norm <-  ( (2 * ((x - min(x)) / (max(x) - min(x))) ) - 1 )
  return (ifelse(norm < 0 , -1, 1))
}

#############################

cat_gender <- function (sex){
  sex <- as.character(sex)

  if( sex == 'M' ) {
    return (as.integer(1))
  }
  else{
    return(as.integer(2))
  }
}

##################################

cat_admsn_type <- function (type){
  type <- as.character(type)

  if( type == 'EMERGENCY' ) {
    return(as.integer(1))
  }
  else if ( type == 'URGENT'){ 
    return(as.integer(2))
  }
  else{
    return(as.integer(3))
  }
}

#############################

cat_first_icu <- function (ficu){
  type <- as.character(ficu)

  if( ficu == 'CCU' ) {
    return(as.integer(1))
  }
  else if ( ficu == 'CSRU'){ 
    return(as.integer(2))
  }
  else if ( ficu == 'MICU'){ 
    return(as.integer(3))
  }
  else if ( ficu == 'NICU'){ 
    return(as.integer(4))
  }
  else if ( ficu == 'SICU'){ 
    return(as.integer(5))
  }
  else{
    return(as.integer(6))
  }
}

##################################

cat_last_icu <- function (licu){
  type <- as.character(licu)

  if( licu == 'CCU' ) {
    return(as.integer(1))
  }
  else if ( licu == 'CSRU'){ 
    return(as.integer(2))
  }
  else if ( licu == 'MICU'){ 
    return(as.integer(3))
  }
  else if ( licu == 'NICU'){ 
    return(as.integer(4))
  }
  else if ( licu == 'SICU'){ 
    return(as.integer(5))
  }
  else{
    return(as.integer(6))
  }
}

#################################################################################

gender <- sapply(psm_sample$gender,cat_gender)
admission_type <- sapply(psm_sample$admission_type,cat_admsn_type)
first_icu_service_type <- sapply(psm_sample$first_icu_service_type,cat_first_icu)
last_icu_service_type <- sapply(psm_sample$last_icu_service_type,cat_last_icu)

################################################################################

psm_sample_cont_norm_df <- as.data.frame(lapply(psm_sample[8:138], normalize))
psm_sample_cat_df <- data.frame(gender,admission_type,first_icu_service_type,last_icu_service_type)
psm_sample_cat_norm_df <- as.data.frame(lapply(psm_sample_cat_df, cat_normalize))

psm_temp_df <- cbind.data.frame(psm_sample[1], psm_sample_cat_norm_df, psm_sample_cont_norm_df)


row.names(psm_temp_df ) <- make.names(paste0("patid.", as.character(1:nrow(psm_temp_df ))))
psm_final_df <- psm_temp_df[2:136]

###############################################################################


#mycosine <- function(x,y){
#c <- sum(x*y) / (sqrt(sum(x*x)) * sqrt(sum(y*y)))
  #return(c)
#}

#cosinesim <- function(x) {
  # initialize similarity matrix
  #m <- matrix(NA, nrow=ncol(x),ncol=ncol(x),dimnames=list(colnames(x),colnames(x)))
  #cos <- as.data.frame(m)

  #for(i in 1:ncol(x)) {
    #for(j in i:ncol(x)) {
      #co_rate_1 <- x[which(x[,i] & x[,j]),i]
      #co_rate_2 <- x[which(x[,i] & x[,j]),j]  
      #cos[i,j]= mycosine(co_rate_1,co_rate_2)
      #cos[j,i]=cos[i,j]        
    #}
  #}
  #return(cos)
#}

cs <- lsa::cosine(t(psm_final_df))

cs_round <-round(cs,digits = 2)



#cs_norm <- as.data.frame(lapply(cs,normalize))
#print(cs_norm)
#print(cs_round)

##########################################

numCols = 3;
totalROws = (numRows * (numRows-1)) / 2;
result <- matrix(nrow = totalROws, ncol = numCols)
#result<- big.matrix( nrow = totalROws, ncol = numCols, type = "double",shared = TRUE)
#options(bigmemory.allow.dimnames=TRUE)

colnames(result) <- c("PatA","PatB","Similarity")

index = 1;
for (i in 1:nrow(cs_round)) {
  patA = rownames(cs_round)[i]
  for (j in i:ncol(cs_round)) {
    if (j > i) {
      patB = colnames(cs_round)[j]
      result[index, 1] = patA
      result[index, 2] = patB
      result[index, 3] = cs_round[i,j]

      index = index + 1;
    }
  }
}

print(result)

write.csv(result, file = "C:/cosine/output.csv", row.names = F)
#ord_result<-result[order(result[,3],decreasing=TRUE),]
#print(ord_result)

在这种情况下，我可以将数据集分成最高 10 个子集。然后，每个数据集中将有 4650 行。因此，对于 4650 行，它仍然是一个非常大的矩阵计算，我必须等待很长时间才能输出。

我已经尝试过使用这种实现的大内存、ff 和矩阵包，但据我所知没有取得丰硕的成果。

任何类型的建议或代码修改或如何有效地进行都会对我非常有帮助。

注意：我的机器有 8GBDDR3 RAM 和 i3 处理器，时钟速度为 2.10GHz。我使用的是 64 位 R studio。

整个数据集的链接（46.5 KRows - psm_final_without_null.csv）>> https://1drv.ms/u/s!AhoddsPPvdj3hVVFC-yl1tDKEfo8

示例数据集的链接（4700 行 - psm_final_sample.csv）>> https://1drv.ms/u/s!AhoddsPPvdj3hVjrNTgkV0noqMk8

Answer 1

有相当多的空间来优化代码/算法。仅举几例：

co_rate_1 <- x[which(x[,i] & x[,j]),i]
co_rate_2 <- x[which(x[,i] & x[,j]),j]

主要的计算负担是which 函数，显然您不必计算两次，顺便说一句，which 通常是一个缓慢的函数，在计算密集型代码中使用它通常不是一个好主意。 更新：我认为这里不需要which，您可以放心地删除它。

cosinesim 生成的矩阵是一个对称矩阵，这意味着您实际上只需要计算一半的元素。

您在函数中使用的 for 循环构成“令人尴尬的并行”问题，这意味着您可以从并行函数的一些简单实现中受益，例如 mclapply。

我也确信在 Rcpp 中重写 cosinesim 会有很大帮助。