admin管理员组

文章数量:1345581

Is there a way to calculate the sum (or mean, etc.) for a range of values that are defined for that row in another column?

Here's some sample data:

structure(list(start = c("cmi_apr", "cmi_may", "cmi_may"), end = c("cmi_oct", 
"cmi_oct", "cmi_dec"), cmi_jan = c(2.35, 2.24, 37.66), cmi_feb = c(1.33, 
5.65, 43.23), cmi_mar = c(0.08, 4.43, 22.2), cmi_apr = c(0.17, 
6.48, 18.56), cmi_may = c(-5.61, 0.54, 21.52), cmi_jun = c(-6.37, 
-0.92, 13.86), cmi_jul = c(-6.53, 5.18, 2.81), cmi_aug = c(-2.37, 
4.4, 21.32), cmi_sep = c(1.28, 0.92, 19.48), cmi_oct = c(0.33, 
11.21, 26.43), cmi_nov = c(1.41, 9.18, 43.87), cmi_dec = c(2.21, 
10.96, 30.54)), row.names = c(NA, -3L), class = c("tbl_df", "tbl", 
"data.frame"))

I want to generate range sums based on the start and end variable like this:

I have a solution, however my real dataset has over 60,000 rows and it takes way too long to complete the calculation. I figure this should be a lot faster since addition is vectorized. Here's my current solution:

compute_growing_season <- function(df, start_colname, end_colname, FUN) {
  # Generate column index vectors
  start_idx = sapply(start_colname, function(x) { which(x == names(df))} )
  end_idx = sapply(end_colname, function(x) { which(x == names(df))} )
  
  # Generate computed vector
  results <- numeric(nrow(df))
  for (i in 1:nrow(df)) {
    results[i] <- FUN(df[i, start_idx[i]:end_idx[i]], na.rm = F)
  }
  
  return(results)
}

output <- sample %>%
  mutate(
    cmi_growingseason_sum = compute_growing_season(., start, end, sum)
  )

Is there a way to calculate the sum (or mean, etc.) for a range of values that are defined for that row in another column?

Here's some sample data:

structure(list(start = c("cmi_apr", "cmi_may", "cmi_may"), end = c("cmi_oct", 
"cmi_oct", "cmi_dec"), cmi_jan = c(2.35, 2.24, 37.66), cmi_feb = c(1.33, 
5.65, 43.23), cmi_mar = c(0.08, 4.43, 22.2), cmi_apr = c(0.17, 
6.48, 18.56), cmi_may = c(-5.61, 0.54, 21.52), cmi_jun = c(-6.37, 
-0.92, 13.86), cmi_jul = c(-6.53, 5.18, 2.81), cmi_aug = c(-2.37, 
4.4, 21.32), cmi_sep = c(1.28, 0.92, 19.48), cmi_oct = c(0.33, 
11.21, 26.43), cmi_nov = c(1.41, 9.18, 43.87), cmi_dec = c(2.21, 
10.96, 30.54)), row.names = c(NA, -3L), class = c("tbl_df", "tbl", 
"data.frame"))

I want to generate range sums based on the start and end variable like this:

I have a solution, however my real dataset has over 60,000 rows and it takes way too long to complete the calculation. I figure this should be a lot faster since addition is vectorized. Here's my current solution:

compute_growing_season <- function(df, start_colname, end_colname, FUN) {
  # Generate column index vectors
  start_idx = sapply(start_colname, function(x) { which(x == names(df))} )
  end_idx = sapply(end_colname, function(x) { which(x == names(df))} )
  
  # Generate computed vector
  results <- numeric(nrow(df))
  for (i in 1:nrow(df)) {
    results[i] <- FUN(df[i, start_idx[i]:end_idx[i]], na.rm = F)
  }
  
  return(results)
}

output <- sample %>%
  mutate(
    cmi_growingseason_sum = compute_growing_season(., start, end, sum)
  )

• r
• tidyverse

Share Improve this question Follow edited 2 days ago ThomasIsCoding 103k99 gold badges3737 silver badges102102 bronze badges asked 2 days ago frandudefrandude 18188 bronze badges 6

• 1 Have you considered pivoting long? It's an easy task afterwards. – Friede Commented 2 days ago
• There is 1 column for each month of a parameter CMI (so 12 columns), but I only want to find the sums between the start and end months, so the sums being calculated are not necessarily equal lengths nor using the same windows. – frandude Commented 2 days ago
• I'd love to know how to solve this by pivoting long – frandude Commented 2 days ago
• Do you need the cmi-prefix? I.e. are there other columns containing month information in your actual data? Why are you mixing dplyr with base? Any reason for using dplyr? – Friede Commented yesterday
• Your solution is inefficient exactly because it is not vectorized. A pretty simple instant improvement would be to perform calculation grouped by start and end, which means that for all cases with same start end you can do the operations vectorized, resulting in at most n * (n + 1) / 2 runs where n is the number of relevant columns. – Lazy Commented yesterday

 |  Show 1 more comment

8 Answers 8

Sorted by: Reset to default 6

There might be better names than sample for a tibble. In dplyr syntax (data and code suggest you are already using those packages), you might want to start developing something from here. Staying in long format may bring advantages.

library(tidyr)
library(dplyr)

sample |>
  rename_with(~sub('^cmi_', '', .), starts_with('cmi')) |>
  mutate(row = row_number(), start = sub('^cmi_', '', start), 
         end = sub('^cmi_', '', end), .before = start) |>
  pivot_longer(cols = -c(row, start, end), names_to = 'month', values_to = 'value') |>
  mutate(across(c(start, end, month), ~match(., tolower(month.abb)), .names = '{.col}_i')) |>
  mutate(gs_sum = sum(value[between(month_i, start_i, end_i)]), .by = row) |>
  pivot_wider(id_cols = -ends_with('_i'), names_from = 'month', values_from = 'value')

# A tibble: 3 × 15
  start end   gs_sum   jan   feb   mar   apr   may   jun   jul   aug   sep   oct   nov   dec
  <chr> <chr>  <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
1 apr   oct    -19.1  2.35  1.33  0.08  0.17 -5.61 -6.37 -6.53 -2.37  1.28  0.33  1.41  2.21
2 may   oct     21.3  2.24  5.65  4.43  6.48  0.54 -0.92  5.18  4.4   0.92 11.2   9.18 11.0 
3 may   dec    180.  37.7  43.2  22.2  18.6  21.5  13.9   2.81 21.3  19.5  26.4  43.9  30.5 

If you like the idea of going from wide to long back to wide. Surely, there is room for optimisation, but not needed at 60k rows. Included some re-arrangements: removing cmi-prefix; if you need it, keep it instead.

---

Base R. (1) Reshaping (might be useful later), (2) Months to integer representation and aggregation.

names(sample) = sub('^cmi_', '', names(sample))
sample[c('start', 'end')] = lapply(sample[c('start', 'end')], 
  \(i) match(sub('^cmi_', '', i), tolower(month.abb)))

reshape(as.data.frame(sample), varying=tolower(month.abb),  
        v.names='value', timevar='month', direction='l') |>
  subset(month >= start & month <= end) |>
  aggregate(value~id, data=_, sum) # id = row
## or aggregate(cbind(gs_sum=value)~cbind(row=id), data=_, sum) to re-name

  id  value
1  1 -19.10
2  2  21.33
3  3 179.83

We could multiply by a boolean matrix and just do rowSums().

mk_boolean <- \(dat) {
  stopifnot(
    match(sub('.*_', '', names(dat)[-(1:2)]),  ## check for valid structure
          tolower(month.abb)) == 1:12)
  ix <- array(FALSE, dim(dat) - c(0, 2))
  s <- match(dat$start, names(dat)) - 2
  e <- match(dat$end, names(dat)) - 2
  for (i in seq_len(nrow(ix))) {
    ix[i, s[i]:e[i]] <- TRUE
  }
  ix
}

> rowSums(as.matrix(dat[-(1:2)])*mk_boolean(dat))
[1] -19.10  21.33 179.83

Note: as.matrix(dat[-(1:2)]) coerces the value part of the data frame to a numeric matrix. Solution assumes, there's no missing data.

This runs ~250 ms on 1e6 rows:

> dat1 <- dat[sample.int(nrow(dat), 1e6, replace=TRUE), ]
> median(replicate(10, system.time(rowSums(as.matrix(dat1[-(1:2)])*mk_boolean(dat1))))['elapsed', ])
[1] 0.2535

Benchmark on 60K rows

$ Rscript --vanilla foo.R
Unit: milliseconds
 expr         min          lq        mean      median          uq         max neval    cld
   OP  3590.85116  3704.74528  3724.21890  3741.12687  3765.88398  3796.29571     7 a     
 Fri1   506.23107   515.67786   555.44382   523.30474   596.68277   633.84966     7  b    
 Fri2   837.06177   930.40294  1019.39328  1000.53680  1128.74173  1179.86501     7   c   
  Ggr 10380.33648 10437.12937 10531.00274 10523.29611 10607.37366 10724.38053     7    d  
  Tho    34.35523    39.82415    70.27250    52.92480    87.13069   150.71777     7     e 
  The    62.85395    64.04024    76.74724    67.13938    71.95369   135.24950     7     e 
  Tim  3850.96011  3997.81038  4181.21920  4083.68056  4352.27350  4633.72598     7      f
  Kni   102.46322   106.35692   121.24207   109.65788   122.34785   179.16387     7     e 
  Jay    14.25244    16.19633    20.04956    19.87360    22.89518    28.03783     7     e 

Code:

dat1 <- dat0[sample.int(nrow(dat0), 6e4, replace=TRUE), ] 
suppressPackageStartupMessages(invisible(sapply(c('tidyr', 'dplyr', 'data.table'), require, character.only=TRUE)))
options(width=200, digits=7)
suppressWarnings(suppressMessages(bench <- microbenchmark::microbenchmark(
  OP=with(dat1, compute_growing_season(df=dat1, start_colname=start, end_colname=end, FUN=sum)),
  Fri1=(dat1 |>
    rename_with(~sub('^cmi_', '', .), starts_with('cmi')) |>
    mutate(row = row_number(), start = sub('^cmi_', '', start), 
           end = sub('^cmi_', '', end), .before = start) |>
    pivot_longer(cols = -c(row, start, end), names_to = 'month', values_to = 'value') |>
    mutate(across(c(start, end, month), ~match(., tolower(month.abb)), .names = '{.col}_i')) |>
    mutate(gs_sum = sum(value[between(month_i, start_i, end_i)]), .by = row) |>
    pivot_wider(id_cols = -ends_with('_i'), names_from = 'month', values_from = 'value'))[['gs_sum']],
  Fri2={
    dat1a <- dat1
    names(dat1a) = sub('^cmi_', '', names(dat1a))
    dat1a[c('start', 'end')] = lapply(dat1a[c('start', 'end')], 
                                      \(i) match(sub('^cmi_', '', i), tolower(month.abb)))
    
    (reshape(as.data.frame(dat1a), varying=tolower(month.abb),  
             v.names='value', timevar='month', direction='l') |>
        subset(month >= start & month <= end) |>
        aggregate(value~id, data=_, sum))[, 2]
  },
  Ggr={
    dat1a <- dat1
    (dat1a %>%
        bind_cols(
          mutate(., start = match(start, names(.)),
                 end = match(end, names(.))) %>%
            rowwise %>%
            reframe(cmi_growingseason_sum = sum(c_across(everything())[start:end])) %>%
            ungroup))[['cmi_growingseason_sum']]
  }, 
  Tho={
    (dat1 %>%
       left_join({
         .
       } %>%
         pivot_longer(
           cols = -(1:2),
           names_to = "date",
           values_to = "val"
         ) %>%
         reframe(
           cmi_growingseason_sum = sum(val[match(start[1], date):match(end[1], date)]),
           .by = c(start, end)
         )))[['cmi_growingseason_sum']]
  },
  The={
    dt <- as.data.table(dat1)
    dt[, id := .I]
    montonum <- function(x) match(sub("cmi_", "", x), table=tolower(month.abb))
    samplong <- melt(dt, id.vars="id", measure.vars=patterns("cmi_"),
                     variable.name="month", value.name="cmi")
    samplong[, month := montonum(month)]
    dt[, names(.SD) := NULL, .SDcols = -c("id","start","end")]
    dt[, names(.SD) := lapply(.SD, montonum), .SDcols=c("start","end")]
    samplong[dt, on=.(id,month>=start,month<=end),
             .(cmi = sum(cmi)), by=id][[2]]
  },
  Tim={
    dt <- as.data.table(dat1)
    
    dt[, range_sum := {
      cmi_cols <- grep("^cmi_", names(dt), value = TRUE)
      cmi_cols <- setdiff(cmi_cols, c("start", "end"))
      start_pos <- match(start, cmi_cols)
      end_pos <- match(end, cmi_cols)
      sum(unlist(.SD[, cmi_cols[start_pos:end_pos], with = FALSE]))
      
    }, by = 1:nrow(dt)][['range_sum']]
  },
  Kni={
    mat <- as.matrix(cbind(
      start = match(dat1$start, colnames(dat1)),
      end = match(dat1$end, colnames(dat1)),
      dat1[, -c(1, 2)]
    ))
    apply(mat, 1, \(x) sum(x[x[1]:x[2]]))
  },
  Jay={
    rowSums(as.matrix(dat1[-(1:2)])*mk_boolean(dat1))
  }, check='equal',
  times=7L)))
bench

---

Data:

> dput(dat)
structure(list(start = c("cmi_apr", "cmi_may", "cmi_may"), end = c("cmi_oct", 
"cmi_oct", "cmi_dec"), cmi_jan = c(2.35, 2.24, 37.66), cmi_feb = c(1.33, 
5.65, 43.23), cmi_mar = c(0.08, 4.43, 22.2), cmi_apr = c(0.17, 
6.48, 18.56), cmi_may = c(-5.61, 0.54, 21.52), cmi_jun = c(-6.37, 
-0.92, 13.86), cmi_jul = c(-6.53, 5.18, 2.81), cmi_aug = c(-2.37, 
4.4, 21.32), cmi_sep = c(1.28, 0.92, 19.48), cmi_oct = c(0.33, 
11.21, 26.43), cmi_nov = c(1.41, 9.18, 43.87), cmi_dec = c(2.21, 
10.96, 30.54)), row.names = c(NA, -3L), class = c("tbl_df", "tbl", 
"data.frame"))

Here is a data.table approach

library(data.table)
dt <- as.data.table(df)

dt[, range_sum := {
  cmi_cols <- grep("^cmi_", names(dt), value = TRUE)
  cmi_cols <- setdiff(cmi_cols, c("start", "end"))
  start_pos <- match(start, cmi_cols)
  end_pos <- match(end, cmi_cols)
  sum(unlist(.SD[, cmi_cols[start_pos:end_pos], with = FALSE]))

}, by = 1:nrow(dt)]

giving

start     end cmi_jan cmi_feb cmi_mar cmi_apr cmi_may cmi_jun cmi_jul

1: cmi_apr cmi_oct    2.35    1.33    0.08    0.17   -5.61   -6.37   -6.53

2: cmi_may cmi_oct    2.24    5.65    4.43    6.48    0.54   -0.92    5.18

3: cmi_may cmi_dec   37.66   43.23   22.20   18.56   21.52   13.86    2.81

   cmi_aug cmi_sep cmi_oct cmi_nov cmi_dec range_sum

1:   -2.37    1.28    0.33    1.41    2.21    -19.10

2:    4.40    0.92   11.21    9.18   10.96     21.33

3:   21.32   19.48   26.43   43.87   30.54    179.83

Adding yet another answer, for efficiency reasons, we can try to (i) avoid any row-wise operations, and (ii) avoid reshaping the initial dataset.

The sum of a specified range from:to of a vector x can be found by storing the cumsum (cs = cumsum(x)) and using cs[to] - cs[from - 1]. Of course we need to take care for cases where from == 1.

A way to operate column-wise on the dataset, as is, is to utilize Reduce (d is the example dataset) to store the cumulative sums for each row efficiently:

val_columns = grep("^cmi_", names(d), value = TRUE)

# init = 0; to handle cases where start == 1
cum_sums = do.call(cbind, Reduce("+", d[, val_columns], accumulate = TRUE, init = 0))

And then subset according to the range of each row:

end_cumsum = cum_sums[cbind(1:nrow(d), match(d$end, val_columns) + 1)] 
start_cumsum = cum_sums[cbind(1:nrow(d), match(d$start, val_columns))] 

end_cumsum - start_cumsum
#[1] -19.10  21.33 179.83

For each row compute the numeric indexes of the columns to sum and perform the sum.

library(dplyr)
output2 <- sample %>%
  bind_cols(
    mutate(., start = match(start, names(.)),
              end = match(end, names(.))) %>%
    rowwise %>%
    reframe(cmi_growingseason_sum = sum(c_across(everything())[start:end])) %>%
    ungroup)

identical(output, output2)
## [1] TRUE

You can try

df %>%
  left_join({
    .
  } %>%
    pivot_longer(
      cols = -(1:2),
      names_to = "date",
      values_to = "val"
    ) %>%
    reframe(
      cmi_growingseason_sum = sum(val[match(start[1], date):match(end[1], date)]),
      .by = c(start, end)
    ))

data.table approach, but in long form. Seems to work in a fraction of a second for the core operation.

## make a 60K file 
samp <- as.data.frame(samp)
samp <- samp[rep(1:3, 20000),]

## load data.table
library(data.table)
setDT(samp)

## do some reshaping to long and cleaning up
samp[, id := .I]
montonum <- function(x) match(sub("cmi_", "", x), table=tolower(month.abb))
samplong <- melt(samp, id.vars="id", measure.vars=patterns("cmi_"),
                 variable.name="month", value.name="cmi")
samplong[, month := montonum(month)]
samp[, names(.SD) := NULL, .SDcols = -c("id","start","end")]
samp[, names(.SD) := lapply(.SD, montonum), .SDcols=c("start","end")]

## then the core task in a single call once the data is structured in long form
system.time({
results <- samplong[samp, on=.(id,month>=start,month<=end),
                    .(cmi = sum(cmi)), by=id]
})
##   user  system elapsed 
##   0.02    0.02    0.10

results
##          id    cmi
##       <int>  <num>
##    1:     1 -19.10
##    2:     2  21.33
##    3:     3 179.83
###   ...

Surprised I haven't seen a simple apply, just needs matrix input. Coerce start and end to column indices first, then use a function on each row with apply.

mat <- as.matrix(cbind(
  start = match(df$start, colnames(df)),
  end = match(df$end, colnames(df)),
  df[, -c(1, 2)]
))
df$cmi_growingseason_sum <- apply(mat, 1, \(x) sum(x[x[1]:x[2]]))

df$cmi_growingseason_sum
# [1] -19.10  21.33 179.83

本文标签： tidyverseIs there an R function to calculate row sums using a rangewindow of column indicesStack Overflow