R 如何从一个巨大的矩阵中获得尽可能大的列序列和尽可能少的行NAs？
我希望从数据帧中选择列，以便生成的连续的列序列尽可能长，而带有NAs的行数尽可能少，因为它们必须在之后删除 （我想这样做的原因是，我想运行R 如何从一个巨大的矩阵中获得尽可能大的列序列和尽可能少的行NAs？,r,cluster-analysis,powerset,traminer,sequence-analysis,R,Cluster Analysis,Powerset,Traminer,Sequence Analysis,我希望从数据帧中选择列，以便生成的连续的列序列尽可能长，而带有NAs的行数尽可能少，因为它们必须在之后删除 （我想这样做的原因是，我想运行TraMineR:：seqsubm（）自动获得转移成本矩阵（按转移概率），然后在上面运行cluster:：agnes（）。TraMineR:：seqsubm（）不喜欢NA状态和cluster:：agnes（）矩阵中的NA状态不一定有多大意义。） 为此，我已经编写了一个工作程序，根据原则计算所有可能的功率子集，并检查它们是否为NA。它与表示10x5矩阵的玩具数据
TraMineR:：seqsubm（）cluster:：agnes（）TraMineR:：seqsubm（）NAcluster:：agnes（）NAd> d
id X1 X2 X3 X4 X5
1 A 1 11 21 31 41
2 B 2 12 22 32 42
3 C 3 13 23 33 NA
4 D 4 14 24 34 NA
5 E 5 15 25 NA NA
6 F 6 16 26 NA NA
7 G 7 17 NA NA NA
8 H 8 18 NA NA NA
9 I 9 NA NA NA NA
10 J 10 NA NA NA NA
11 K NA NA NA NA NA
seqRank2 <- function(d, id = "id") {
require(matrixStats)
# change structure, convert to matrix
ii <- as.character(d[, id])
dm <- d
dm[[id]] <- NULL
dm <- as.matrix(dm)
rownames(dm) <- ii
your.powerset = function(s){
l = vector(mode = "list", length = 2^length(s))
l[[1]] = numeric()
counter = 1L
for (x in 1L:length(s)) {
for (subset in 1L:counter) {
counter = counter + 1L
l[[counter]] = c(l[[subset]], s[x])
}
}
return(l[-1])
}
psr <- your.powerset(ii)
psc <- your.powerset(colnames(dm))
sss <- lapply(psr, function(x) {
i <- ii %in% x
lapply(psc, function(y) dm[i, y, drop = F])
})
cn <- sapply(sss, function(x)
lapply(x, function(y) {
if (ncol(y) == 1) {
if (any(is.na(y))) return(NULL)
return(y)
}
isna2 <- matrixStats::colAnyNAs(y)
if (all(isna2)) return(NULL)
if (sum(isna2) == 0) return(NA)
r <- y[, !isna2, drop = F]
return(r)
}))
scr <- sapply(cn, nrow)
scc <- sapply(cn, ncol)
namesCN <- sapply(cn, function(x) paste0(colnames(x), collapse = ", "))
names(scr) <- namesCN
scr <- unlist(scr)
names(scc) <- namesCN
scc <- unlist(scc)
m <- t(rbind(n.obs = scr, sq.len = scc))
ag <- aggregate(m, by = list(sequence = rownames(m)), max)
ag <- ag[order(-ag$sq.len, -ag$n.obs), ]
rownames(ag) <- NULL
return(ag)
}
d上正确运行。庞大的会导致当前的错误：
> seqRank2(d.huge)
Error in vector(mode = "list", length = 2^length(s)) :
vector size cannot be infinite
玩具数据d
：
附录（见评论和最新答案）：
d.max转换为矩阵并计算每列的Na计数：
dm <- is.na(d[, -1])
na_counts <- colSums(dm)
x <- data.frame(na_counts = na_counts, non_na_count = nrow(dm) - na_counts)
x <- as.matrix(x)
# create all combinations for column indexes:
nx <- 1:nrow(x)
psr <- do.call(c, lapply(seq_along(nx), combn, x = nx, simplify = FALSE))
# test if continuous:
good <- sapply(psr, function(y) !any(diff(sort.int(y)) != 1L))
psr <- psr[good == T] # remove non continuous
# for each combo count nas and non NA:
s <- sapply(psr, function(y) colSums(x[y, , drop = F]))
# put all together in table:
res <- data.frame(var_count = lengths(psr), t(s))
res$var_indexes <- sapply(psr, paste, collapse = ',')
res
# var_count na_counts non_na_count var_indexes
# 1 1 1 10 1
# 2 1 3 8 2
# 3 1 5 6 3
# 4 1 7 4 4
# 5 1 9 2 5
# 6 2 4 18 1,2
# 7 2 8 14 2,3
# 8 2 12 10 3,4
# 9 2 16 6 4,5
# 10 3 9 24 1,2,3
# 11 3 15 18 2,3,4
# 12 3 21 12 3,4,5
# 13 4 16 28 1,2,3,4
# 14 4 24 20 2,3,4,5
# 15 5 25 30 1,2,3,4,5
# choose
dm这在海量数据上花费的时间不到一秒钟
l1 = combn(2:length(d), 2, function(x) d[x[1]:x[2]], simplify = FALSE)
# If you also need "combinations" of only single columns, then uncomment the next line
# l1 = c(d[-1], l1)
l2 = sapply(l1, function(x) sum(complete.cases(x)))
score = sapply(1:length(l1), function(i) NCOL(l1[[i]]) * l2[i])
best_score = which.max(score)
best = l1[[best_score]]
问题不清楚如何对各种组合进行排序。我们可以使用不同的评分公式来生成不同的偏好。例如，要分别对行数和列数进行加权，我们可以
col_weight = 2
row_weight = 1
score = sapply(1:length(l1), function(i) col_weight*NCOL(l1[[i]]) + row_weight * l2[i])
只是澄清一下，TraMineR
中的seqsubm
函数对于NAs和不同长度的序列都没有任何问题。但是，函数需要一个状态序列对象（使用seqdef
创建）作为输入
函数seqsubm
用于通过不同方法计算状态之间的替代成本（即差异）。你可能会提到一种方法（'TRATE'
），该方法从观察到的转移概率中得出成本，即2-p（i | j）-p（j | i），其中p（i | j）是当我们在t-1中处于状态j时，t中处于状态i的概率。因此，我们所需要的只是转移概率，它可以很容易地从一组不同长度的序列或其中的间隙来估计
下面我使用随TraMineR
附带的ex1
数据进行说明。（由于您的玩具示例中存在大量不同的状态，因此生成的替代成本矩阵对于本图来说太大（28 x 28）
库（TraMineR）
数据（ex1）
总额（不适用（ex1））
# [1] 38
sq C->D->
#A->0 2.000 2.000
#B->2 0.000 2 1.823
#C->2.000 0 2.000
#D->21.823 2 0.000
现在，我不清楚你们想对国家差异做什么。将它们输入到聚类算法中，可以对状态进行聚类。如果要对序列进行聚类，则应首先计算序列之间的不相似性（使用seqdist
并可能将seqsubm
返回的替换成本矩阵作为sm
参数传递），然后在聚类算法中输入结果距离矩阵 我可能很傻，但为什么不在示例数据中选择X1、X2、X3呢？我不理解挑选的理由，这告诉我也许我不理解提问的权利……不，你完全正确，我已经编辑了挑选。但是，X1、X2、X3、X4
更好，因为生成的序列更长。由于NAs的原因，我需要通过获得序列长度的最大值和丢失行的最小值来最小化折衷。我仍然感到困惑。2-3-4有4*3，就像1-3-4和1-2-4一样。你在1-2-3上选择其中任何一个的理性是什么，也就是6*3，在1-2-3-4上选择1-2-3-4的理性是什么，因为它只有4*4。是否涉及称重？啊，因为1-2-3-4，1-2-3，2-3-4是连续的，我不能使用像1-2-*-4这样的间隙。我已经相应地编辑了这个问题。您有两个条件，但没有指定它们的优先顺序（如果有）或它们的加权方式（如果有）。如果我们有3列20行，或者4列19行，我们应该选择哪一个？我们如何决定？@iod所以我们没有列表，可能有不同的方法来实现这一点。你已经令人印象深刻地提高了大约500倍的速度。然而，输出是不正确的。代码按列计算NAs，因此接受带有NAs的行，但不应该接受。可以肯定的是，seqRank2（）
的输出完全正确，只需从输出中删除非连续的。在您的新代码中，non_na_count
输出对于1-2-3-4-5应该是10，对于1-2-3-4应该是16，对于1-2-3应该是18，对于2-3-4应该是12。Thx！我已经在真实数据上测试了代码，它似乎在一眨眼之间就能满足我的需要，但我不确定：（1）我对你写的两个sapply感到困惑，第一个是NCOL*l2
，第二个是NCOL+l2
。（2） 我玩了重量游戏，他们最近开始喜欢行或列。更确切地说，我在row_-weight:1.27e-1/col_-weight:1.780e1周围发现了一个（有点滑稽）阈值，但它只从一些列和许多行切换到所有列和少数行。使用附录编辑中的w/代码进行了测试。很高兴这对生成选项起到了很好的作用。我还向您展示了如何实现一些用于对选项进行排序的函数，即使您没有指定rankin
d.huge <- setNames(data.frame(matrix(1:15.3e5, 3e4, 51)),
c("id", paste0("X", 1:50)))
d.huge[, 41:51] <- lapply(d.huge[, 41:51], function(x){
x[which(x %in% sample(x, .05*length(x)))] <- NA
x
})
d.huge <- read.csv("d.huge.csv")
d.huge.1 <- d.huge[sample(nrow(d.huge), 3/4*nrow(d.huge)), ]
d1 <- seqRank3(d.huge.1, 1.27e-1, 1.780e1)
d2 <- d1[complete.cases(d1), ]
dim(d2)
names(d2)
dm <- is.na(d[, -1])
na_counts <- colSums(dm)
x <- data.frame(na_counts = na_counts, non_na_count = nrow(dm) - na_counts)
x <- as.matrix(x)
# create all combinations for column indexes:
nx <- 1:nrow(x)
psr <- do.call(c, lapply(seq_along(nx), combn, x = nx, simplify = FALSE))
# test if continuous:
good <- sapply(psr, function(y) !any(diff(sort.int(y)) != 1L))
psr <- psr[good == T] # remove non continuous
# for each combo count nas and non NA:
s <- sapply(psr, function(y) colSums(x[y, , drop = F]))
# put all together in table:
res <- data.frame(var_count = lengths(psr), t(s))
res$var_indexes <- sapply(psr, paste, collapse = ',')
res
# var_count na_counts non_na_count var_indexes
# 1 1 1 10 1
# 2 1 3 8 2
# 3 1 5 6 3
# 4 1 7 4 4
# 5 1 9 2 5
# 6 2 4 18 1,2
# 7 2 8 14 2,3
# 8 2 12 10 3,4
# 9 2 16 6 4,5
# 10 3 9 24 1,2,3
# 11 3 15 18 2,3,4
# 12 3 21 12 3,4,5
# 13 4 16 28 1,2,3,4
# 14 4 24 20 2,3,4,5
# 15 5 25 30 1,2,3,4,5
# choose
good <- sapply(psr, function(y) !any(diff(y) != 1L))
l1 = combn(2:length(d), 2, function(x) d[x[1]:x[2]], simplify = FALSE)
# If you also need "combinations" of only single columns, then uncomment the next line
# l1 = c(d[-1], l1)
l2 = sapply(l1, function(x) sum(complete.cases(x)))
score = sapply(1:length(l1), function(i) NCOL(l1[[i]]) * l2[i])
best_score = which.max(score)
best = l1[[best_score]]
col_weight = 2
row_weight = 1
score = sapply(1:length(l1), function(i) col_weight*NCOL(l1[[i]]) + row_weight * l2[i])
library(TraMineR)
data(ex1)
sum(is.na(ex1))
# [1] 38
sq <- seqdef(ex1[1:13])
sq
# Sequence
# s1 *-*-*-A-A-A-A-A-A-A-A-A-A
# s2 D-D-D-B-B-B-B-B-B-B
# s3 *-D-D-D-D-D-D-D-D-D-D
# s4 A-A-*-*-B-B-B-B-D-D
# s5 A-*-A-A-A-A-*-A-A-A
# s6 *-*-*-C-C-C-C-C-C-C
# s7 *-*-*-*-*-*-*-*-*-*-*-*-*
sm <- seqsubm(sq, method='TRATE')
round(sm,digits=3)
# A-> B-> C-> D->
# A-> 0 2.000 2 2.000
# B-> 2 0.000 2 1.823
# C-> 2 2.000 0 2.000
# D-> 2 1.823 2 0.000