用 BASE R 中的嵌套 lapply 循环替换嵌套的“for”循环答案

【问题标题】：Replacing nested `for` loop with nested lapply loop in BASE R用 BASE R 中的嵌套 lapply 循环替换嵌套的“for”循环
【发布时间】：2021-08-09 01:42:27
【问题描述】：

我想知道是否可以将我的 for() 循环替换为等效的 *apply() 家庭？

我已经尝试过lapply()，但我无法让它工作。这在 BASE R 中可行吗？

(dat <- data.frame(id=rep(c("A", "B"), c(2, 6)), mp=c(1, 5, 2, 1, 1, 1, 5, 6), sp=c(.2, .3, .2, .2, .2, .2, .6, .6),
                  cont=c(F, T, F, F, T, T, T, T), pos=c(1, 1, rep(1:2, 3)),
                  out=c(1, 1, 1, 1, 1, 1, 2, 2)))

##### for loop:
for (x in split(dat, dat$id)) {
  pos_constant <- (length(unique(x$pos)) == 1)
  if (pos_constant) {
    next
  }
  group_out <- split(x,x$out)
  for (x_sub in group_out) {
    mps <- x_sub[x_sub$cont==TRUE,"mp"]
    sps <- x_sub[x_sub$cont==TRUE,"sp"]
    mps_constant <- length(unique(mps)) %in% c(1,0)
    sps_constant <- length(unique(sps)) %in% c(1,0)
    r <- !mps_constant || !sps_constant
    if (r) {
      stop(sprintf("'%s' has a wrong value.", x[,"id"][1]), call. = FALSE)
    }
  }
}

##### `lapply()` solution without success:
lapply(split(dat, dat$id), function(x){
  pos_constant <- (length(unique(x$pos)) == 1)
  if (pos_constant) {
  lapply(split(x, x$out), function(x_sub){
    mps <- x_sub[x_sub$cont==TRUE,"mp"]
    sps <- x_sub[x_sub$cont==TRUE,"sp"]
    mps_constant <- length(unique(mps)) %in% c(1,0)
    sps_constant <- length(unique(sps)) %in% c(1,0)
    r <- !mps_constant || !sps_constant
    if (r) {
      stop(sprintf("'%s' has a wrong value.", x[,"id"][1]), call. = FALSE)
    }
  }
 }
}

【问题讨论】：

标签： r dataframe function for-loop lapply

【解决方案1】：

类似的选项是

lapply(split(dat, dat$id), function(x){
  pos_constant <- (length(unique(x$pos)) == 1)
  if (!pos_constant) {
     lapply(split(x, x$out), function(x_sub){
      mps <- x_sub[x_sub$cont==TRUE,"mp"]
      sps <- x_sub[x_sub$cont==TRUE,"sp"]
       mps_constant <- length(unique(mps)) %in% c(1,0)
       sps_constant <- length(unique(sps)) %in% c(1,0)
       r <- !mps_constant || !sps_constant
      if (r) {
        stop(sprintf("'%s' has a wrong value.", x[,"id"][1]), call. = FALSE)
        }
           })
       }
      })
#Error: 'B' has a wrong value.

如果我们也想返回message

lapply(split(dat, dat$id), function(x){
                      pos_constant <- (length(unique(x$pos)) == 1)
                      if (!pos_constant) {
                         lapply(split(x, x$out), function(x_sub){
                          mps <- x_sub[x_sub$cont==TRUE,"mp"]
                          sps <- x_sub[x_sub$cont==TRUE,"sp"]
                           mps_constant <- length(unique(mps)) %in% c(1,0)
                           sps_constant <- length(unique(sps)) %in% c(1,0)
                           r <- !mps_constant || !sps_constant
                          if (r) {
                            stop(sprintf("'%s' has a wrong value.", 
                              x[,"id"][1]), call. = FALSE)
                            } 
                               })
                           } else {
                         message(sprintf("'%s' is ok.", x[,"id"][1]))
                   
                            }
                          })
#'A' is ok.
#Error: 'B' has a wrong value.

【讨论】：

@rnorouzian 是的，有可能，但是stop执行后，不会有新id的消息了？这是正确的行为吗
@rnorouzian 但是，一旦某个特定元素的停止为真，它就会停止一切
@rnorouzian 为您更新了以下工作
在代码中，我们按“id”和消息分割，我们只选择单个“id”，即x[,"id"][1]
@rnorouzian if/else 循环在每个唯一的 id 拆分中。此外，它在嵌套的内部 lapply 之外