使用大型数据集在 R 中创建二进制矩阵
Creating Binary Matrix in R with a large dataset
我在 linux 机器上使用 R 版本 3.2.3。
我有一个数据集，其中包含 145 个变量的 1,374,439 个观测值。我需要将此数据帧转换为二进制矩阵。
我查看了不同的论坛，找到了一个解决方案，其中包含包 reshape2 以及函数 melt() 和 dcast()。这非常适用于小型数据集（我总是首先在小部件上尝试我的代码，以检查它是否在做我想要的事情）。当我想在整个数据集上使用这段代码时，它不再起作用了。
我看过其他论坛，我试过（没有成功），以下功能：
table()sparseMatrix() 和 as.Matrix()xtabs()
我还发现了 dplyr 和 tidyr 包用于更大的数据集。但是我没有成功。老实说，我也为理解而苦苦挣扎。但似乎我的数据集的大小是主要问题...
数据看起来是这样的（这是一个版本短版）：
Code_1 Code_2 Code_3 Code_4 Code_5 Code_6 Code_7
1 M201 M2187 M670
2 O682 O097 Z370 O48 O759
3 S7211 Z966 Z501
我想要这个（二进制矩阵）：
M201 M2187 M670 O682 O097 Z370 O48 0759 S7211 Z966 Z501
1 1 1 1 0 0 0 0 0 0 0 0
2 0 0 0 1 1 1 1 1 0 0 0
3 0 0 0 0 0 0 0 0 1 1 1
我还想准确地说，空格不是 NA。真的是空格
我们可以在 melt 将数据转换为 long 格式 and remove the blank (''`) 元素后应用 table。
library(reshape2)
table(droplevels(subset(melt(as.matrix(df1)), value!='', select = -2)))
# value
# Var1 M201 M2187 M670 O097 O48 O682 O759 S7211 Z370 Z501 Z966
# 1 1 1 1 0 0 0 0 0 0 0 0
# 2 0 0 0 1 1 1 1 0 1 0 0
# 3 0 0 0 0 0 0 0 1 0 1 1
或使用dplyr/tidyr
library(dplyr)
library(tidyr)
data_frame(rn = rep(1:nrow(df1), ncol(df1)), v1 = unlist(df1)) %>%
filter(v1!="") %>%
group_by(rn, v1) %>%
summarise(n = n()) %>%
spread(v1, n, fill = 0)
# rn M201 M2187 M670 O097 O48 O682 O759 S7211 Z370 Z501 Z966
# <int> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
#1 1 1 1 1 0 0 0 0 0 0 0 0
#2 2 0 0 0 1 1 1 1 0 1 0 0
#3 3 0 0 0 0 0 0 0 1 0 1 1
或使用 data.table
中的 dcast
library(data.table)
dcast(data.table(rn = rep(1:nrow(df1), ncol(df1)),
v1 = unlist(df1))[v1!=''], rn~v1, length)
# rn M201 M2187 M670 O097 O48 O682 O759 S7211 Z370 Z501 Z966
#1: 1 1 1 1 0 0 0 0 0 0 0 0
#2: 2 0 0 0 1 1 1 1 0 1 0 0
#3: 3 0 0 0 0 0 0 0 1 0 1 1
这是基本的 R 方法：
## define input data.frame
data <- data.frame(Code_1=c('M201','O682','S7211'),Code_2=c('','','Z966'),Code_3=c('M2187',
'O097',''),Code_4=c('M670','Z370','Z501'),Code_5=c('','',''),Code_6=c('','O48',''),Code_7=c(
'','O759',''),stringsAsFactors=F);
## coerce to a matrix to speed up subsequent operations
data <- as.matrix(data);
## solution
im <- which(arr.ind=T,data!='');
u <- unique(data[im[order(im[,'row'],im[,'col']),]]);
res <- matrix(0L,nrow(data),length(u),dimnames=list(NULL,u));
res[cbind(im[,'row'],match(data[im],u))] <- 1L;
res;
## M201 M2187 M670 O682 O097 Z370 O48 O759 S7211 Z966 Z501
## [1,] 1 1 1 0 0 0 0 0 0 0 0
## [2,] 0 0 0 1 1 1 1 1 0 0 0
## [3,] 0 0 0 0 0 0 0 0 1 1 1
基准测试
library(microbenchmark);
library(reshape2);
library(dplyr);
library(tidyr);
library(data.table);
akrun1 <- function(df1) table(droplevels(subset(melt(as.matrix(df1)),value!='',select=-2)));
akrun2 <- function(df1) data_frame(rn=rep(1:nrow(df1),ncol(df1)),v1=unlist(df1)) %>% filter(v1!="") %>% group_by(rn,v1) %>% summarise(n=n()) %>% spread(v1,n,fill=0) %>% ungroup() %>% select(-rn);
akrun3 <- function(df1) dcast(data.table(rn=rep(1:nrow(df1),ncol(df1)),v1=unlist(df1))[v1!=''],rn~v1,length,value.var='v1')[,!'rn',with=FALSE];
bgoldst <- function(data) { data <- as.matrix(data); im <- which(arr.ind=T,data!=''); u <- unique(data[im[order(im[,'row'],im[,'col']),]]); res <- matrix(0L,nrow(data),length(u),dimnames=list(NULL,u)); res[cbind(im[,'row'],match(data[im],u))] <- 1L; res; };
harmonize <- function(res) {
res <- as.matrix(if ('table'%in%class(res)) unclass(res) else res);
res <- res[,order(colnames(res))];
res <- res[do.call(order,as.data.frame(res)),];
res;
}; ## end harmonize()
## OP's example
data <- data.frame(Code_1=c('M201','O682','S7211'),Code_2=c('','','Z966'),Code_3=c('M2187','O097',''),Code_4=c('M670','Z370','Z501'),Code_5=c('','',''),Code_6=c('','O48',''),Code_7=c('','O759',''),stringsAsFactors=F);
ex <- harmonize(akrun1(data));
all.equal(ex,harmonize(akrun2(data)),check.attributes=F);
## [1] TRUE
all.equal(ex,harmonize(akrun3(data)),check.attributes=F);
## [1] TRUE
all.equal(ex,harmonize(bgoldst(data)),check.attributes=F);
## [1] TRUE
microbenchmark(akrun1(data),akrun2(data),akrun3(data),bgoldst(data));
## Unit: microseconds
## expr min lq mean median uq max neval
## akrun1(data) 1155.945 1287.2345 1356.0013 1356.301 1396.072 1745.678 100
## akrun2(data) 4053.292 4313.7315 4639.1197 4544.664 4763.408 6839.875 100
## akrun3(data) 5866.965 6115.4320 6542.8618 6353.848 6601.886 11951.178 100
## bgoldst(data) 108.197 144.1195 162.6198 162.936 180.684 240.769 100
## scale test
set.seed(1L);
NR <- 1374439L; NC <- 145L; NU <- as.integer(11/7*NC); probBlank <- 10/21;
repeat { u <- paste0(sample(LETTERS,NU,T),sprintf('%03d',sample(0:999,NU,T))); if (length(u)==NU) break; };
data <- setNames(nm=paste0('Code_',seq_len(NC)),as.data.frame(matrix(sample(c('',u),NR*NC,T,c(probBlank,rep((1-probBlank)/NU,NU))),NR)));
ex <- harmonize(akrun1(data));
all.equal(ex,harmonize(akrun2(data)),check.attributes=F);
## Error: cannot allocate vector of size 1.5 Gb
all.equal(ex,harmonize(akrun3(data)),check.attributes=F);
## Error: cannot allocate vector of size 1.5 Gb
all.equal(ex,harmonize(bgoldst(data)),check.attributes=F);
## [1] "Mean relative difference: 1.70387"
microbenchmark(akrun1(data),bgoldst(data),times=1L);
## Unit: seconds
## expr min lq mean median uq max neval
## akrun1(data) 101.81215 101.81215 101.81215 101.81215 101.81215 101.81215 1
## bgoldst(data) 30.82899 30.82899 30.82899 30.82899 30.82899 30.82899 1
我不知道为什么我的结果与 akrun1() 不一样，但他的结果似乎是不正确的，因为他有非二进制值：
unique(c(ex));
## [1] 0 1 2 3 4 5 6 7 8
您真正需要的是 Matrix::sparse.model.matrix() 功能。下面的答案会创建密集矩阵，这将很快吃掉您在此数据集上的所有内存。
这是一个简单的例子：
M = sparse.model.matrix( ~ ., data=data.frame(x = letters , y = LETTERS))
如果不需要拦截，使用下面的公式
M = sparse.model.matrix( ~ -1 + ., data=data.frame(x = letters , y = LETTERS))
我在 linux 机器上使用 R 版本 3.2.3。
我有一个数据集，其中包含 145 个变量的 1,374,439 个观测值。我需要将此数据帧转换为二进制矩阵。
我查看了不同的论坛，找到了一个解决方案，其中包含包 reshape2 以及函数 melt() 和 dcast()。这非常适用于小型数据集（我总是首先在小部件上尝试我的代码，以检查它是否在做我想要的事情）。当我想在整个数据集上使用这段代码时，它不再起作用了。
我看过其他论坛，我试过（没有成功），以下功能：
table()sparseMatrix()和as.Matrix()xtabs()
我还发现了 dplyr 和 tidyr 包用于更大的数据集。但是我没有成功。老实说，我也为理解而苦苦挣扎。但似乎我的数据集的大小是主要问题...
数据看起来是这样的（这是一个版本短版）：
Code_1 Code_2 Code_3 Code_4 Code_5 Code_6 Code_7
1 M201 M2187 M670
2 O682 O097 Z370 O48 O759
3 S7211 Z966 Z501
我想要这个（二进制矩阵）：
M201 M2187 M670 O682 O097 Z370 O48 0759 S7211 Z966 Z501
1 1 1 1 0 0 0 0 0 0 0 0
2 0 0 0 1 1 1 1 1 0 0 0
3 0 0 0 0 0 0 0 0 1 1 1
我还想准确地说，空格不是 NA。真的是空格
我们可以在 melt 将数据转换为 long 格式 and remove the blank (''`) 元素后应用 table。
library(reshape2)
table(droplevels(subset(melt(as.matrix(df1)), value!='', select = -2)))
# value
# Var1 M201 M2187 M670 O097 O48 O682 O759 S7211 Z370 Z501 Z966
# 1 1 1 1 0 0 0 0 0 0 0 0
# 2 0 0 0 1 1 1 1 0 1 0 0
# 3 0 0 0 0 0 0 0 1 0 1 1
或使用dplyr/tidyr
library(dplyr)
library(tidyr)
data_frame(rn = rep(1:nrow(df1), ncol(df1)), v1 = unlist(df1)) %>%
filter(v1!="") %>%
group_by(rn, v1) %>%
summarise(n = n()) %>%
spread(v1, n, fill = 0)
# rn M201 M2187 M670 O097 O48 O682 O759 S7211 Z370 Z501 Z966
# <int> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
#1 1 1 1 1 0 0 0 0 0 0 0 0
#2 2 0 0 0 1 1 1 1 0 1 0 0
#3 3 0 0 0 0 0 0 0 1 0 1 1
或使用 data.table
dcast
library(data.table)
dcast(data.table(rn = rep(1:nrow(df1), ncol(df1)),
v1 = unlist(df1))[v1!=''], rn~v1, length)
# rn M201 M2187 M670 O097 O48 O682 O759 S7211 Z370 Z501 Z966
#1: 1 1 1 1 0 0 0 0 0 0 0 0
#2: 2 0 0 0 1 1 1 1 0 1 0 0
#3: 3 0 0 0 0 0 0 0 1 0 1 1
这是基本的 R 方法：
## define input data.frame
data <- data.frame(Code_1=c('M201','O682','S7211'),Code_2=c('','','Z966'),Code_3=c('M2187',
'O097',''),Code_4=c('M670','Z370','Z501'),Code_5=c('','',''),Code_6=c('','O48',''),Code_7=c(
'','O759',''),stringsAsFactors=F);
## coerce to a matrix to speed up subsequent operations
data <- as.matrix(data);
## solution
im <- which(arr.ind=T,data!='');
u <- unique(data[im[order(im[,'row'],im[,'col']),]]);
res <- matrix(0L,nrow(data),length(u),dimnames=list(NULL,u));
res[cbind(im[,'row'],match(data[im],u))] <- 1L;
res;
## M201 M2187 M670 O682 O097 Z370 O48 O759 S7211 Z966 Z501
## [1,] 1 1 1 0 0 0 0 0 0 0 0
## [2,] 0 0 0 1 1 1 1 1 0 0 0
## [3,] 0 0 0 0 0 0 0 0 1 1 1
基准测试
library(microbenchmark);
library(reshape2);
library(dplyr);
library(tidyr);
library(data.table);
akrun1 <- function(df1) table(droplevels(subset(melt(as.matrix(df1)),value!='',select=-2)));
akrun2 <- function(df1) data_frame(rn=rep(1:nrow(df1),ncol(df1)),v1=unlist(df1)) %>% filter(v1!="") %>% group_by(rn,v1) %>% summarise(n=n()) %>% spread(v1,n,fill=0) %>% ungroup() %>% select(-rn);
akrun3 <- function(df1) dcast(data.table(rn=rep(1:nrow(df1),ncol(df1)),v1=unlist(df1))[v1!=''],rn~v1,length,value.var='v1')[,!'rn',with=FALSE];
bgoldst <- function(data) { data <- as.matrix(data); im <- which(arr.ind=T,data!=''); u <- unique(data[im[order(im[,'row'],im[,'col']),]]); res <- matrix(0L,nrow(data),length(u),dimnames=list(NULL,u)); res[cbind(im[,'row'],match(data[im],u))] <- 1L; res; };
harmonize <- function(res) {
res <- as.matrix(if ('table'%in%class(res)) unclass(res) else res);
res <- res[,order(colnames(res))];
res <- res[do.call(order,as.data.frame(res)),];
res;
}; ## end harmonize()
## OP's example
data <- data.frame(Code_1=c('M201','O682','S7211'),Code_2=c('','','Z966'),Code_3=c('M2187','O097',''),Code_4=c('M670','Z370','Z501'),Code_5=c('','',''),Code_6=c('','O48',''),Code_7=c('','O759',''),stringsAsFactors=F);
ex <- harmonize(akrun1(data));
all.equal(ex,harmonize(akrun2(data)),check.attributes=F);
## [1] TRUE
all.equal(ex,harmonize(akrun3(data)),check.attributes=F);
## [1] TRUE
all.equal(ex,harmonize(bgoldst(data)),check.attributes=F);
## [1] TRUE
microbenchmark(akrun1(data),akrun2(data),akrun3(data),bgoldst(data));
## Unit: microseconds
## expr min lq mean median uq max neval
## akrun1(data) 1155.945 1287.2345 1356.0013 1356.301 1396.072 1745.678 100
## akrun2(data) 4053.292 4313.7315 4639.1197 4544.664 4763.408 6839.875 100
## akrun3(data) 5866.965 6115.4320 6542.8618 6353.848 6601.886 11951.178 100
## bgoldst(data) 108.197 144.1195 162.6198 162.936 180.684 240.769 100
## scale test
set.seed(1L);
NR <- 1374439L; NC <- 145L; NU <- as.integer(11/7*NC); probBlank <- 10/21;
repeat { u <- paste0(sample(LETTERS,NU,T),sprintf('%03d',sample(0:999,NU,T))); if (length(u)==NU) break; };
data <- setNames(nm=paste0('Code_',seq_len(NC)),as.data.frame(matrix(sample(c('',u),NR*NC,T,c(probBlank,rep((1-probBlank)/NU,NU))),NR)));
ex <- harmonize(akrun1(data));
all.equal(ex,harmonize(akrun2(data)),check.attributes=F);
## Error: cannot allocate vector of size 1.5 Gb
all.equal(ex,harmonize(akrun3(data)),check.attributes=F);
## Error: cannot allocate vector of size 1.5 Gb
all.equal(ex,harmonize(bgoldst(data)),check.attributes=F);
## [1] "Mean relative difference: 1.70387"
microbenchmark(akrun1(data),bgoldst(data),times=1L);
## Unit: seconds
## expr min lq mean median uq max neval
## akrun1(data) 101.81215 101.81215 101.81215 101.81215 101.81215 101.81215 1
## bgoldst(data) 30.82899 30.82899 30.82899 30.82899 30.82899 30.82899 1
我不知道为什么我的结果与 akrun1() 不一样，但他的结果似乎是不正确的，因为他有非二进制值：
unique(c(ex));
## [1] 0 1 2 3 4 5 6 7 8
您真正需要的是 Matrix::sparse.model.matrix() 功能。下面的答案会创建密集矩阵，这将很快吃掉您在此数据集上的所有内存。
这是一个简单的例子：
M = sparse.model.matrix( ~ ., data=data.frame(x = letters , y = LETTERS))
如果不需要拦截，使用下面的公式
M = sparse.model.matrix( ~ -1 + ., data=data.frame(x = letters , y = LETTERS))