Question

我有一个数据集，其中包含两组天范围（一天被编码为一年中的天数）。对于每一行，我想计算这些范围总计每月对应的天数。

在我的示例数据中，列“ deb”和“ fin”是每一行中第一个子范围的开始和结束日期，而“ deb2”和“ fin2”是第二个子范围的界限。

d <- data.frame(deb = c(1, 32, 90, 91), fin = c(31, 59, 91, 91),
                deb2 = c(50, 0, 0, 0), fin2 = c(60, 0, 0, 0))

d
#  deb fin deb2 fin2
#1   1  31   50   60
#2  32  59    0    0
#3  90  91    0    0
#4  91  91    0    0

例如，对于第1行，第一个范围（从'deb'到'fin'）从第1天到第31天，第二个范围从第50天到60天。

将两个范围的每月天数相加后，我希望得到类似的东西：

#     jan feb  mar
#[1,]  31  10    1
#[2,]   0  28    0
#[3,]   0   0    2
#[4,]   0   0    1

（NA而不是零不是问题）

我尝试了以下三个解决方案（第三个解决方案“ g3”是最快的），并且还尝试使用tidyverse，它显示出幅度较慢。我想知道是否有最快的选择，因为在现实生活中，我有无数行。问题似乎出在从参考范围到月参考列表的转换中，也许还在于计数的方式。

f1<-function(deb,fin,deb2,fin2,...) {
  f<-factor(c(deb:fin,deb2:fin2))
  levels(f)<-list(jan=1:31,feb=32:59,mar=60:91)
  table(f)
}
g1 <- function() do.call(rbind,d %>% pmap(f1))

K <- vector(10,mode="character")
K[1:31] <- "jan"; K[32:59] <- "feb"; K[60:91] <- "mar"
f2 <- Vectorize(function(deb,fin,deb2,fin2) table(c(K[deb:fin],K[deb2:fin2])))
g2 <- function() do.call(bind_rows,f2(d$deb,d$fin,d$deb2,d$fin2))

L <- K
names(L) <- 1:91
f3 <- Vectorize(function(deb,fin,deb2,fin2) c(L[deb:fin],L[deb2:fin2]))
g3 <- function() {
  as.matrix(do.call(bind_rows,f3(d$deb,d$fin,d$deb2,d$fin2))) -> m
  z <- unlist(map(list("jan","feb","mar"),
                   function(y) apply(m,1,function(x) sum(x==y,na.rm=TRUE))))
  dim(z)<-c(nrow(d),3)
  z

}

已更新遵循一些基准。我在试用版中添加了Chinsson12的解决方案，该解决方案在优雅的解决方案中表现良好。

firstOfMths <- seq(as.Date("2018-01-01"), as.Date("2019-01-01"), by="month")
daysPerMth <- c(1L, cumsum(as.integer(diff(firstOfMths))))
chinsoon12 <- function() 
  t(apply(d, 1, function(x)
      table(cut(c(x["deb"]:x["fin"],x["deb2"]:x["fin2"]), daysPerMth, labels=month.abb, include.lowest=TRUE, right=TRUE))

））

N <- 500
d<-data.frame(deb=rep(c(1,32,90,91),N),fin=rep(c(31,59,91,91),N),deb2=rep(c(50,0,0,0),N),fin2=rep(c(60,0,0,0),N))
microbenchmark(g1(),g2(),g3(),chinsoon12())
#Unit: milliseconds
# expr              min       lq     mean   median       uq      max neval
# g1()         571.3890 615.1020 649.7619 639.6632 662.4808 976.9566   100
# g2()         306.7141 341.3056 360.9687 353.1227 373.8194 505.0882   100
# g3()         282.2767 304.4331 320.4908 314.2377 325.8846 543.4680   100
# chinsoon12() 429.7627 469.6998 500.6289 488.5176 512.0520 729.0995   100

Answer 1

使用findInterval，Map和table：

# create breaks to be used in findInterval
b <- <- as.numeric(format(seq(as.Date("2018-01-01"), as.Date("2018-12-31"), by = "month"), "%j"))

# use Map to expand the day of year ranges by row
# use findInterval to convert day of year to month number
# use the month numbers to index month.abb 
l <- Map(function(from, to, from2, to2) month.abb[findInterval(c(from:to, from2:to2), b)], d$deb, d$fin, d$deb2, d$fin2)

# create a row index
i <- rep(1:nrow(d), lengths(l))

# use table to get a contigency table of row indices and months
table(i, factor(unlist(l), levels = month.abb))
# i   Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec
#   1  31  10   1   0   0   0   0   0   0   0   0   0
#   2   0  28   0   0   0   0   0   0   0   0   0   0
#   3   0   0   1   1   0   0   0   0   0   0   0   0
#   4   0   0   0   1   0   0   0   0   0   0   0   0

在较大的数据集（g3()）上看起来比d <- d[rep(1:nrow(d), 1e4), ]更快。

Answer 2

OP要求找到最快的方法来重新编码一年中某天的范围并计数 ，并且mentioned的生产数据集包括1000万行。 OP进行了基准测试，问题大小为2000行，测试数据仅涵盖3个月而不是12个月。

尽管我想知道这个问题的答案是可以接受的

使用melt()，foverlaps()和dcast()的{{3}}方法与其他答案的比较
以及具有不同问题大小的更切合实际的基准看起来如何。

foverlaps（）

library(data.table)
library(magrittr)
cols <- c("deb", "fin")
# reshape sub ranges from wide to long format
long <- melt(setDT(d)[, rn := .I], id.vars = "rn", measure.vars = patterns(cols),
     value.name = cols)[deb > 0]
# create data.table with monthly breaks and set keys
b <- seq(as.IDate("2018-01-01"), as.IDate("2019-01-01"), "month")
mDT <- data.table(abb = forcats::fct_inorder(month.abb), 
                  deb = yday(head(b, 12L)), 
                  fin = yday(tail(b, 12L) - 1L),
                  key = c("deb", "fin"))
# find overlaps between sub ranges and monthly breaks
foverlaps(long, mDT)[
  # compute days in overlaps
  , days := pmin(fin, i.fin) - pmax(deb, i.deb) + 1L] %>%
  # reshape to wide format for final result
  dcast(rn ~ abb, sum, value.var = "days", fill = 0L, drop = FALSE)

   rn Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec
1:  1  31  10   1   0   0   0   0   0   0   0   0   0
2:  2   0  28   0   0   0   0   0   0   0   0   0   0
3:  3   0   0   1   1   0   0   0   0   0   0   0   0
4:  4   0   0   0   1   0   0   0   0   0   0   0   0

基准

下面的基准代码进行比较

foverlaps()方法，
OP自己的方法g1，g2和g3（已修改为可处理12个月），
data.table和
Henrik's answer。

chinsoon12's now deleted answer未被考虑，因为OP AntoniosK's tidyverse answer (now deleted)认为这种方法比他自己的g2方法慢30倍。

对于基准测试，问题大小有所不同（n_rows = 100、1000、10000）以及具有两个范围的行所占的比例（p_sr_2 = 10％，50％，100％）。已针对某些方法的长期运行选择了最大的问题大小。

不同的方法在结果的类别（即data.table，matrix，tibble和table）和列数方面也不同。因此，重点放在编写适当的检查功能上。

library(bench)
library(data.table)
library(magrittr)
library(ggplot2)

bm2 <- press(
  p_sr_2 = c(0.1, 0.5, 1), # share or rows with 2nd sub range ]0, 1]
  n_rows = 10^seq(2, 4, 1),
  { # create test data
    set.seed(1L)
    d0 <- t(replicate(n_rows, sample(365L, 4L) %>% sort())) %>% data.table()
    setnames(d0, c("deb", "fin", "deb2", "fin2"))
    idx <- sample(nrow(d0), (1 - p_sr_2) * nrow(d0))
    d0[idx, c("deb2", "fin2") := 0L]
    str(d0)

    mark(
      foverlaps = {
        d <- copy(d0)
        cols <- c("deb", "fin")
        long <- melt(setDT(d)[, rn := .I], id.vars = "rn", measure.vars = patterns(cols),
                     value.name = cols)[deb > 0]
        b <- seq(as.IDate("2018-01-01"), as.IDate("2019-01-01"), "month")
        mDT <- data.table(abb = forcats::fct_inorder(month.abb), 
                          deb = yday(head(b, 12L)), 
                          fin = yday(tail(b, 12L) - 1L),
                          key = c("deb", "fin"))
        foverlaps(long, mDT)[, days := pmin(fin, i.fin) - pmax(deb, i.deb) + 1L] %>% 
          dcast(rn ~ abb, sum, value.var = "days", fill = 0L, drop = FALSE)
        # returns a data.table with 13 columns and 0 for missing values
      },
      g1 = {
        f1 <- function(deb, fin, deb2, fin2, ...) {
          f <- factor(c(deb:fin, deb2:fin2))
          levels(f) <- list(jan = 1:31,
                            feb = 32:59,
                            mar = 60:90,
                            apr = 91:120,
                            may = 121:151,
                            jun = 152:181,
                            jul = 182:212,
                            aug = 213:243,
                            sep = 244:273,
                            oct = 274:304,
                            nov = 305:334,
                            dec = 335:365)
          table(f)
        }
        do.call(rbind, d %>% purrr::pmap(f1))
        # returns a matrix with 12 named columns and 0 for missing values
      },
      g2 = {
        K <- vector(10, mode = "character")
        K[1:31]    <- "jan"
        K[32:59]   <- "feb"
        K[60:90]   <- "mar"
        K[91:120]  <- "apr"
        K[121:151] <- "may"
        K[152:181] <- "jun"
        K[182:212] <- "jul"
        K[213:243] <- "aug"
        K[244:273] <- "sep"
        K[274:304] <- "oct"
        K[305:334] <- "nov"
        K[335:365] <- "dec"
        f2 <-
          Vectorize(function(deb, fin, deb2, fin2)
            table(c(K[deb:fin], K[deb2:fin2])))
        template <- matrix(
          integer(0), ncol = 12L, 
          dimnames = list(NULL, c("jan", "feb", "mar", "apr", "may", "jun", 
                                  "jul", "aug", "sep", "oct", "nov", "dec"))) %>% 
          tibble::as.tibble()
        do.call(dplyr::bind_rows, c(list(template), f2(d$deb, d$fin, d$deb2, d$fin2))) 
        # returns a tibble with 12 columns and NA for missing values 
      },
      g3 = {
        K <- vector(10, mode = "character")
        K[1:31]    <- "jan"
        K[32:59]   <- "feb"
        K[60:90]   <- "mar"
        K[91:120]  <- "apr"
        K[121:151] <- "may"
        K[152:181] <- "jun"
        K[182:212] <- "jul"
        K[213:243] <- "aug"
        K[244:273] <- "sep"
        K[274:304] <- "oct"
        K[305:334] <- "nov"
        K[335:365] <- "dec"
        names(K) <- 1:365
        f3 <-
          Vectorize(function(deb, fin, deb2, fin2)
            c(K[deb:fin], K[deb2:fin2]))
        m <- as.matrix(do.call(dplyr::bind_rows, f3(d$deb, d$fin, d$deb2, d$fin2)))
        z <- unlist(purrr::map(list("jan", "feb", "mar", "apr", "may", "jun", 
                                    "jul", "aug", "sep", "oct", "nov", "dec"),
                               function(y)
                                 apply(m, 1, function(x)
                                   sum(x == y, na.rm = TRUE))))
        dim(z) <- c(nrow(d), 12)
        z
        # returns a matrix with 12 columns and 0 for missing values
      },
      henrik = {
        d <- copy(d0)
        b <- as.numeric(format(seq(as.Date("2018-01-01"), as.Date("2018-12-31"), 
                                   by = "month"), "%j"))
        l <- Map(
          function(from, to, from2, to2) month.abb[findInterval(c(from:to, from2:to2), b)], 
          d$deb, d$fin, d$deb2, d$fin2)
        i <- rep(1:nrow(d), lengths(l))
        table(i, factor(unlist(l), levels = month.abb))
        # returns an object of class table with 12 columns and 0 for missing values
      },
      chinsoon12 = {
        d <- copy(d0)
        firstOfMths <- seq(as.Date("2018-01-01"), as.Date("2019-01-01"), by="month")
        daysPerMth <- c(1L, cumsum(as.integer(diff(firstOfMths))))
        g <- ceiling(seq(1, ncol(d)) / 2)
        t(apply(d, 1, function(x) {
          x <- unlist(by(x, g, function(k) seq(k[1L], k[2L])), use.names=FALSE)
          table(cut(x, daysPerMth, labels=month.abb, include.lowest=TRUE, right=TRUE))
        }))
        # returns a matrix with 12 named columns and 0 for missing values
      },
      check = function(x, y) {
        cat("Run check: ")
        xdt <- as.data.table(x) %>% .[, .SD, .SDcols = tail(seq_len(ncol(.)), 12L)] 
        if (tibble::is_tibble(y)) {
          y <- dplyr::mutate_all(y, function(x) dplyr::if_else(is.na(x), 0L, x))
        }
        if (is.table(y)) y <- matrix(y, ncol = 12L)
        ydt <- as.data.table(y) %>% .[, .SD, .SDcols = tail(seq_len(ncol(.)), 12L)]
        result <- all.equal(xdt, ydt, check.attributes = FALSE)
        if (!isTRUE(result)) {
          print(result)
        } else cat("OK\n")
        return(result)
      }
    )
  }
)

可以绘制基准测试的时间：

library(ggplot2)
autoplot(bm)

commented

请注意对数时间刻度。

显然，与行数相比，具有两个范围的行份额对性能没有明显影响。对于较小的问题，henrik的方法是确认OP观察结果的最快方法。但是，对于1000行及更多行的问题大小，foverlaps方法要快得多。对于1万行，foverlaps比其他方法快一到两个数量级。

此外，内存要求也有很大差异：

bm %>%
  tidyr::unnest() %>%
  ggplot(aes(expression, mem_alloc, color = gc)) +
  ggbeeswarm::geom_quasirandom() +
  coord_flip() +
  facet_grid(p_sr_2 ~ n_rows, labeller = label_both)

再次，请注意对数刻度。

foverlaps方法分配的内存比其他方法少一到两个数量级。

基准测试第2部分

由于运行时间长（以及我的不耐烦），因此仅对最多1万行进行了高于基准测试。也仅测试了40 k行。因此，我想知道foverlaps方法是否能够在合理的时间内处理1000万行（OP生产数据集的大小）。

不幸的是，对于1M行或更大的问题，我创建输入数据的代码太慢了。因此，我不得不分别优化（和基准测试）这部分。

只有foverlaps方法的基准是OP规定的固定为25％的第二范围的份额。

library(bench)
library(data.table)
library(magrittr)
library(ggplot2)
bm5 <- press(
  n_rows = 10^seq(2, 7, 1),
  { # create test data
    cat("Start to create test data", format(Sys.time()), "\n")
    p_sr_2 <- 0.25 # share or rows with 2nd sub range ]0, 1]
    set.seed(1L)
    long <- data.table(rn = rep(seq_len(n_rows), each = 4L),
                      day = sample(365L, 4L * n_rows, replace = TRUE))
    setorder(long, rn, day)
    dups <- long[, which(anyDuplicated(day) > 0), by = rn]$rn
    if (length(dups) > 0) long[
      rn %in% dups, 
      day := replicate(length(dups), sample(365L, 4L) %>% sort(), simplify = FALSE) %>% unlist()]
    d0 <- dcast(long, rn ~ rowid(rn), value.var = "day")[, rn := NULL]
    setnames(d0, c("deb", "fin", "deb2", "fin2"))
    idx <- sample(nrow(d0), (1 - p_sr_2) * nrow(d0))
    d0[idx, c("deb2", "fin2") := 0L]
    str(d0)
    rm(long)  # free the memory
    tables()
    cat("Test data created", format(Sys.time()), "\n")

    mark(
      foverlaps = {
        d <- copy(d0)
        cols <- c("deb", "fin")
        long <- melt(setDT(d)[, rn := .I], id.vars = "rn", measure.vars = patterns(cols),
                     value.name = cols)[deb > 0]
        b <- seq(as.IDate("2018-01-01"), as.IDate("2019-01-01"), "month")
        mDT <- data.table(abb = forcats::fct_inorder(month.abb), 
                          deb = yday(head(b, 12L)), 
                          fin = yday(tail(b, 12L) - 1L),
                          key = c("deb", "fin"))
        foverlaps(long, mDT)[, days := pmin(fin, i.fin) - pmax(deb, i.deb) + 1L] %>% 
          dcast(rn ~ abb, sum, value.var = "days", fill = 0L, drop = FALSE)
        # returns a data.table with 13 columns and 0 for missing values
      },
      min_time = 2
    )
  }
)

在我的系统上，1000万行案例的运行时间约为23.7秒。对于1000行以上的问题，运行时间几乎呈线性增长。 1000万行的轻微向上弯曲可能是由于我的系统上的内存限制所致。

bm4 %>% 
  tidyr::unnest() %>% 
  ggplot(aes(n_rows, time, colour = expression)) +
  geom_smooth(data = . %>% dplyr::filter(n_rows > 10^3), 
              method = "lm", se = FALSE, colour = "blue", size = 1) + 
  geom_point(size = 2) + 
  scale_x_log10() +
  stat_summary(fun.y = median, geom = "line", size = 1) +
  ggtitle("time vs n_rows")

Henrik

请注意双对数刻度。

最快的方法来重新编码一年中的某天的范围并计数？

2 个答案:

foverlaps（）

基准

基准测试第2部分