logo标签列表

如何按顺序计算因数

rcountsequencestrsplit
5

我有一个数据框 df:

userID Score  Task_Alpha Task_Beta Task_Charlie Task_Delta 
3108  -8.00   Easy       Easy      Easy         Easy    
3207   3.00   Hard       Easy      Match        Match
3350   5.78   Hard       Easy      Hard         Hard
3961   10.00  Easy       NA        Hard         Hard
4021   10.00  Easy       Easy      NA           Hard


1. userID is factor variable
2. Score is numeric
3. All the 'Task_' features are factor variables with possible values 'Hard', 'Easy', 'Match' or NA

我希望能够计算Task_功能之间的可能转换。参考以下可能的转换：

EE transition from Easy -> Easy
EM transition from Easy -> Match
EH transition from Easy -> Hard
ME transition from Match-> Easy
MM transition from Match-> Match
MH transition from Match-> Hard
HE transition from Hard -> Easy
HM transition from Hard -> Match
HH transition from Hard -> Hard

由于存在三个可能的值（不包括 NA 情况），输出列如下：

userID  EE  EM  EH  MM  ME  MH  HH  HE  HM
3108    3   0   0   0   0   0   0   0   0
3207    0   1   0   1   0   0   0   1   0
3350    0   0   1   0   0   0   1   1   0
3961    0   0   0   0   0   0   1   0   0
4021    1   0   0   0   0   0   0   0   0

1) 在这个例子中，每个userID最多可以有3个状态转换。

2) 请注意，对于用户3961和4021，NA已经减少了可能的状态转换。

对于这些问题的任何建议都将不胜感激。

dput()数据为：

df <- structure(list(
userID = c(3108L, 3207L, 3350L, 3961L, 4021L), 
Score = c(-8, 3, 5.78, 10, 10), 
Task_Alpha = structure(c(1L, 2L, 2L, 1L, 1L), .Label = c("Easy", "Hard"), class = "factor"), 
Task_Beta = structure(c(1L, 1L, 1L, NA, 1L), .Label = "Easy", class = "factor"), 
Task_Charlie = structure(c(1L, 3L, 2L, 2L, NA), .Label = c("Easy", "Hard", "Match"), class = "factor"), 
Task_Delta = structure(c(1L, 3L, 2L, 2L, 2L), .Label = c("Easy", "Hard", "Match"), class = "factor")), 
class = "data.frame", row.names = c(NA, -5L))
3个回答
2

通过基础R，另一个想法是将值粘贴到它们的上一个值（逐行操作），转换为因子以获得所有9个级别（使用expand.grid仅使用所需级别 - 这也处理了NA），最后通过table计算值的数量。最后一步是将ID与结果绑定在一起。

cbind.data.frame(df$userID, t(apply(df[-c(1:2)], 1, function(i) { 
                          i1 <- paste(i[-length(i)], i[-1]); 
                          i1 <- factor(i1, levels = do.call(paste, expand.grid(c('Easy', 'Match', 'Hard'), 
                                                                             c('Easy', 'Match', 'Hard')))); 
                         table(i1) })))

这提供了,

  df$userID Easy Easy Match Easy Hard Easy Easy Match Match Match Hard Match Easy Hard Match Hard Hard Hard
1      3108         3          0         0          0           0          0         0          0         0
2      3207         0          0         1          1           1          0         0          0         0
3      3350         0          0         1          0           0          0         1          0         1
4      3961         0          0         0          0           0          0         0          0         1
5      4021         1          0         0          0           0          0         0          0         0
Sotos，感谢您发布了一个解决方案。我尝试了您的脚本，但代码一直在运行，这种情况也发生在您那里吗？ - Sandy
2

除了 Sotos 的方法之外，还有一种类似的选择，但是 1) 使用 data.table，2) 不使用 factor，并且 3) 用 Rfast::rowTabulate 替换 table：

v <- c('Hard', 'Match', 'Easy')
vv <- do.call(paste, expand.grid(v, v))
DT[, (vv) := {
        mat <- mapply(paste, .SD[, -ncol(.SD), with=FALSE], .SD[, -1L])
        as.data.table(Rfast::rowTabulate(matrix(match(mat, vv, 0L), nrow=.N)))
    }, .SDcols=Task_Alpha:Task_Delta]

输出：

   userID Score Task_Alpha Task_Beta Task_Charlie Task_Delta Hard Hard Match Hard Easy Hard Hard Match Match Match Easy Match Hard Easy Match Easy Easy Easy
1:   3108 -8.00       Easy      Easy         Easy       Easy         0          0         0          0           0          0         0          0         3
2:   3207  3.00       Hard      Easy        Match      Match         0          0         0          0           1          1         1          0         0
3:   3350  5.78       Hard      Easy         Hard       Hard         1          0         1          0           0          0         1          0         0
4:   3961 10.00       Easy      <NA>         Hard       Hard         1          0         0          0           0          0         0          0         0
5:   4021 10.00       Easy      Easy         <NA>       Hard         0          0         0          0           0          0         0          0         1

数据：

library(data.table)
library(Rfast)
DT <- structure(list(
    userID = c(3108L, 3207L, 3350L, 3961L, 4021L), 
    Score = c(-8, 3, 5.78, 10, 10), 
    Task_Alpha = structure(c(1L, 2L, 2L, 1L, 1L), .Label = c("Easy", "Hard"), class = "factor"), 
    Task_Beta = structure(c(1L, 1L, 1L, NA, 1L), .Label = "Easy", class = "factor"), 
    Task_Charlie = structure(c(1L, 3L, 2L, 2L, NA), .Label = c("Easy", "Hard", "Match"), class = "factor"), 
    Task_Delta = structure(c(1L, 3L, 2L, 2L, 2L), .Label = c("Easy", "Hard", "Match"), class = "factor")), 
    class = "data.frame", row.names = c(NA, -5L))
setDT(DT)

很想知道这种方法在实际数据集上的运行速度以及实际数据集是否很大。

编辑：添加了一些时间统计信息。

library(data.table)
nr <- 1e6
vec <- c('Hard', 'Match', 'Easy', NA)
DT <- data.table(userID=1:nr, Task_Alpha=sample(vec, nr, TRUE), Task_Beta=sample(vec, nr, TRUE),
    Task_Charlie=sample(vec, nr, TRUE), Task_Delta=sample(vec, nr, TRUE))
df <- as.data.frame(DT)
DT0 <- copy(DT)
DT1 <- copy(DT)
DT2 <- copy(DT)

mtd0 <- function() {
    t(apply(df[-1L], 1, function(i) {
        i1 <- paste(i[-length(i)], i[-1L]);
        i1 <- factor(i1, levels = do.call(paste, expand.grid(c('Easy', 'Match', 'Hard'),
            c('Easy', 'Match', 'Hard'))));
        table(i1)
    }))
}

mtd1 <- function() {
    f_cols <- names(DT0)[ sapply( DT0, is.factor ) ]
    DT0[, (f_cols) := lapply(.SD, as.character), .SDcols = f_cols ]
    #melt to long format
    DT.melt <- melt( DT0, id.vars = "userID", measure.vars = patterns( task = "^Task_"))
    #set order of Aplha-Beta-etc...
    DT.melt[ grepl( "Alpha",   variable ), order := 1 ]
    DT.melt[ grepl( "Beta",    variable ), order := 2 ]
    DT.melt[ grepl( "Charlie", variable ), order := 3 ]
    DT.melt[ grepl( "Delta",   variable ), order := 4 ]
    #order DT.melt
    setorder( DT.melt, userID, order )
    #fill in codes EE, etc...
    DT.melt[, `:=`( code1 = gsub( "(^.).*", "\\1", value ),
        code2 = gsub( "(^.).*", "\\1", shift( value, type = "lead" ) ) ),
        by = userID ]
    #filter only rows without NA
    DT.melt <- DT.melt[ complete.cases( DT.melt ) ]
    #cast to wide output
    dcast( DT.melt, userID ~ paste0( code2, code1 ), fun.aggregate = length )
}

mtd2 <- function() {
    v <- c('Hard', 'Match', 'Easy')
    vv <- do.call(paste, expand.grid(v, v))
    DT2[, (vv) := {
        mat <- mapply(paste, .SD[, -ncol(.SD), with=FALSE], .SD[, -1L])
        as.data.table(Rfast::rowTabulate(matrix(match(mat, vv, 0L), nrow=.N)))
    }, .SDcols=Task_Alpha:Task_Delta]
}

bench::mark(mtd0(), mtd1(), mtd2(), check=FALSE)

时间：

# A tibble: 3 x 13
  expression      min   median `itr/sec` mem_alloc `gc/sec` n_itr  n_gc total_time result                     memory                 time     gc              
  <bch:expr> <bch:tm> <bch:tm>     <dbl> <bch:byt>    <dbl> <int> <dbl>   <bch:tm> <list>                     <list>                 <list>   <list>          
1 mtd0()        2.19m    2.19m   0.00760     252MB    2.26      1   297      2.19m <int[,9] [1,000,000 x 9]>  <df[,3] [171,481 x 3]> <bch:tm> <tibble [1 x 3]>
2 mtd1()       33.16s   33.16s   0.0302      856MB    0.754     1    25     33.16s <df[,10] [843,688 x 10]>   <df[,3] [8,454 x 3]>   <bch:tm> <tibble [1 x 3]>
3 mtd2()     844.95ms 844.95ms   1.18        298MB    1.18      1     1   844.95ms <df[,14] [1,000,000 x 14]> <df[,3] [8,912 x 3]>   <bch:tm> <tibble [1 x 3]>
感谢您发布解决方案，我尝试了第一个脚本，但是我遇到了以下错误： "Error in `:=`((vv), { : Check that is.data.table(DT) == TRUE. Otherwise, := and `:=`(...) are defined for use in j, once only and in particular ways. See help(":=")."有什么建议如何处理这个问题吗？ - Sandy
你需要确保你的变量是一个 data.table。你可以使用 setDT 将其从 data.frame 转换为 data.table。 - chinsoon12
1
library(data.table)
#set df to data.table
setDT(df)
#convert factor-columns to character
f_cols <- names(df)[ sapply( df, is.factor ) ]
df[, (f_cols) := lapply(.SD, as.character), .SDcols = f_cols ]
#melt to long format
DT.melt <- melt( df, id.vars = "userID", measure.vars = patterns( task = "^Task_"), variable.name = grep("^Task",names(df), value = TRUE) )
#set order of Aplha-Beta-etc...
DT.melt[ grepl( "Alpha",   variable ), order := 1 ]
DT.melt[ grepl( "Beta",    variable ), order := 2 ]
DT.melt[ grepl( "Charlie", variable ), order := 3 ]
DT.melt[ grepl( "Delta",   variable ), order := 4 ]
#order DT.melt
setorder( DT.melt, userID, order )
#fill in codes EE, etc...
DT.melt[, `:=`( code1 = gsub( "(^.).*", "\\1", value ),
                code2 = gsub( "(^.).*", "\\1", shift( value, type = "lead" ) ) ),
        by = userID ]
#filter only rows without NA
DT.melt <- DT.melt[ complete.cases( DT.melt ) ]
str(DT.melt)
#cast to wide output
dcast( DT.melt, userID ~ paste0( code2, code1 ), fun.aggregate = length )

#    userID EE EH EM HE HH MM
# 1:   3108  3  0  0  0  0  0
# 2:   3207  0  0  1  1  0  1
# 3:   3350  0  1  0  1  1  0
# 4:   3961  0  0  0  0  1  0
# 5:   4021  1  0  0  0  0  0
更新了答案以处理您数据中的“factor”列... - Wimpel
第二次更新：糟糕，我必须将最后一行中的 paste0( code1, code2 ) 切换为 paste0( code2, code1 )... 现在它与您的输出匹配（除了缺少的组合，如 ME）。 - Wimpel
网页内容由stack overflow 提供, 点击上面的
可以查看英文原文，
原文链接