高效遞歸隨機抽樣

Question

賞金明天到期。 此問題的答案有資格獲得+300聲望獎勵。 tmfmnk正在尋找規范的答案。

想象一下以下格式的 df：

   ID1 ID2
1    A   1
2    A   2
3    A   3
4    A   4
5    A   5
6    B   1
7    B   2
8    B   3
9    B   4
10   B   5
11   C   1
12   C   2
13   C   3
14   C   4
15   C   5

問題是為 ID1 中的第一個唯一值隨機選擇一行（理想情況下可調整為 n 行），從數據集中刪除相應的 ID2 值，從剩余的 ID2 值池中隨機選擇一個值作為第二個 ID1 值（即遞歸），依此類推。

因此，例如，對於第一個 ID1 值，它將執行sample(1:5, 1) ，結果為 2。對於第二個 ID1 值，它將執行sample(c(1, 3:5), 1) ，結果為 3。對於第三個 ID1 值，它將執行sample(c(1, 4:5), 1) ，結果為 5。不可能發生至少沒有一個唯一的 ID2 值留給分配給特定的 ID1。 但是，如果要選擇多個 ID2 值（例如三個），可能會發生它們數量不足的情況； 在這種情況下，請盡可能多地選擇。 最后，結果應該具有類似的格式：

  ID1 ID2
1   A   2
2   B   3
3   C   5

它應該足夠有效地處理相當大的數據集（ID1 中的數萬個唯一值和每個 ID2 中的數十萬個唯一值）。

我嘗試了多種方法來解決這個問題，但老實說，它們都沒有意義，而且可能只會造成混亂，所以我不會在這里分享它們。

樣本數據：

df <- data.frame(ID1 = rep(LETTERS[1:3], each = 5),
                 ID2 = rep(1:5, 3))

Answer 1

我認為該算法可以滿足您的要求，但效率不高。 它可以為其他人提供更快解決方案的起點。

all_ID1 <- unique(df$ID1)
available <- unique(df$ID2)
new_ID2 <-  numeric(length(all_ID1))

for(i in seq_along(all_ID1))
{
  ID2_group <- df$ID2[df$ID1 == all_ID1[i]]
  sample_space <- ID2_group[ID2_group %in% available]
  new_ID2[i]<- sample(sample_space, 1)
  available <- available[available != new_ID2[i]]
}

data.frame(ID1 = all_ID1, ID2 = new_ID2)
#>   ID1 ID2
#> 1   A   5
#> 2   B   1
#> 3   C   2

請注意，如果您用完唯一 ID2 值，這將不起作用。 例如，如果 ID1 列中有字母 A:F，每個字母的 ID2 值為 1:5，那么當您開始為 ID1 值“F”選擇 ID2 值時，沒有唯一的 ID2 值了，因為數字 1 到 5 都已分配給字母 A:E。 您沒有在問題中說明當沒有唯一的 ID2 值可以分配給特定的 ID1 時會發生什么 - 它們應該是NA ，還是在那時允許重復？

^{由reprex 包( v2.0.0 ) 於 2021 年 11 月 3 日創建}

Answer 2

selected <- c()

for(i in unique(df[,1])) {

    x <- df[df[,"ID1"]==i,"ID2"]

    y <- setdiff(x,selected)
    selected <- unique(c(sample(y,1),selected))
    

}

data.frame(ID1 = unique(df[,1]), ID2 =selected)

給，

  ID1 ID2
1   A   4
2   B   2
3   C   3

Answer 3

您可以在split df 的Reduce使用sample 。

df <- data.frame(ID1 = rep(LETTERS[1:3], each = 5),
                 ID2 = rep(1:5, 3))
set.seed(42)

. <- split(df$ID2, df$ID1)
data.frame(ID1 = type.convert(names(.), as.is=TRUE),
           ID2 = Reduce(function(x, y) {
             y <- y[!y %in% x]
             c(x, y[sample.int(length(y),1)])}, c(list(NULL), .)))
#  ID1 ID2
#1   A   1
#2   B   2
#3   C   3

或者使用 for 循環：

. <- split(df$ID2, df$ID1)
x <- df$ID2[0]
for(y in .) {
  y <- y[!y %in% x]
  x <- c(x, y[sample.int(length(y),1)])
}
data.frame(ID1 = type.convert(names(.), as.is=TRUE), ID2 = x)
#  ID1 ID2
#1   A   1
#2   B   2
#3   C   3

或者使用fastmatch和dqrng而不是base ：

. <- split(df$ID2, df$ID1)
x <- df$ID2[0]
for(y in .) {
  y <- y[!y %fin% x]
  x <- c(x, y[dqsample.int(length(y),1)])
}
data.frame(ID1 = type.convert(names(.), as.is=TRUE), ID2 = x)
#  ID1 ID2
#1   A   2
#2   B   1
#3   C   5

並創建具有最終大小的結果向量：

. <- split(df$ID2, df$ID1)
x <- vector(typeof(df$ID2), length(.))
for(i in seq_along(.)) {
  y <- .[[i]]
  y <- y[!y %fin% x[seq_len(i-1)]]
  x[i] <- y[dqsample.int(length(y),1)]
}
data.frame(ID1 = type.convert(names(.), as.is=TRUE), ID2 = x)
#  ID1 ID2
#1   A   3
#2   B   1
#3   C   2

Answer 4

您可以嘗試以下代碼（ Reduce用於遞歸添加未訪問的ID2值）

lst <- split(df, ~ID1)
Reduce(
  function(x, y) {
    y <- subset(y,!ID2 %in% x$ID2)
    rbind(x, y[sample(nrow(y), 1), ])
  },
  lst[-1],
  init = lst[[1]][sample(1:nrow(lst[[1]]), 1), ],
)

這使

   ID1 ID2
4    A   4
7    B   2
11   C   1

Answer 5

歡迎更新基准！

df <- data.frame(
  ID1 = rep(LETTERS, each = 10000),
  ID2 = sample(1000, length(LETTERS) * 10000, replace = TRUE)
)

f_TIC1 <- function() {
  lst <- split(df, ~ID1)
  lst[[1]] <- lst[[1]][sample(1:nrow(lst[[1]]), 1), ]
  Reduce(
    function(x, y) {
      y <- subset(y, !ID2 %in% x$ID2)
      rbind(x, y[sample(nrow(y), 1), ])
    },
    lst
  )
}

library(igraph)
library(dplyr)
f_TIC2 <- function() {
  g <- df %>%
    arrange(sample(n())) %>%
    graph_from_data_frame() %>%
    set_vertex_attr(
      name = "type",
      value = names(V(.)) %in% df$ID1
    )

  type.convert(
    setNames(
      rev(
        stack(
          max_bipartite_match(g)$matching[unique(df$ID1)]
        )
      ), names(df)
    ),
    as.is = TRUE
  )
}

f_TIC3 <- function() {
  lst <- with(df, split(ID2, ID1))
  v <- c()
  for (k in seq_along(lst)) {
    u <- lst[[k]][!lst[[k]] %in% v]
    v <- c(v, u[sample(length(u), 1)])
  }
  type.convert(
    data.frame(ID1 = names(lst), ID2 = v),
    as.is = TRUE
  )
}

f_GKi1 <- function() {
  . <- split(df$ID2, df$ID1)
  data.frame(ID1 = type.convert(names(.), as.is=TRUE),
    ID2 = Reduce(function(x, y) {c(x, sample(y[!y %in% x], 1))}, c(list(NULL), .)))
}

f_GKi2 <- function() {
  . <- split(df$ID2, df$ID1)
  x <- df$ID2[0]
  for(y in .) {
    y <- y[!y %in% x]
    x <- c(x, y[sample.int(length(y),1)])
  }
  data.frame(ID1 = type.convert(names(.), as.is=TRUE), ID2 = x)
}

library(fastmatch)
library(dqrng)
f_GKi3 <- function() {
  . <- split(df$ID2, df$ID1)
  x <- df$ID2[0]
  for(y in .) {
    y <- y[!y %fin% x]
    x <- c(x, y[dqsample.int(length(y),1)])
  }
  data.frame(ID1 = type.convert(names(.), as.is=TRUE), ID2 = x)
}

f_GKi4 <- function() {
  . <- split(df$ID2, df$ID1)
  x <- vector(typeof(df$ID2), length(.))
  for(i in seq_along(.)) {
    y <- .[[i]]
    y <- y[!y %fin% x[seq_len(i-1)]]
    x[i] <- y[dqsample.int(length(y),1)]
  }
  data.frame(ID1 = type.convert(names(.), as.is=TRUE), ID2 = x)
}

bm <- microbenchmark::microbenchmark(
  f_TIC1(),
  f_TIC2(),
  f_TIC3(),
  f_GKi1(),
  f_GKi2(),
  f_GKi3(),
  f_GKi4()
)
ggplot2::autoplot(bm)
bm
#Unit: milliseconds
#     expr       min        lq      mean    median        uq       max neval
# f_TIC1()  43.14179  45.41185  47.05051  45.79306  46.59130  85.45910   100
# f_TIC2() 147.84393 152.60408 164.02179 157.15458 168.93675 199.91619   100
# f_TIC3()  12.57286  13.06033  13.87014  13.39367  14.81703  16.12412   100
# f_GKi1()  12.53613  13.05422  14.88768  13.38417  14.65109  51.45954   100
# f_GKi2()  12.56547  13.10306  15.01454  14.06471  14.72303  51.07801   100
# f_GKi3()  11.16921  11.34962  13.12718  11.52172  12.91261  49.98969   100
# f_GKi4()  11.14612  11.36738  12.48292  11.59885  12.95116  51.63936   100

目前GKi3和GKi4是最快的，其次是TIC3 、 GKi1和GKi2 ，它們或多或少相等，因為它們使用與 TIC1 相同的邏輯，在 GKi1 中優化並在 TIC3 和 GKi2 中重用。

Answer 6

一種可能的方法

library(data.table)
setDT(df)
exclude.values <- as.numeric()
L <- split(df, by = "ID1")
ans <- lapply(L, function(x) {
  sample.value <- sample(setdiff(x$ID2, exclude.values), 1)
  exclude.values <<- c(exclude.values, sample.value)
  return(sample.value)
})

Answer 7

如果我正確理解了這篇文章，那么ID2的樣本應該是單調遞增的。

這似乎有效。 方法是確定每個ID1存在多少“松弛”，然后隨機分配。

請注意，它假設每個ID1 ID2從 1 重新開始，並遞增 1。

dt <- data.table(ID1 = LETTERS[rep.int(1:10, sample(10:20, 10, replace = TRUE))])[, ID2 := 1:.N, by = ID1]

stepSample <- function(dt) {
  dt2 <- dt[, .(n = max(ID2)), by = ID1][, `:=`(slack = rev(cummin(cummin(rev(n)) - rev(.I))), inc = 0L)]
  dtSlack <- data.table(idx = 1:nrow(dt2), slack = dt2$slack)
  
  while (nrow(dtSlack)) {
    if (nrow(dtSlack) == 1L) {
      dt2[dtSlack$idx, inc := inc + sample(0:dtSlack$slack, 1L)]
      break
    } else {
      dt2[sample(dtSlack$idx, 1L), inc := inc + 1L]
      dtSlack <- dtSlack[, slack := slack - 1L][slack != 0L]
    }
  }
  
  return(dt2[, ID2 := .I + cumsum(inc)][, c("ID1", "ID2")])
}

dtSample <- stepSample(dt)

Answer 8

這是使用基礎 R 的另一個選項，我認為滿足您的要求。 我確實想指出，如果 ID2 中沒有選項，它將悄悄地排除 ID1 值（例如，如果您將n = 5放在帶有示例數據的函數中，您將看到ID1 == B被排除在外。

df <- data.frame(ID1 = rep(LETTERS[1:3], each = 5),
                 ID2 = rep(1:5, 3))

set.seed(1)
andrew_fun(df$ID1, df$ID2, n = 1)
#>   ID1 ID2
#> 1   A   1
#> 2   B   5
#> 3   C   3
andrew_fun(df$ID1, df$ID2, n = 2)
#>   ID1 ID2
#> 1   A   1
#> 2   A   2
#> 3   B   3
#> 4   B   5
#> 5   C   4
#> 6   C   2
andrew_fun(df$ID1, df$ID2, n = 3)
#>   ID1 ID2
#> 1   A   2
#> 2   A   3
#> 3   A   4
#> 4   B   1
#> 5   B   5
#> 6   C   2
#> 7   C   3
#> 8   C   4

功能：

andrew_fun = function(ID1, ID2, n = 1) {
  l = split.default(ID2, ID1)
  l_len = length(l)
  l_vals = vector("list", l_len)

  for(i in seq_along(l)) {
    vec = l[[i]]
    if(n < length(vec)) {
      val = vec[sample.int(length(vec), n)] # sample if there are enough values
    } else {
      val = vec # grab everything if not
    }
    
    l_vals[[i]] = val

    # remove values from next level of ID1
    if(i < l_len) {
      idx = i + 1L
      l[[idx]] = l[[idx]][!l[[idx]] %in% val] 
    }
  }
  data.frame(
    ID1 = rep(names(l), lengths(l_vals)),
    ID2 = unlist(l_vals, use.names = FALSE)
  )
  
}

Answer 9

還有另一種方法可以在不使用for -loop/ Recursion 甚至更高級別函數的情況下執行此操作。 我們需要注意 R 中的sample函數是向量化的。 因此，如果數據幀中的所有組大小相同，或者大小增加，那么您可以使用矢量化樣本。

n <- 1 # to be sampled from each group
s <- 5 # size of each group - Note that you have to give the minimum size. 
m <- length(unique(df[[1]])) # number of groups.
size <- min(m*n, s) #Total number of sampled data from the dataframe
samples <- sample(s, size)
index <- as.numeric(as.character(gl(s, n, size)))*s - s + samples
df[order(df[[1]]), ][index, ]

這可以寫成一個函數：

sub_sample <- function(data, n){
   s <- min(by(data, data[[1]], nrow))
   m <- length(unique(data[[1]])) 
   size <- min(m*n, s) 
   samples <- sample(s, size)
   index <- as.numeric(as.character(gl(s, n, size)))*s - s + samples
   data[order(data[[1]]), ][index, ]
}

sub_sample(df, 1)
   ID1 ID2
1    A   1
7    B   2
13   C   3

sub_sample(df, 2)
   ID1 ID2
1    A   1
5    A   5
8    B   3
7    B   2
14   C   4

請注意，當子集n=2我們只有 1 個組 C 行。 為什么？ 這是因為 C 組有 5 行。 但是我們已經為 A 組和 B 組使用了 4 個樣本。我們只為 C 組保留了 1 個樣本。