r语言 - 如何为特定列重复函数并将其组合在 data.frame 中并计算平均值

Question

我有关于洪泛区的数据，有日期和洪水 0/1。我有一个功能，可以计算不同时期和不同结束日期的洪水天数。现在我想重复 severeal 列的函数(一个观测样带的几高(，并计算每个时期的洪水天数平均值。我不想为每个列手册重复我的功能。

我想知道一个带有循环的解决方案或应用程序系列的东西，但我还不够 R Guru。

set.seed(1)
df2 <- data.frame(date=seq(as.Date("2016-11-01"), as.Date("2018-11-01"), "day"),
                  flooded=rbinom(731, 1, .5), flooded2=rbinom(731, 1, .5), flooded2=rbinom(731, 1, .5))
date_end2 <- sort(sample(df2$date, 4))
period2 <- c(30,60,90)
###########################################################################################
floodCount <- function(datecol, floodcol, e, p) {
  e <- as.Date(e)
  datecol <- as.Date(datecol)
  stopifnot(!anyNA(c(e, p)))
  stopifnot((e - p) %in% datecol)
  return(sum(floodcol[which((datecol == e - p + 1)):which(datecol == e)]))
}
F_2017 <- sapply(period2, function(p) with(df2, floodCount(date, flooded,date_end2[1], p)))
S_2017 <- sapply(period2, function(p) with(df2, floodCount(date, flooded,date_end2[2], p)))
F_2018 <- sapply(period2, function(p) with(df2, floodCount(date, flooded,date_end2[3], p)))
S_2018 <- sapply(period2, function(p) with(df2, floodCount(date, flooded,date_end2[4], p)))
FLOODED.T <- rbind(F_2017, S_2017, F_2018, S_2018)
FLOODED.T2 <- as.data.frame(FLOODED.T)
names(FLOODED.T2)[1:3] <- period2[1:3]

作为中间步骤的解决方案，我希望有一个这样的数据帧：

       30 60 90 30_1 60_1 90_1 30_2 60_2 90_2 ...
F_2017 11 28 42 21   31   45   ... 
S_2017 17 30 44 18   28   ...
F_2018 14 32 48 15   ...
S_2018 15 31 49 ...

作为最终输出，每个结束日期每个周期的平均值

       30_m 60_m 90_m 
F_2017 10   30   52
S_2017 21   28   41
F_2018 13   32   47
S_2018 5    32   35 

我对你聪明而天才的R想法持开放态度;)

Answer 1

好的，事情发生了变化，我们应该再次卷起它。

我们需要另一个适用于多列的floodFun。

floodFun <- function(floodcol, datecol, e=date.end2, p=period2) {
  fc2 <- Vectorize(function(x, y, ...) {
    e <- as.Date(e[x])
    p <- p[y]
    # stopifnot(!anyNA(c(e, p)))
    # stopifnot((e - p) %in% datecol)
    if (anyNA(c(e, p)) | !((e - p) %in% datecol))
      S <- NA
    else
      S <- sum(floodcol[which(datecol == e - p + 1):which(datecol == e)])
  })
  res <- outer(seq_along(date.end2), seq(period2), fc2)
  return(res)
}

关于细胞均值，最好是sapply成 3D 阵列，

A <- sapply(df2[-1], function(x) 
  `dimnames<-`(floodFun(x, df2$date, e=date.end2, p=period2), 
               list(as.character(date.end2), period2)), simplify="array")

我们可以轻松提取手段的地方。

apply(A, 1:2, mean)
#                  30       60       90
# 2018-05-02 17.33333 33.33333 48.33333
# 2018-06-19 15.66667 30.66667 47.00000
# 2018-06-25 15.66667 30.00000 47.33333
# 2018-08-01 12.66667 29.33333 43.00000
# 2018-08-10 12.00000 29.33333 43.00000
# 2018-09-08 13.33333 25.66667 43.00000
# 2018-09-26 12.33333 27.33333 39.33333
# 2018-10-19 16.33333 27.66667 42.33333
# 2018-10-24 16.33333 28.66667 43.66667
# 2018-10-26 16.00000 28.33333 43.33333

对于"中间步骤"，请执行

tmp <- Map(function(x) `dimnames<-`(floodFun(x, df2$date, e=date.end2, p=period2),
                                  list(as.character(date.end2), period2)), df2[-1])
RES <- do.call(cbind, lapply(tmp, function(x) 
  `colnames<-`(x, paste(colnames(x), names(tmp), sep="."))))

数据

set.seed(42)
df2 <- data.frame(date=seq(as.Date("2016-11-01"), as.Date("2018-11-01"), "day"),
                  flooded.1=rbinom(731, 1, .5), flooded.2=rbinom(731, 1, .5), 
                  flooded.3=rbinom(731, 1, .5))
date.end2 <- sort(sample(tail(df2$date, 200), 10))  # I chose `tail` to avoid NAs
period2 <- c(30, 60, 90)

Answer 2

这是使用嵌套lapply/sapply来获取所有组合的另一种解决此问题的方法。

m1 <- (Reduce(`+`, lapply(df2[-1], function(x) 
                      t(sapply(date_end2, function(y) 
     sapply(period2, function(z) floodCount(df2$date, x,y, z))))))/(ncol(df2) - 1))
colnames(m1) <- paste0(period2, "_m")
m1
#     30_m 60_m 90_m
#[1,] 14.0 30.7 42.7
#[2,] 18.0 31.0 43.7
#[3,] 16.0 33.7 49.7
#[4,] 14.7 27.3 43.3

数据

set.seed(123)
df2 <- data.frame(date=seq(as.Date("2016-11-01"), as.Date("2018-11-01"), "day"),
               flooded=rbinom(731, 1, .5), flooded2=rbinom(731, 1, .5), 
              flooded2=rbinom(731, 1, .5))
date_end2 <- sort(sample(df2$date, 4))
period2 <- c(30,60,90)