提升递归抽样函数的性能

huangapple
go评论102阅读模式
英文:

Improve the performance of recursive sampling function

问题

以下是您要翻译的内容：

作为对我的先前问题的后续，我对改进现有的递归抽样函数性能感兴趣。

通过递归抽样，我指的是随机选择多达n个独特的未暴露ID，用于给定的已暴露ID，然后随机选择多达n个独特的未暴露ID，用于另一个已暴露ID的剩余未暴露ID。如果对于给定的已暴露ID没有剩余的未暴露ID，那么该已暴露ID将被排除在外。

原始函数如下：

  1. recursive_sample <- function(data, n) {
  2.  
  3.  groups <- unique(data[["exposed"]])
  4.  out <- data.frame(exposed = character(), unexposed = character())
  5.  
  6.  for (group in groups) {
  7.   
  8.   chosen <- data %>%
  9.    filter(exposed == group,
  10.           !unexposed %in% out$unexposed) %>%
  11.    group_by(unexposed) %>%
  12.    slice(1) %>%
  13.    ungroup() %>%
  14.    sample_n(size = min(n, nrow(.))) 
  15.   
  16.   out <- rbind(out, chosen)
  17.   
  18.  }
  19.  
  20.  out
  21.  
  22. }

我能够创建一个更有效的版本，如下所示：

  1. recursive_sample2 <- function(data, n) {
  2.  
  3.  groups <- unique(data[["exposed"]])
  4.  out <- tibble(exposed = integer(), unexposed = integer())
  5.  
  6.  for (group in groups) {
  7.   
  8.   chosen <- data %>%
  9.    filter(exposed == group,
  10.           !unexposed %in% out$unexposed) %>%
  11.    filter(!duplicated(unexposed)) %>%
  12.    sample_n(size = min(n, nrow(.))) 
  13.   
  14.   out <- bind_rows(out, chosen)
  15.   
  16.  }
  17.  
  18.  out
  19.  
  20. }

示例数据和性能基准测试：

  1. set.seed(123)
  2. df <- tibble(exposed = rep(1:100, each = 100),
  3.              unexposed = sample(1:7000, 10000, replace = TRUE))
  5. microbenchmark(f1 = recursive_sample(df, 5),
  6.                f2 = recursive_sample2(df, 5),
  7.                times = 10)
  9. Unit: milliseconds
  10.  expr       min        lq      mean    median        uq      max neval cld
  11.    f1 1307.7198 1316.5276 1379.0533 1371.3952 1416.6360 1540.955    10   b
  12.    f2  839.0086  865.2547  914.8327  901.2288  970.9518 1036.170    10  a

然而，对于我的实际数据集，我需要一个更高效（即更快）的函数。欢迎提供更高效版本的任何想法，无论是在data.table中，涉及并行化还是其他方法。

英文:

As a follow-up to my previous question, I'm interested in improving the performance of the existing recursive sampling function.

By recursive sampling I mean randomly choosing up to n unique unexposed IDs for a given exposed ID, and the randomly choosing up to n unique unexposed IDs from the remaining unexposed IDs for another exposed ID. If there are no remaining unexposed IDs for a given exposed ID, then the exposed ID is left out.

The original function is as follows:

  1. recursive_sample &lt;- function(data, n) {
  2.  
  3.  groups &lt;- unique(data[[&quot;exposed&quot;]])
  4.  out &lt;- data.frame(exposed = character(), unexposed = character())
  5.  
  6.  for (group in groups) {
  7.   
  8.   chosen &lt;- data %&gt;%
  9.    filter(exposed == group,
  10.           !unexposed %in% out$unexposed) %&gt;%
  11.    group_by(unexposed) %&gt;%
  12.    slice(1) %&gt;%
  13.    ungroup() %&gt;%
  14.    sample_n(size = min(n, nrow(.))) 
  15.   
  16.   out &lt;- rbind(out, chosen)
  17.   
  18.  }
  19.  
  20.  out
  21.  
  22. }

I was able to create a more efficient one as follows:

  1. recursive_sample2 &lt;- function(data, n) {
  2.  
  3.  groups &lt;- unique(data[[&quot;exposed&quot;]])
  4.  out &lt;- tibble(exposed = integer(), unexposed = integer())
  5.  
  6.  for (group in groups) {
  7.   
  8.   chosen &lt;- data %&gt;%
  9.    filter(exposed == group,
  10.           !unexposed %in% out$unexposed) %&gt;%
  11.    filter(!duplicated(unexposed)) %&gt;%
  12.    sample_n(size = min(n, nrow(.))) 
  13.   
  14.   out &lt;- bind_rows(out, chosen)
  15.   
  16.  }
  17.  
  18.  out
  19.  
  20. }

Sample data and bechmarking:

  1. set.seed(123)
  2. df &lt;- tibble(exposed = rep(1:100, each = 100),
  3.              unexposed = sample(1:7000, 10000, replace = TRUE))
  5. microbenchmark(f1 = recursive_sample(df, 5),
  6.                f2 = recursive_sample2(df, 5),
  7.                times = 10)
  9. Unit: milliseconds
  10.  expr       min        lq      mean    median        uq      max neval cld
  11.    f1 1307.7198 1316.5276 1379.0533 1371.3952 1416.6360 1540.955    10   b
  12.    f2  839.0086  865.2547  914.8327  901.2288  970.9518 1036.170    10  a

However, for my actual dataset, I would need an even more efficient (i.e., quicker) function. Any ideas for a more efficient version, whether in data.table, involving parallelisation or other approaches are welcome.

答案1

得分: 2

以下是翻译好的代码部分：

  1. # 更新，改进更多
  3. 更简洁的解决方案可能是使用 `Reduce` + `split`，其中我们首先对 `data` 的行进行洗牌，然后我们按组进行**迭代**抽样
  4. ```R
  5. ftic <- function(data, n) {
  6.     Reduce(
  7.         \(x, y) {
  8.             rbind(x, head(subset(y, !unexposed %in% x$unexposed), n))
  9.         },
  10.         split(data[sample(1:nrow(data)), ], ~exposed)
  11.     )
  12. }

下面是一个更具挑战性的性能测试，即具有1e6行的data，其中的方法包括：

  1. ftmfmnk <- function(data, n) {
  2.     groups <- unique(data[["exposed"]])
  3.     out <- tibble(exposed = integer(), unexposed = integer())
  5.     for (group in groups) {
  6.         chosen <- data %>%
  7.             filter(
  8.                 exposed == group,
  9.                 !unexposed %in% out$unexposed
  10.             ) %>%
  11.             filter(!duplicated(unexposed)) %>%
  12.             sample_n(size = min(n, nrow(.)))
  14.         out <- bind_rows(out, chosen)
  15.     }
  17.     out
  18. }
  20. fminem <- function(data, n) {
  21.     groups <- unique(data[["exposed"]])
  22.     # working on vectors is faster
  23.     id <- 1:nrow(data)
  24.     i <- vector("integer")
  25.     unexposed2 <- vector(class(data$unexposed))
  26.     ex <- data$exposed
  27.     ux <- data$unexposed
  29.     for (group in groups) {
  30.         f1 <- ex == group # first filter
  31.         f2 <- !ux[f1] %in% unexposed2 # 2nd filter (only on those that match 1st)
  32.         id3 <- id[f1][f2][!duplicated(ux[f1][f2])] # check duplicates only on needed
  33.         # and select necesary row ids
  34.         is <- sample(id3, size = min(length(id3), n)) # sample row ids
  35.         i <- c(i, is) # add to list
  36.         unexposed2 <- ux[i] # resave unexposed2
  37.     }
  38.     out <- data[i, ] # only one data.frame subset
  39.     out$id <- NULL
  40.     out
  41. }
  43. ftic <- function(data, n) {
  44.     Reduce(
  45.         \(x, y) {
  46.             rbind(x, head(subset(y, !unexposed %in% x$unexposed), n))
  47.         },
  48.         split(data[sample(1:nrow(data)), ], ~exposed)
  49.     )
  50. }

以下是基准测试：

  1. set.seed(123)
  2. df <- tibble(
  3.     exposed = rep(1:1000, each = 1000),
  4.     unexposed = sample(1:70000, 1000000, replace = TRUE)
  5. )
  7. mbm <- microbenchmark(
  8.     tmfmnk = ftmfmnk(df, 5),
  9.     minem = fminem(df, 5),
  10.     tic = ftic(df, 5),
  11.     times = 10
  12. )
  14. boxplot(mbm)

我们将会看到：

  1. > mbm
  2. Unit: milliseconds
  3.    expr        min         lq       mean     median         uq        max neval
  4.  tmfmnk 36809.9563 44276.3545 43780.8407 44897.2661 46175.1031 46948.8906    10
  5.   minem  5361.2796  5932.7752  5923.8811  6010.7775  6047.3716  6233.2919    10
  6.     tic   504.5749   519.5997   641.7935   607.2825   729.4545   868.1283    10

先前的朴素方法

我在这里没有任何高级技巧，只是使用了for循环的动态规划方案，我相信一定有比我更高效的方法

  1. dp <- function(df, n) {
  2.     d <- table(df)
  3.     out <- list()
  4.     rnm <- row.names(d)
  5.     cnm <- colnames(d)
  6.     for (i in 1:nrow(d)) {
  7.         v <- which(d[i, ] > 0)
  8.         l <- length(v)
  9.         idx <- v[sample(l, min(l, n))]
  10.         out[[i]] <- data.frame(exposed = rnm[i], unexposed = cnm[idx])
  11.         d[, idx] <- 0
  12.     }
  13.     do.call(rbind, out)
  14. }

基准测试如下：

  1. set.seed(123)
  2. df <- tibble(
  3.     exposed = rep(1:100, each = 100),
  4.     unexposed = sample(1:7000, 10000, replace = TRUE)
  5. )
  7. mbm <- microbenchmark(
  8.     f1 = recursive_sample(df, 5),
  9.     f2 = recursive_sample2(df, 5),
  10.     f3 = dp(df, 5),
  11.     times = 10
  12. )
  14. boxplot(mbm)

结果如下：

  1. > mbm
  2. Unit: milliseconds
  3.  expr       min        lq      mean    median        uq       max neval
  4.    f1 1271.0135 1302.4310 1449.2193 1326.7630 1686.4329 1888.4549    10
  5.    f2  507.9350  516.8854  617.0313  559.0422  706.4300  801.0124    10
  6.    f3  212.8944  247.0066  278.1792  271.9010  309.7377  354.4320    10

此外，要检查结果 res <- dp(df, 5)，我们可以使用以下代码：

  1. > table(res$exposed)
  3.   1  10 100  11  12  13  14  15  16  17  18  19   2  20  21  22  23  24  25  26
  4.   5   5   5   5   5   5   5   5   5   5   5   5   5   5   5   5   5   5   5   5
  5.  27  28  29   3  30  31  32  33  34  
  7. <details>
  8. <summary>英文:</summary>
  10. # Update, with More Improvement
  12. A more concise solution might be using `Reduce` + `split`, where we shuffle the rows of `data` first and then we samples by groups **iteratively**

ftic <- function(data, n) {
Reduce(
(x, y) {
rbind(x, head(subset(y, !unexposed %in% x$unexposed), n))
},
split(data[sample(1:nrow(data)), ], ~exposed)
)
}

  1. and below is a ***tougher*** pressure test, i.e., **`data` of `1e6` rows**, where the approaches include:

ftmfmnk <- function(data, n) {
groups <- unique(data[["exposed"]])
out <- tibble(exposed = integer(), unexposed = integer())

  1. for (group in groups) {
  2.     chosen &lt;- data %&gt;%
  3.         filter(
  4.             exposed == group,
  5.             !unexposed %in% out$unexposed
  6.         ) %&gt;%
  7.         filter(!duplicated(unexposed)) %&gt;%
  8.         sample_n(size = min(n, nrow(.)))
  10.     out &lt;- bind_rows(out, chosen)
  11. }
  13. out

}

fminem <- function(data, n) {
groups <- unique(data[["exposed"]])
# working on vectors is faster
id <- 1:nrow(data)
i <- vector("integer")
unexposed2 <- vector(class(data$unexposed))
ex <- data$exposed
ux <- data$unexposed

  1. for (group in groups) {
  2.     f1 &lt;- ex == group # first filter
  3.     f2 &lt;- !ux[f1] %in% unexposed2 # 2nd filter (only on those that match 1st)
  4.     id3 &lt;- id[f1][f2][!duplicated(ux[f1][f2])] # check duplicates only on needed
  5.     # and select necesary row ids
  6.     is &lt;- sample(id3, size = min(length(id3), n)) # sample row ids
  7.     i &lt;- c(i, is) # add to list
  8.     unexposed2 &lt;- ux[i] # resave unexposed2
  9. }
  10. out &lt;- data[i, ] # only one data.frame subset
  11. out$id &lt;- NULL
  12. out

}

ftic <- function(data, n) {
Reduce(
(x, y) {
rbind(x, head(subset(y, !unexposed %in% x$unexposed), n))
},
split(data[sample(1:nrow(data)), ], ~exposed)
)
}

  2. The benchmarking is as below

set.seed(123)
df <- tibble(
exposed = rep(1:1000, each = 1000),
unexposed = sample(1:70000, 1000000, replace = TRUE)
)

mbm <- microbenchmark(
tmfmnk = ftmfmnk(df, 5),
minem = fminem(df, 5),
tic = ftic(df, 5),
times = 10
)

boxplot(mbm)

  1. and we will see that

> mbm
Unit: milliseconds
expr min lq mean median uq max neval
tmfmnk 36809.9563 44276.3545 43780.8407 44897.2661 46175.1031 46948.8906 10
minem 5361.2796 5932.7752 5923.8811 6010.7775 6047.3716 6233.2919 10
tic 504.5749 519.5997 641.7935 607.2825 729.4545 868.1283 10

  2. [![enter image description here][1]][1]
  4. -------------------------------------------
  5. # Previous Na&#239;ve Approach 
  7. I don&#39;t have any advanced technique here, but just a dynamic programming scheme with `for` loops, and I believe there must be more performant approaches than mine
  8.

dp <- function(df, n) {
d <- table(df)
out <- list()
rnm <- row.names(d)
cnm <- colnames(d)
for (i in 1:nrow(d)) {
v <- which(d[i, ] > 0)
l <- length(v)
idx <- v[sample(l, min(l, n))]
out[[i]] <- data.frame(exposed = rnm[i], unexposed = cnm[idx])
d[, idx] <- 0
}
do.call(rbind, out)
}

  1. and the benchmarking

set.seed(123)
df <- tibble(
exposed = rep(1:100, each = 100),
unexposed = sample(1:7000, 10000, replace = TRUE)
)

mbm <- microbenchmark(
f1 = recursive_sample(df, 5),
f2 = recursive_sample2(df, 5),
f3 = dp(df, 5),
times = 10
)

boxplot(mbm)

  1. shows

> mbm
Unit: milliseconds
expr min lq mean median uq max neval
f1 1271.0135 1302.4310 1449.2193 1326.7630 1686.4329 1888.4549 10
f2 507.9350 516.8854 617.0313 559.0422 706.4300 801.0124 10
f3 212.8944 247.0066 278.1792 271.9010 309.7377 354.4320 10

  2. [![enter image description here][2]][2]
  4. Also, to check the result `res &lt;- dp(df, 5)`, we can use

> table(res$exposed)

1 10 100 11 12 13 14 15 16 17 18 19 2 20 21 22 23 24 25 26
5 5 5 5 5 5 5 5 5 5 5 5 5 5 5 5 5 5 5 5
27 28 29 3 30 31 32 33 34 35 36 37 38 39 4 40 41 42 43 44
5 5 5 5 5 5 5 5 5 5 5 5 5 5 5 5 5 5 5 5
45 46 47 48 49 5 50 51 52 53 54 55 56 57 58 59 6 60 61 62
5 5 5 5 5 5 5 5 5 5 5 5 5 5 5 5 5 5 5 5
63 64 65 66 67 68 69 7 70 71 72 73 74 75 76 77 78 79 8 80
5 5 5 5 5 5 5 5 5 5 5 5 5 5 5 5 5 5 5 5
81 82 83 84 85 86 87 88 89 9 90 91 92 93 94 95 96 97 98 99
5 5 5 5 5 5 5 5 5 5 5 5 5 5 5 5 5 5 5 5

> anyDuplicated(res$unexposed)
1 0

  3.   [1]: https://i.stack.imgur.com/HUvI0.png
  4.   [2]: https://i.stack.imgur.com/60wE3.png
  6. </details>
  10. # 答案2
  11. **得分**: 2
  13. 以下是已翻译的代码部分：
  15. ```R
  16. Working on vectors is much faster:
  18. recursive_sample3 <- function(data, n) {
  19.   groups <- unique(data[["exposed"]])
  20.   # working on vectors is faster
  21.   id <- 1:nrow(data)
  22.   i <- vector('integer')
  23.   unexposed2 <- vector(class(data$unexposed))
  24.   ex <- data$exposed
  25.   ux <- data$unexposed
  26.   
  27.   for (group in groups) {
  28.     f1 <- ex == group # first filter
  29.     f2 <- !ux[f1] %in% unexposed2 # 2nd filter (only on those that match 1st)
  30.     id3 <- id[f1][f2][!duplicated(ux[f1][f2])] # check duplicates only on needed
  31.     # and select necesary row ids
  32.     is <- sample(id3, size = min(length(id3), n)) # sample row ids
  33.     i <- c(i, is) # add to list
  34.     unexposed2 <- ux[i] # resave unexposed2
  35.   }
  36.   out <- data[i, ] # only one data.frame subset
  37.   out$id <- NULL
  38.   out
  39. }
  41. benchmarks:
  43. microbenchmark(f1 = recursive_sample(df, 5),
  44.                f2 = recursive_sample2(df, 5),
  45.                f3 = recursive_sample3(df, 5),
  46.                times = 3)
  47. # Unit: milliseconds
  48. # expr       min        lq        mean    median         uq       max neval cld
  49. #   f1 1399.8988 1407.1939 1422.008133 1414.4889 1433.06280 1451.6367     3 a  
  50. #   f2  667.0813  673.7229  678.106400  680.3645  683.61895  686.8734     3  b 
  51. #   f3    6.2399    6.2625    9.531267    6.2851   11.17695   16.0688     3   c
  53. Iterating on `recursive_sample3` & incorporating concerns of `sample`:
  55. f_minem <- function(data, n) {
  56.   i <- vector('integer')
  57.   unexposed2 <- vector(class(data$unexposed))
  58.   ux <- data$unexposed
  59.   exl <- split(1:nrow(data), data$exposed)
  60.   for (ii in exl) {
  61.     f2 <- !ux[ii] %in% unexposed2
  62.     f12 <- ii[f2]
  63.     dn <- !duplicated(ux[f12])
  64.     id3 <- f12[dn]
  65.     is <- id3[sample.int(min(length(id3), n))]
  66.     i <- c(i, is)
  67.     unexposed2 <- ux[i]
  68.   }
  69.   out <- data[i, ]
  70.   out
  71. }
  73. benchmarks nr2:
  75. microbenchmark::microbenchmark(
  76.   recursive_sample3 = recursive_sample3(df, 5L),
  77.   recursive_sample4 = recursive_sample4(setDT(df), 5L),
  78.   f_minem = f_minem(df, 5L),
  79.   setup = {df <- copy(data)}
  80.   , times = 10
  81. )
  82. # Unit: milliseconds
  83. #              expr    min     lq    mean  median      uq     max neval cld
  84. # recursive_sample3 6.2102 6.2974 9.63296 6.43245 16.3367 17.0746    10  a 
  85. # recursive_sample4 3.5145 3.6249 3.67077 3.67075  3.7513  3.7970    10   b
  86. #           f_minem 2.1705 2.1920 2.27510 2.23215  2.3784  2.4585    10   b

希望这对你有所帮助！如果需要进一步的翻译，请告诉我。

英文:

Working on vectors is much faster:

  1. recursive_sample3 &lt;- function(data, n) {
  2.   groups &lt;- unique(data[[&quot;exposed&quot;]])
  3.   # working on vectors is faster
  4.   id &lt;- 1:nrow(data)
  5.   i &lt;- vector(&#39;integer&#39;)
  6.   unexposed2 &lt;- vector(class(data$unexposed))
  7.   ex &lt;- data$exposed
  8.   ux &lt;- data$unexposed
  9.   
  10.   for (group in groups) {
  11.     f1 &lt;- ex == group # first filter
  12.     f2 &lt;- !ux[f1] %in% unexposed2 # 2nd filter (only on those that match 1st)
  13.     id3 &lt;- id[f1][f2][!duplicated(ux[f1][f2])] # check duplicates only on needed
  14.     # and select necesary row ids
  15.     is &lt;- sample(id3, size = min(length(id3), n)) # sample row ids
  16.     i &lt;- c(i, is) # add to list
  17.     unexposed2 &lt;- ux[i] # resave unexposed2
  18.   }
  19.   out &lt;- data[i, ] # only one data.frame subset
  20.   out$id &lt;- NULL
  21.   out
  22. }

benchmarks:

  1. microbenchmark(f1 = recursive_sample(df, 5),
  2.                f2 = recursive_sample2(df, 5),
  3.                f3 = recursive_sample3(df, 5),
  4.                times = 3)
  5. # Unit: milliseconds
  6. # expr       min        lq        mean    median         uq       max neval cld
  7. #   f1 1399.8988 1407.1939 1422.008133 1414.4889 1433.06280 1451.6367     3 a  
  8. #   f2  667.0813  673.7229  678.106400  680.3645  683.61895  686.8734     3  b 
  9. #   f3    6.2399    6.2625    9.531267    6.2851   11.17695   16.0688     3   c

Iterating on recursive_sample3 & incorporating concerns of sample:

  1. f_minem &lt;- function(data, n) {
  2.   i &lt;- vector(&#39;integer&#39;)
  3.   unexposed2 &lt;- vector(class(data$unexposed))
  4.   ux &lt;- data$unexposed
  5.   exl &lt;- split(1:nrow(data), data$exposed)
  6.   for (ii in exl) {
  7.     f2 &lt;- !ux[ii] %in% unexposed2
  8.     f12 &lt;- ii[f2]
  9.     dn &lt;- !duplicated(ux[f12])
  10.     id3 &lt;- f12[dn]
  11.     is &lt;- id3[sample.int(min(length(id3), n))]
  12.     i &lt;- c(i, is)
  13.     unexposed2 &lt;- ux[i]
  14.   }
  15.   out &lt;- data[i, ]
  16.   out
  17. }

benchmarks nr2:

  1. microbenchmark::microbenchmark(
  2.   recursive_sample3 = recursive_sample3(df, 5L),
  3.   recursive_sample4 = recursive_sample4(setDT(df), 5L),
  4.   f_minem = f_minem(df, 5L),
  5.   setup = {df &lt;- copy(data)}
  6.   , times = 10
  7. )
  8. # Unit: milliseconds
  9. #              expr    min     lq    mean  median      uq     max neval cld
  10. # recursive_sample3 6.2102 6.2974 9.63296 6.43245 16.3367 17.0746    10  a 
  11. # recursive_sample4 3.5145 3.6249 3.67077 3.67075  3.7513  3.7970    10   b
  12. #           f_minem 2.1705 2.1920 2.27510 2.23215  2.3784  2.4585    10   b

答案3

得分: 2

以下是您要翻译的代码部分：

  1. A `data.table` solution that keeps a running list of sampled values that are used in `setdiff` (or %!in% from `collapse`):
  3.     library(data.table)
  4.     library(collapse) # for %!in%
  6.     recursive_sample4 <- function(data, n) {
  7.       sampled <- vector("list", uniqueN(data$exposed))
  8.       data[
  9.         ,.(
  10.           unexposed = {
  11.             x <- setdiff(unexposed, unlist(sampled))
  12.             sampled[[.GRP]] <- x[sample.int(min(length(x), n))]
  13.           }
  14.         ), exposed
  15.       ]
  16.     }
  18.     recursive_sample5 <- function(data, n) {
  19.       sampled <- vector("list", uniqueN(data$exposed))
  20.       data[
  21.         ,.(
  22.           unexposed = {
  23.             x <- unexposed[unexposed %!in% unlist(sampled)]
  24.             sampled[[.GRP]] <- x[sample.int(min(length(x), n))]
  25.           }
  26.         ), exposed
  27.       ]
  28.     }
  30. Timing (including `recursive_sample3` by @minem):
  32.     data <- copy(df)
  33.     
  34.     microbenchmark::microbenchmark(
  35.       recursive_sample2 = recursive_sample2(df, 5L),
  36.       recursive_sample3 = recursive_sample3(df, 5L),
  37.       recursive_sample4 = recursive_sample4(setDT(df), 5L),
  38.       recursive_sample5 = recursive_sample5(setDT(df), 5L),
  39.       setup = {df <- copy(data)}
  40.     )
  41.     #> Unit: milliseconds
  42.     #>               expr      min        lq       mean    median        uq      max neval
  43.     #>  recursive_sample2 416.5425 427.38700 452.520780 436.58280 459.79430 614.6392   100
  44.     #>  recursive_sample3   4.5211   5.16330   6.765060   5.79820   6.95425  14.0693   100
  45.     #>  recursive_sample4   3.2038   3.57650   4.676284   4.41120   4.90855  11.6975   100
  46.     #>  recursive_sample5   2.2327   2.58255   3.384131   3.27405   3.93265   8.7091   100
  48. Note that `recursive_sample3` can give erroneous results due to the behavior of `sample` when the first argument is of length 1:
  50.     set.seed(123)
  51.     df <- tibble(exposed = rep(1:100, each = 100),
  52.                  unexposed = sample(1:700, 10000, replace = TRUE))
  53.     nrow(recursive_sample3(df, 10L))
  54.     #> [1] 704
英文:

A data.table solution that keeps a running list of sampled values that are used in setdiff (or %!in% from collapse):

  1. library(data.table)
  2. library(collapse) # for %!in%
  4. recursive_sample4 &lt;- function(data, n) {
  5.   sampled &lt;- vector(&quot;list&quot;, uniqueN(data$exposed))
  6.   data[
  7.     ,.(
  8.       unexposed = {
  9.         x &lt;- setdiff(unexposed, unlist(sampled))
  10.         sampled[[.GRP]] &lt;- x[sample.int(min(length(x), n))]
  11.       }
  12.     ), exposed
  13.   ]
  14. }
  16. recursive_sample5 &lt;- function(data, n) {
  17.   sampled &lt;- vector(&quot;list&quot;, uniqueN(data$exposed))
  18.   data[
  19.     ,.(
  20.       unexposed = {
  21.         x &lt;- unexposed[unexposed %!in% unlist(sampled)]
  22.         sampled[[.GRP]] &lt;- x[sample.int(min(length(x), n))]
  23.       }
  24.     ), exposed
  25.   ]
  26. }

Timing (including recursive_sample3 by @minem):

  1. data &lt;- copy(df)
  3. microbenchmark::microbenchmark(
  4.   recursive_sample2 = recursive_sample2(df, 5L),
  5.   recursive_sample3 = recursive_sample3(df, 5L),
  6.   recursive_sample4 = recursive_sample4(setDT(df), 5L),
  7.   recursive_sample5 = recursive_sample5(setDT(df), 5L),
  8.   setup = {df &lt;- copy(data)}
  9. )
  10. #&gt; Unit: milliseconds
  11. #&gt;               expr      min        lq       mean    median        uq      max neval
  12. #&gt;  recursive_sample2 416.5425 427.38700 452.520780 436.58280 459.79430 614.6392   100
  13. #&gt;  recursive_sample3   4.5211   5.16330   6.765060   5.79820   6.95425  14.0693   100
  14. #&gt;  recursive_sample4   3.2038   3.57650   4.676284   4.41120   4.90855  11.6975   100
  15. #&gt;  recursive_sample5   2.2327   2.58255   3.384131   3.27405   3.93265   8.7091   100

Note that recursive_sample3 can give erroneous results due to the behavior of sample when the first argument is of length 1:

  1. set.seed(123)
  2. df &lt;- tibble(exposed = rep(1:100, each = 100),
  3.              unexposed = sample(1:700, 10000, replace = TRUE))
  4. nrow(recursive_sample3(df, 10L))
  5. #&gt; [1] 704

huangapple
  • 本文由 发表于 2023年6月5日 19:00:20
  • 转载请务必保留本文链接：https://go.coder-hub.com/76405781.html
  • dataframe
  • performance
  • r
  • sampling
匿名

发表评论

匿名网友

:?: :razz: :sad: :evil: :!: :smile: :oops: :grin: :eek: :shock: :???: :cool: :lol: :mad: :twisted: :roll: :wink: :idea: :arrow: :neutral: :cry: :mrgreen:

确定