如何根据列名子集的成对组合创建新的数据表?

2024-06-23

我正在尝试定义一个函数,该函数将数据框或表作为具有特定数量的 ID 列(例如 2 或 3 个 ID 列)的输入,其余列是 NAME1、NAME2、...、NAMEK(数字列) )。输出应该是一个数据表,其中包含与之前相同的 ID 列以及一个附加 ID 列,该 ID 列对列名称的每个唯一的成对组合进行分组(NAME1、NAME2、...)。另外,我们必须根据ID列将数字列的实际值收集到两个新列中;具有两个 ID 列和三个数字列的示例:

ID1 <- c("A","A","A","B","B","B")
ID2 <- c(1,2,3,1,2,3)
NAME1 <- c(10,11,9,22,25,22)
NAME2 <- c(7,9,8,20,22,21)
NAME3 <- c(10,12,11,15,19,30)
DT <- data.table(ID1,ID2,NAME1,NAME2,NAME3)

我希望以 DT 作为输入的函数的输出为

ID.new <- c("NAME1 - NAME2","NAME1 - NAME2","NAME1 - NAME2", "NAME1 - NAME2",
 "NAME1 - NAME2","NAME1 - NAME2", "NAME1 - NAME3", "NAME1 - NAME3",
 "NAME1 - NAME3","NAME1 - NAME3","NAME1 - NAME3","NAME1 - NAME3",
 "NAME2 - NAME3","NAME2 - NAME3","NAME2 - NAME3","NAME2 - NAME3",
 "NAME2 - NAME3", "NAME2 - NAME3")
ID1 <- c("A","A","A","B","B","B","A","A","A","B","B","B","A","A","A","B","B","B")
ID2 <- c(1,2,3,1,2,3,1,2,3,1,2,3,1,2,3,1,2,3)
value.left <- c(10,11,9,22,25,22,10,11,9,22,25,22,7,9,8,20,22,21)
value.right <- c(7,9,8,20,22,21,10,12,11,15,19,30,10,12,11,15,19,30)
DT.output <- data.table(ID.new,ID1,ID2,value.left,value.right)

我发现 fun() (见下文)可以完成这项工作,但对于我来说太慢了:

  fun <- function(data, ID.cols){
   data <- data.table(data)
   # Which of the columns are ID columns
   ids <-  which(colnames(data) %in% ID.cols)
   # Obtain all pairwise combinations of numeric columns into a list
   numeric.combs <- combn(x = data.table(data)[,!ids, with = FALSE], m = 2, simplify = FALSE)
   id.cols <- data[,ids, with = FALSE]
   # bind the ID columns to each pairwise combination of numeric columns inside the list
   bind.columns.each.numeric.comb <- lapply(X = numeric.combs, FUN = function(x) cbind(id.cols,x)) 
   # Create generic names for the numeric columns so that rbindlist() may be applied. In addition we make a new column that groups based on which columns we are considering
   generalize <- suppressWarnings(lapply(X = bind.columns.each.numeric.comb, FUN = function(x) 
   setattr(x = x[,ID.NEW:=paste(colnames(x[,!ids,with=FALSE]),collapse=" - ")], name = 
   'names', value = c(ID.cols,"value.left","value.right","ID.NEW"))))
   return(rbindlist(l=generalize))
}

# Performance
print(microbenchmark(fun(DT,ID.cols=c("ID1","ID2")),times=1000))

有没有更快、更优雅的方法来做到这一点?


熔化的自连接选项:

library(data.table)
DTlong <- melt(DT, id.vars = c("ID1", "ID2"), variable.factor = FALSE)
out <- DTlong[DTlong, on = .(ID1, ID2), allow.cartesian = TRUE
  ][variable < i.variable,
  ][, .(ID.new = paste(variable, i.variable, sep = " - "),
        ID1, ID2, value.left = value, value.right = i.value)]
out
#            ID.new    ID1   ID2 value.left value.right
#            <char> <char> <num>      <num>       <num>
#  1: NAME1 - NAME2      A     1         10           7
#  2: NAME1 - NAME2      A     2         11           9
#  3: NAME1 - NAME2      A     3          9           8
#  4: NAME1 - NAME2      B     1         22          20
#  5: NAME1 - NAME2      B     2         25          22
#  6: NAME1 - NAME2      B     3         22          21
#  7: NAME1 - NAME3      A     1         10          10
#  8: NAME2 - NAME3      A     1          7          10
#  9: NAME1 - NAME3      A     2         11          12
# 10: NAME2 - NAME3      A     2          9          12
# 11: NAME1 - NAME3      A     3          9          11
# 12: NAME2 - NAME3      A     3          8          11
# 13: NAME1 - NAME3      B     1         22          15
# 14: NAME2 - NAME3      B     1         20          15
# 15: NAME1 - NAME3      B     2         25          19
# 16: NAME2 - NAME3      B     2         22          19
# 17: NAME1 - NAME3      B     3         22          30
# 18: NAME2 - NAME3      B     3         21          30

### validation
setorder(out, ID.new, ID1, ID2)
identical(DT.output, out)
# [1] TRUE

方法论combn当然,这是一个合理的想法,但它唯一的低效率是每个组合都会迭代一次。也就是说,函数传递给combn(..., FUN=)在本例中被调用 18 次;如果你的数据更大,它会被调用很多次。如果是merge不过,就像这里的 /join 一样,一切都是以我们可以管理的矢量化方式完成的:merge高效完成,过滤作为单个逻辑向量返回,并且paste(..)也是一个大向量。

公平地说,合并概念确实有其自身的低效率:由于笛卡尔连接,它最初生成 54 行。对于更大的数据,这将导致内存耗尽问题。如果您遇到这种情况,使用以下方法可能会有所帮助fuzzyjoin并包括variable < variable(左轴与右轴),这应该可以减少(如果不是完全消除)问题。

最后的建议可以在sqldf还有:

sqldf::sqldf("
  select t1.variable || ' - ' || t2.variable as [ID.new], t1.ID1, t1.ID2, 
    t1.value as [value.left], t2.value as [value.right]
  from DTlong t1
    join DTlong t2 on t1.ID1=t2.ID1 and t1.ID2=t2.ID2
      and t1.variable < t2.variable")
#           ID.new ID1 ID2 value.left value.right
# 1  NAME1 - NAME2   A   1         10           7
# 2  NAME1 - NAME3   A   1         10          10
# 3  NAME1 - NAME2   A   2         11           9
# 4  NAME1 - NAME3   A   2         11          12
# 5  NAME1 - NAME2   A   3          9           8
# 6  NAME1 - NAME3   A   3          9          11
# 7  NAME1 - NAME2   B   1         22          20
# 8  NAME1 - NAME3   B   1         22          15
# 9  NAME1 - NAME2   B   2         25          22
# 10 NAME1 - NAME3   B   2         25          19
# 11 NAME1 - NAME2   B   3         22          21
# 12 NAME1 - NAME3   B   3         22          30
# 13 NAME2 - NAME3   A   1          7          10
# 14 NAME2 - NAME3   A   2          9          12
# 15 NAME2 - NAME3   A   3          8          11
# 16 NAME2 - NAME3   B   1         20          15
# 17 NAME2 - NAME3   B   2         22          19
# 18 NAME2 - NAME3   B   3         21          30

基准测试:

bench::mark(
  pernkf  = fun(DT, c("ID1", "ID2")),
  tjebo   = fun2(DT, c("ID1", "ID2")),
  r2evans = fun3(DT, c("ID1", "ID2")),  # native data.table
  r2evans2 = fun4(),                    # sqldf
  check = FALSE)
# # A tibble: 4 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 pernkf       5.38ms   6.06ms     161.      287KB    13.2     61     5      379ms <NULL> <Rprofmem[,3~ <bch:tm~ <tibble [~
# 2 tjebo        5.08ms   5.63ms     172.      230KB     8.83    78     4      453ms <NULL> <Rprofmem[,3~ <bch:tm~ <tibble [~
# 3 r2evans      2.97ms   3.48ms     280.      170KB    11.0    127     5      454ms <NULL> <Rprofmem[,3~ <bch:tm~ <tibble [~
# 4 r2evans2    17.19ms  18.91ms      52.0     145KB    13.0     20     5      384ms <NULL> <Rprofmem[,3~ <bch:tm~ <tibble [~

(sqldf在这个例子中确实会影响性能,我欢迎改进查询:-)

本文内容由网友自发贡献,版权归原作者所有,本站不承担相应法律责任。如您发现有涉嫌抄袭侵权的内容,请联系:hwhale#tublm.com(使用前将#替换为@)

如何根据列名子集的成对组合创建新的数据表? 的相关文章

  • 在 dfm 中查找非英语标记并将其删除

    在 dfm 中如何检测非英语单词并将其删除 dftest lt data frame id 1 3 text c Holla this is a spanish word English online here Bonjour commen
  • 如何按组计算日期之间的时间差

    我有一个包含日期 时间和位置的数据框 我想计算组内记录与上一条记录 根据日期排列 之间的分钟差异 并变异为新列 我已经弄清楚如何使用循环来完成此操作 但这仅适用于所有组 位置 而且我不确定如何按组执行此操作 fake data set fo
  • 使用 ggplot2 进行分面 qqplots

    假设我有以下数据 datapoints1 data frame categ c rep 1 n rep 2 n vals1 c rt n 1 2 rnorm n 3 4 datapoints2 data frame categ c rep
  • 贝叶斯网络中一个节点的条件概率修改(R代码)

    估计贝叶斯网络中的条件概率后 我问了一个节点 Inlet gas total Pressure 的概率如下 bn mle before Inlet gas total pressure 节点 Inlet gas total Pressure
  • 如何将字符串转换为日期?

    我已经搜索过 但找不到如何从格式如下的字符串转换日期 date lt 07 21 2015 09 30AM 我想用as Date 但我还没有做到 我得到的只是以下内容 as Date date format m d y hAM NA as
  • `filter()` 输入 `..1` 出现问题。与闪亮的R

    我正在尝试构建一个闪亮的应用程序 根据用户条目过滤数据帧 但是 我正在努力使用我创建的函数来执行此任务 错误Problem with filter input 1 x Input 1 must be of size 9 or 1 not s
  • 使用 dplyr::filter 创建 R 函数问题

    我查看了其他答案 但找不到使下面的代码起作用的解决方案 基本上 我正在创建一个函数inner join两个数据框和filter基于函数中输入的列 问题是filter部分功能不起作用 但是 如果我将过滤器从函数中取出并附加它 它就会起作用my
  • 从 r 中的数据帧中删除每第 n 列

    我试图通过删除每第三列来减小数据框的大小 这是我的示例数据框 example data frame x c 1 2 3 4 y c 1 2 3 4 z c 1 2 3 4 w c 1 2 3 4 p c 1 2 3 4 q c 1 2 3
  • 更改分配新变量的默认环境

    我经常想在全局环境下的一个环境中创建很多变量 这可以通过以下方式轻松完成envir论证sys source 如果由正在获取的文件创建的所有变量都应该进入单个环境 但我通常使用创建变量集的文件 一组应该进入一个环境 另一组应该进入另一个环境
  • 如何使用 caret 包解释模型输出的准确性

    我正在使用 caret 包来训练模型 并希望获得模型的准确性 我听说的一种常见方法是使用confusionMatrix 然而 当我运行下面的代码时 经过训练的模型给出了一些与confuseMatrix 报告的精度值略有不同的精度值 所以我的
  • 包“diamonds”不可用(对于 R 版本 3.0.0)[重复]

    这个问题在这里已经有答案了 在我的 R 环境中拥有钻石包 数据集的简单方法是什么 我是使用 RStudio 3 0 的新手 gt install packages diamonds Warning in install packages p
  • knitr pandoc:“无法使用 pdf writer 生成 pdf 输出”

    Up front using pandoc 在knitr中 当尝试将 md或 Rmd编译为PDF时 它会抱怨 我正在简化流程可重复的研究 正如许多地方所记录的那样 我在用着pandoc and knitr并制作出色的文档 我还试图为一些不太
  • R 绘制一些 unicode 字符,但不绘制其他字符

    我们的系统管理员刚刚将我们的操作系统升级到 SLES12SP1 我重新安装了 Rv3 2 3 并尝试绘图 我用cairo pdf并尝试绘制 x 标签为的图 u0298即太阳能符号 但它不起作用 标签只是空白 例如 cairo pdf Rpl
  • 求R中3列中每一行的最大值

    我需要计算 3 列中每行的最大值 一个表可以是 x c 1 2 3 4 5 y c 2 3 3 1 1 z c 4 3 2 1 1 df lt data frame x y z 我需要得到 x y z max 1 1 2 4 4 2 2 3
  • 如何以角度将数据表导出到csv文件中

    我的 angularjs 应用程序中有一个数据表 我想将其导出到 csv 文件 我在互联网上搜索了很多 找到了这个指令 但这仅在按钮位于表格旁边时才有效 需要帮助来编辑它 app directive exportToCsv function
  • 使用 R 并行处理 XML 节点

    我正在尝试与 R 并行处理 XML 文档xml2包装和foreach功能 但我收到 node attrs x node nsMap ns 中的错误 外部指针无效 尝试导出树集群导出 示例代码 library xml2 library for
  • 如何使用 ggplot2 在轴标签中使用上标

    如何在x轴上打印埃平方 我尝试如下 labs x x axis 2 y y axis 我们可以用bquote library ggplot2 ggplot mtcars aes hp mpg geom point labs x bquote
  • 使用同一变量的多个子集创建新数据框

    我想创建一个新的数据框 其中的列是由不同变量分割的同一变量的子集 例如 我想创建一个新的变量子集 b 其中列由不同变量 year 的子集分割 set seed 88 df lt data frame year rep 1996 1998 3
  • 根据值绘制具有条件颜色的折线图

    我想绘制折线图 根据值 它应该改变它的颜色 我发现的是 plot sin seq from 1 to 10 by 0 1 type p col ifelse sin seq from 1 to 10 by 0 1 gt 0 5 red ye
  • 为什么 NaN^0 == 1

    受到早期高尔夫代码的提示 为什么会 gt NaN 0 1 1 这非常有道理NA 0为 1 因为NA缺少数据 并且any数字提高到 0 将得到 1 包括 Inf and Inf 然而NaN应该代表非数字 那么为什么会这样呢 当帮助页面出现时

随机推荐