Início / coding / Perguntas / 79551531
Accepted
frandude
Asked: 2025-04-03 04:35:10 +0800 CST

Existe uma função R para calcular somas de linhas usando um intervalo/janela de índices de colunas?

  • 772

Existe uma maneira de calcular a soma (ou média, etc.) de um intervalo de valores definidos para aquela linha em outra coluna?

Aqui estão alguns dados de exemplo:

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"))

Quero gerar somas de intervalo com base na variável startand endassim:

insira a descrição da imagem aqui

Eu tenho uma solução, porém meu conjunto de dados real tem mais de 60.000 linhas e demora muito para concluir o cálculo. Imagino que isso deva ser muito mais rápido, já que a adição é vetorizada. Aqui está minha solução atual:

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)
  )

8 respostas

  1. Best Answer

    Pode haver nomes melhores do que samplepara um tibble. Na dplyrsintaxe (dados e código sugerem que você já esteja usando esses pacotes), você pode querer começar a desenvolver algo a partir daqui. Ficar em formato longo pode trazer vantagens.

    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

    Se você gosta da ideia de ir de largo para longo de volta para largo. Certamente, há espaço para otimização, mas não é necessário em 60 mil linhas. Incluí alguns rearranjos: removendo cmi-prefix; se precisar, mantenha-o.

    Base R. (1) Remodelagem (pode ser útil mais tarde), (2) Meses para representação e agregação de inteiros.

    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
    • 6

  2. Poderíamos multiplicar por uma matriz booleana e simplesmente fazer 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

    Nota: as.matrix(dat[-(1:2)]) força a parte do valor do quadro de dados para uma matriz numérica. A solução assume que não há dados faltantes.

    Isso roda ~250 ms em 1e6 linhas:

    > 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

    Referência em 60 mil linhas

    $ 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

    Código:

    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

    Dados:

    > 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"))
    • 6

  3. Aqui está uma abordagem data.table

    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)]

    dando

    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
    • 4

  4. Adicionando ainda outra resposta, por razões de eficiência, podemos tentar (i) evitar quaisquer operações por linha e (ii) evitar remodelar o conjunto de dados inicial.

    A soma de um intervalo especificado from:tode um vetor xpode ser encontrada armazenando o cumsum( cs = cumsum(x)) e usando cs[to] - cs[from - 1]. Claro que precisamos tomar cuidado com os casos em que from == 1.

    Uma maneira de operar em colunas no conjunto de dados, como está, é utilizar Reduce( dé o conjunto de dados de exemplo) para armazenar as somas cumulativas para cada linha de forma eficiente:

    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))

    E então subdivida de acordo com o intervalo de cada linha:

    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
    • 4

  5. Para cada linha, calcule os índices numéricos das colunas a serem somadas e execute a soma.

    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
    • 3

  6. Você pode tentar

    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)
    ))
    • 3

  7. abordagem data.table , mas em formato longo. Parece funcionar em uma fração de segundo para a operação principal.

    ## 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
###   ...
    • 3

  8. Surpreso por não ter visto um simples apply, só precisa de entrada de matriz. Coerce startand endpara índices de coluna primeiro, então use uma função em cada linha com 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
    • 1

relate perguntas