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

Posted 2023-04-18

【中文标题】R中非常大的矩阵计算有效

【英文标题】：very large matrix calculation in R efficiently

【发布时间】：2017-07-19 12:44:56

【问题描述】：

我是 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

【问题讨论】：

psm_final_sample.csv在哪里？

@F.Privé 请检查编辑的链接。示例数据集链接（4700 行 - psm_final_sample.csv）>> 1drv.ms/u/s!AhoddsPPvdj3hVjrNTgkV0noqMk8

which(x[,i] & x[,j]) 的目的是什么。这些不合逻辑？

@F.Privé 是的，我可以从 lsa 库中删除这个 cosinesim 和带有 lsa::cosine 的循环，但实现具有相同的结果！ :( 坚持下去！！

你真的想要一个 46500 x 46500 的距离矩阵吗？

【参考方案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 会有很大帮助。

【讨论】：

> 可以使用 lsa::cosine 包删除 cosinesim 函数和循环。我检查了 cosinesim 和 lsa::cosine 实现，但结果相同！据我所知，mclapply 不适用于 Windows，因为我有 Windows 10 机器！我不知道 Rcpp，因为我是 R 的新手。

windows 使用parLapply，比mclapply 稍微费点力。