置换数据帧但必须具有唯一的行

2023年12月15日 129次阅读

假设我有一个这样的数据帧：

d <- data.frame(time = c(1,3,5,6,11,15,15,18,18,20), side = c("L", "R", "R", "L", "L", "L", "L", "R","R","R"), id = c(1,2,1,2,4,3,4,2,1,1), stringsAsFactors = F)
d

   time side id
1     1    L  1
2     3    R  2
3     5    R  1
4     6    L  2
5    11    L  4
6    15    L  3
7    15    L  4
8    18    R  2
9    18    R  1
10   20    R  1

我希望置换id变量并保持其他两个不变.但是,重要的是,在我的最终排列中,我不希望同时在同一侧拥有相同的id.例如,有两次/两次可能发生这种情况.在时间15和18的原始数据中,在同一侧有两个唯一的id(左边是时间15,右边是时间18).如果我使用样本进行置换,则可能会在同一时间/侧面组合中显示相同的ID.

例如,

set.seed(11)
data.frame(time=d$time, side=d$side, id=sample(d$id))

   time side id
1     1    L  1
2     3    R  1
3     5    R  4
4     6    L  1
5    11    L  4
6    15    L  2
7    15    L  3
8    18    R  2
9    18    R  2
10   20    R  1

这里,id = 2出现在“R”侧的时间18的两行上.在我需要的排列中不允许这样做.

一种解决方案就是暴力破解 – 例如说我需要100个排列,我可以产生500个并丢弃那些不符合标准的那些.但是,在我的实际数据中,我有数百行,只使用samplealmost总会导致失败.我想知道是否有更好的算法来做到这一点？也许是生灭算法？

最佳答案 建立：

library(tidyverse)
d <- data.frame(time = c(1,3,5,6,11,15,15,18,18,20), side = c("L", "R", "R", "L", "L", "L", "L", "R","R","R"), id = c(1,2,1,2,4,3,4,2,1,1), stringsAsFactors = F)
d <- rownames_to_column(d)

我希望rownames在最后按顺序放回去.

你需要一个带向量的函数(比如你的id向量)并返回一个大小为n的样本,其约束值必须是不同的,如下所示(假设你想要的样本实际上可以发生,即你没有用完的物品).为方便起见,这也会返回未被采样的“剩余物”：

samp_uniq_n <- function(vec, n) {
  x <- vec
  out <- rep(NA, n)
  for(i in 1:n) {
    # Here would be a good place to make sure sampling is even possible.
    probs <- prop.table(table(x))
    out[i] <- sample(unique(x), 1, prob=probs)
    x <- x[x != out[i]]
    vec <- vec[-min(which(vec == out[i]))]
  }
  return(list(out=out, vec=vec))
}

现在,我们需要将数据拆分为具有相同时间和边的行列表,并以最大的开始采样：

id <- d$id
d_split <- d %>% select(-id) %>% split(., list(d$time, d$side), drop = TRUE)
d_split_desc <- d_split[order(-sapply(d_split, nrow))]

然后我们可以自己进行抽样：

for(i in seq_along(d_split_desc)) {
  samp <- samp_uniq_n(id, nrow(d_split_desc[[i]]))
  this_id <- samp$out
  d_split_desc[[i]]$id <- this_id
  id <- samp$vec
}

最后,一些清理：

d_permute <- do.call(rbind, d_split_desc) %>% 
  arrange(as.numeric(rowname)) %>% 
  select(-rowname)

将所有这些放在一个大功能中是一件烦恼,我会留给任何有兴趣的人.

点赞