R：创建一个函数以随机替换数据框中的数据答案

【问题标题】：R: Creating a Function to Randomly Replace Data from a Data FrameR：创建一个函数以随机替换数据框中的数据
【发布时间】：2022-01-25 08:42:17
【问题描述】：

我正在使用 R 编程语言。假设我有以下数据（“my_data”）：

set.seed(123)


num_var_1 <- rnorm(1000, 10, 1)
num_var_2 <- rnorm(1000, 10, 5)
num_var_3 <- rnorm(1000, 10, 10)
num_var_4 <- rnorm(1000, 10, 10)
num_var_5 <- rnorm(1000, 10, 10)

factor_1 <- c("A","B", "C")
factor_2 <- c("AA","BB", "CC")
factor_3 <- c("AAA","BBB", "CCC", "DDD")
factor_4 <- c("AAAA","BBBB", "CCCC", "DDDD", "EEEE")
factor_5 <- c("AAAAA","BBBBB", "CCCCC", "DDDDD", "EEEEE", "FFFFFF")

factor_var_1 <- as.factor(sample(factor_1, 1000, replace=TRUE, prob=c(0.3, 0.5, 0.2)))
factor_var_2 <-  as.factor(sample(factor_2, 1000, replace=TRUE, prob=c(0.5, 0.3, 0.2)))
factor_var_3 <-  as.factor(sample(factor_3, 1000, replace=TRUE, prob=c(0.5, 0.2, 0.2, 0.1)))
factor_var_4 <-  as.factor(sample(factor_4, 1000, replace=TRUE, prob=c(0.5, 0.2, 0.1, 0.1, 0.1)))
factor_var_5 <-  as.factor(sample(factor_4, 1000, replace=TRUE, prob=c(0.3, 0.2, 0.1, 0.1, 0.1)))

id = 1:1000

my_data = data.frame(id,num_var_1, num_var_2, num_var_3, num_var_4, num_var_5, factor_var_1, factor_var_2, factor_var_3, factor_var_4, factor_var_5)


> head(my_data)
  id num_var_1 num_var_2 num_var_3 num_var_4  num_var_5 factor_var_1 factor_var_2 factor_var_3 factor_var_4 factor_var_5
1  1  9.439524  5.021006  4.883963  8.496925  11.965498            B           AA          AAA         CCCC         AAAA
2  2  9.769823  4.800225 12.369379  6.722429  16.501132            B           AA          AAA         AAAA         AAAA
3  3 11.558708  9.910099  4.584108 -4.481653  16.710042            C           AA          BBB         AAAA         CCCC
4  4 10.070508  9.339124 22.192276  3.027154  -2.841578            B           CC          DDD         BBBB         AAAA
5  5 10.129288 -2.746714 11.741359 35.984902 -10.261096            B           AA          AAA         DDDD         DDDD
6  6 11.715065 15.202867  3.847317  9.625850  32.053261            B           AA          CCC         BBBB         EEEE

我的问题：鉴于上述数据集，我正在尝试创建一个函数，通过以下方式（重复）从上述数据集中删除随机行：

第 1 步：数据集有 10 个变量 - 在第 1 步中，随机选择“n”个变量（“n”必须小于 10）。
步骤 2： 对于上述“n”个变量，如果它们是“因子”，则为这些因子变量中的每一个随机选择一个水平子集（大小为“m”）。对于每个非因子变量，将它们随机拆分到它们的最小值和最大值之间的一点（称为该点“p”）。
第 3 步：生成一个介于 0 和 1 之间的随机数（称为“r”）。
第 4 步：选择第 2 步中确定的所有行。对于这些行，请考虑逻辑条件中未使用的列。对于这些列，这些行中的任何元素都可以被 0 替换的概率为“r”。
步骤 5：重复步骤 1 - 步骤 4 10 次。

例如，这看起来像这样：

步骤1：假设n被随机选择为4。选择4个随机变量：num_var_2、num_var_5、factor_var_3、factor_var_4
第 2 步： 对于 num_var_2，选择 7 处的点。对于 num_var_5，选择 19 处的点。对于 factor_var_3，选择了 2 个级别：“BBB”和“CCC”。对于 factor_var_4，3 个级别“AAAA”、“DDDD”、“EEEE”。
第 3 步：选择随机数 0.25
第 4 步： SELECT * FROM my_table WHERE num_var_2 >7 & num_var_5 > 19 & factor_var_3 = "BBB, CCC" & factor_var_4 = "AAAA, DDDD, EEEE" 。对于未选择列中的每一行（num_var_1、num_var_3、num_var_4、factor_var_1、factor_var_2、factor_var_5），该行中的每个元素现在有 25% 的机会被 0 替换。
第 5 步：重复第 1 步 - 第 4 步，10 次。在某些时候，可能会选择过去已经被 0 替换的行。这不会有任何区别，因为 0 替换为 0 仍然是 0。

谁能告诉我如何编写一个函数来做到这一点？

目前，我正在尝试手动执行此操作：

# 4 variables are selected
n = sample.int(10, 1)
[1] 4

# which 4 variables are selected (each number corresponds to their position):
sample.int(10, length(n))
[1] 6 2 1 4

num_var_1
num_var_2
num_var_4
factor_var_1

#select random points for the continuous variables

p1 <- runif(1, min(num_var_1), max(num_var_1))
p2 <- runif(1, min(num_var_2), max(num_var_2))
p4 <- runif(1, min(num_var_4), max(num_var_4))

#select random factor levels for the factor variable

nlevel = nlevels(factor_var_1)
nlevels = sample.int(nlevel, 1)
[1] 2

sample(factor_1, nlevels, replace=TRUE, prob=c(0.3, 0.5, 0.2))
[1] "A" "B"

#generate random probability number

r = runif(1,0,1)
[1] 0.4514667

#identify rows matching the above condition

identified_rows = my_data[which(my_data$num_var_1 > p1 & my_data$num_var_2 > p2 & my_data$num_var_4 > p4 & my_data$factor_var_1 %in% c("A", "B")), ]

> identified_rows
     id num_var_1 num_var_2 num_var_3 num_var_4 num_var_5 factor_var_1 factor_var_2 factor_var_3 factor_var_4 factor_var_5
208 208  9.405383  15.53998  4.348425  29.87149  23.46945            B           CC          BBB         DDDD         DDDD
589 589 10.582991  18.84683  5.437036  31.53734  11.16494            B           BB          AAA         BBBB         CCCC

现在，对于第 208 行，剩余 6 列（num_var_3、num_var_5、factor_var_2、factor_var_3、factor_var_4、factor_var_5）中的任何一列中的值都有0.4514667 的概率被替换为 0。对于第 589 行，有0.4514667 剩余 6 列（num_var_3、num_var_5、factor_var_2、factor_var_3、factor_var_4、factor_var_5）中的任何一列中的值将被替换为 0 的概率。

在此之后，我会再次将整个过程再重复 9 次。

这是一个很长的路要走 - 有人可以帮我写一个函数来加快速度（例如重复 100 次）吗？

谢谢！

【问题讨论】：

标签： r function random data-manipulation categorical-data

【解决方案1】：

这是一个解决方案（我认为）。以下函数实现了您上面概述的 5 步过程。

random_drop <- function(x) {
  # Randomly select variables
  which_vars <- names(x[, sort(sample(ncol(x), sample(ncol(x), 1)))])
  # Randomly select factor levels subset or generate continuous cutoff value
  cutoff_vals <- lapply(
    which_vars,
    function(i) {
      if (is.factor(x[[i]])) {
        return(sample(levels(x[[i]]), sample(nlevels(x[[i]]), 1)))
      }
      runif(1, min(x[[i]], na.rm = TRUE), max(x[[i]], na.rm = TRUE))
    }
  )
  names(cutoff_vals) <- which_vars
  # Create random prob value
  r <- runif(1,0,1)
  # Generate idx for which rows to select
  row_idx <- Reduce(
    `&`,
    lapply(
      which_vars,
      function(i) {
        if (is.factor(x[[i]])) {
          return(x[[i]] %in% cutoff_vals[[i]])
        }
        x[[i]] > cutoff_vals[[i]]
      }
    )
  )
  x_sub <- x[row_idx, !colnames(x) %in% which_vars, drop = FALSE]
  # With prob. 'r' fill row values in with '0'
  r_mat <- matrix(
    sample(
      c(TRUE, FALSE), 
      ncol(x_sub)*nrow(x_sub), 
      replace = TRUE, 
      prob = c(r, 1 - r)
    ),
    nrow = nrow(x_sub),
    ncol = ncol(x_sub)
  )
  x_sub[r_mat] <- 0
  x[row_idx, !colnames(x) %in% which_vars] <- x_sub
  return(x)
}

然后这个函数将递归地应用该函数任意多次。

random_drop_recurse <- function(x, n = 10) {
  if (n == 1) return(random_drop(x))
  random_drop_recurse(random_drop(x), n = n - 1)
}

注意：0 不是有效的因子水平，因此此函数会由于尝试用0 替换因子值而生成警告，而是用NA 替换因子值。

使用上面提供的数据子集，分别运行该函数 10 次和 100 次如下所示：

set.seed(123)

num_var_1 <- rnorm(1000, 10, 1)
num_var_2 <- rnorm(1000, 10, 5)
num_var_3 <- rnorm(1000, 10, 10)
num_var_4 <- rnorm(1000, 10, 10)
num_var_5 <- rnorm(1000, 10, 10)

factor_1 <- c("A","B", "C")
factor_2 <- c("AA","BB", "CC")
factor_3 <- c("AAA","BBB", "CCC", "DDD")
factor_4 <- c("AAAA","BBBB", "CCCC", "DDDD", "EEEE")
factor_5 <- c("AAAAA","BBBBB", "CCCCC", "DDDDD", "EEEEE", "FFFFFF")

factor_var_1 <- as.factor(sample(factor_1, 1000, replace=TRUE, prob=c(0.3, 0.5, 0.2)))
factor_var_2 <-  as.factor(sample(factor_2, 1000, replace=TRUE, prob=c(0.5, 0.3, 0.2)))
factor_var_3 <-  as.factor(sample(factor_3, 1000, replace=TRUE, prob=c(0.5, 0.2, 0.2, 0.1)))
factor_var_4 <-  as.factor(sample(factor_4, 1000, replace=TRUE, prob=c(0.5, 0.2, 0.1, 0.1, 0.1)))
factor_var_5 <-  as.factor(sample(factor_4, 1000, replace=TRUE, prob=c(0.3, 0.2, 0.1, 0.1, 0.1)))

my_data = data.frame(num_var_1, num_var_2, num_var_3, num_var_4, num_var_5, factor_var_1, factor_var_2, factor_var_3, factor_var_4, factor_var_5)

random_drop <- function(x) {
  # Randomly select variables
  which_vars <- names(x[, sort(sample(ncol(x), sample(ncol(x), 1)))])
  # Randomly select factor levels subset or generate continuous cutoff value
  cutoff_vals <- lapply(
    which_vars,
    function(i) {
      if (is.factor(x[[i]])) {
        return(sample(levels(x[[i]]), sample(nlevels(x[[i]]), 1)))
      }
      runif(1, min(x[[i]], na.rm = TRUE), max(x[[i]], na.rm = TRUE))
    }
  )
  names(cutoff_vals) <- which_vars
  # Create random prob value
  r <- runif(1,0,1)
  # Generate idx for which rows to select
  row_idx <- Reduce(
    `&`,
    lapply(
      which_vars,
      function(i) {
        if (is.factor(x[[i]])) {
          return(x[[i]] %in% cutoff_vals[[i]])
        }
        x[[i]] > cutoff_vals[[i]]
      }
    )
  )
  x_sub <- x[row_idx, !colnames(x) %in% which_vars, drop = FALSE]
  # With prob. 'r' fill row values in with '0'
  r_mat <- matrix(
    sample(
      c(TRUE, FALSE), 
      ncol(x_sub)*nrow(x_sub), 
      replace = TRUE, 
      prob = c(r, 1 - r)
    ),
    nrow = nrow(x_sub),
    ncol = ncol(x_sub)
  )
  x_sub[r_mat] <- 0
  x[row_idx, !colnames(x) %in% which_vars] <- x_sub
  return(x)
}

random_drop_recurse <- function(x, n = 10) {
  if (n == 1) return(random_drop(x))
  random_drop_recurse(random_drop(x), n = n - 1)
}

suppressWarnings(
  head(
    random_drop_recurse(my_data[, c(1:3, 6:8)], 10),
    20
  )
)
#>    num_var_1 num_var_2 num_var_3 factor_var_1 factor_var_2 factor_var_3
#> 1   9.439524  5.021006  4.883963            B           AA          AAA
#> 2   9.769823  4.800225 12.369379            B           AA          AAA
#> 3  11.558708  9.910099  0.000000            C           AA          BBB
#> 4  10.070508  9.339124 22.192276            B           CC          DDD
#> 5  10.129288 -2.746714 11.741359            B           AA          AAA
#> 6  11.715065 15.202867  3.847317         <NA>           AA          CCC
#> 7  10.460916 11.248629 -8.068930            C           CC         <NA>
#> 8   8.734939 22.081037  0.000000            C           AA          BBB
#> 9   9.313147 13.425991 30.460189            C           AA          BBB
#> 10  9.554338  7.765203  4.392376            B           AA          AAA
#> 11 11.224082 23.986956  1.640007            A         <NA>          AAA
#> 12 10.359814 24.161130 16.529475            A           AA          AAA
#> 13  0.000000  3.906441  0.000000            A           CC         <NA>
#> 14 10.110683 12.345160 17.516291            B           CC          AAA
#> 15  9.444159  8.943765  7.220249            A           AA          DDD
#> 16 11.786913 10.935256 21.226542            B           CC          DDD
#> 17 10.497850 11.137714 -1.726089            B           AA          AAA
#> 18  8.033383  3.690498  9.511232            B           CC          CCC
#> 19 10.701356 11.427948  2.958597            B           BB          AAA
#> 20  9.527209 18.746237 16.807586            C           AA          BBB

suppressWarnings(
  head(
    random_drop_recurse(my_data[, c(1:3, 6:8)], 100),
    20
  )
)
#>    num_var_1 num_var_2 num_var_3 factor_var_1 factor_var_2 factor_var_3
#> 1   9.439524   0.00000  0.000000            B         <NA>         <NA>
#> 2   9.769823   0.00000 12.369379            B         <NA>         <NA>
#> 3  11.558708   0.00000  0.000000         <NA>         <NA>          BBB
#> 4  10.070508   0.00000  0.000000            B         <NA>         <NA>
#> 5  10.129288   0.00000  0.000000            B         <NA>         <NA>
#> 6  11.715065   0.00000  0.000000            B         <NA>         <NA>
#> 7  10.460916   0.00000  0.000000            C         <NA>         <NA>
#> 8   0.000000  22.08104  0.000000         <NA>           AA         <NA>
#> 9   9.313147   0.00000  0.000000            C         <NA>         <NA>
#> 10  0.000000   0.00000  0.000000            B           AA          AAA
#> 11 11.224082   0.00000  0.000000         <NA>         <NA>          AAA
#> 12 10.359814   0.00000  0.000000            A         <NA>         <NA>
#> 13 10.400771   0.00000  0.000000            A         <NA>         <NA>
#> 14 10.110683   0.00000  0.000000            B         <NA>         <NA>
#> 15  9.444159   0.00000  0.000000            A         <NA>         <NA>
#> 16 11.786913   0.00000  0.000000            B         <NA>         <NA>
#> 17 10.497850   0.00000  0.000000            B         <NA>         <NA>
#> 18  8.033383   0.00000  0.000000            B         <NA>         <NA>
#> 19  0.000000   0.00000  2.958597            B           BB          AAA
#> 20  9.527209   0.00000  0.000000            C         <NA>          BBB

【讨论】：

@Daniel Molitor：非常感谢您的回答！只是一个问题，在示例中，您为什么使用 random_drop_recurse(my_data[, c(1:3, 6:8)], 10) 而不是 random_drop_recurse(my_data, 10)？
@stats555 没问题。这纯粹是为了让我可以很好地向您展示函数的输出（不会变得太宽）！
就在每一步获取替换索引而言，这绝对是可能的，但会创建一些额外的步骤。在random_drop 中，您可能想要执行类似返回数据帧以及列表中的索引的操作，然后在random_drop_recurse 中，在每个步骤中，您可以将索引附加到一个更大的列表中，该列表显示每个删除的索引步。我会考虑一下，看看是否可以将其添加到现有答案中。
@stats555 那太好了；我添加了几行代码来满足您的需求，并且我认为在一个新问题中更容易说明。
@Daniel Molitor：我发布了新问题：stackoverflow.com/questions/70483695/…。非常感谢！