減少計算系數的處理時間

Question

我有一個數據庫，一個 function，從中我可以得到coef值（它是通過lm函數計算的）。 有兩種計算方法：第一種是如果我想要一個取決於ID 、 date和Category的特定系數，另一種方法是根據subset_df1計算所有可能的coef 。

代碼正在運行。 對於第一種方式，它是即時計算的，但是對於所有coefs的計算，它需要合理的時間，如您所見。 我使用tictoc function 只是為了向您展示計算時間，它給出了633.38 sec elapsed 。 需要強調的一個重點是df1並不是一個那么小的數據庫，而是用於計算所有coef I 過濾器，在這種情況下是subset_df1 。

我在代碼中做了解釋，這樣你就可以更好地理解我在做什么。 這個想法是為所有日期>=到date1生成coef值。

最后，我想嘗試合理地減少計算所有coef值的處理時間。

library(dplyr)
library(tidyr)
library(lubridate)
library(tictoc)

#database
df1 <- data.frame( Id = rep(1:5, length=900),
                   date1 =  as.Date( "2021-12-01"),
                   date2= rep(seq( as.Date("2021-01-01"), length.out=450, by=1), each = 2),
                   Category = rep(c("ABC", "EFG"), length.out = 900),
                   Week = rep(c("Monday", "Tuesday", "Wednesday", "Thursday", "Friday",
                                "Saturday", "Sunday"), length.out = 900),
                   DR1 = sample( 200:250, 900, repl=TRUE),  
                   setNames( replicate(365, { sample(0:900, 900)}, simplify=FALSE),
                             paste0("DRM", formatC(1:365, width = 2, format = "d", flag = "0"))))
                             
return_coef <- function(df1,idd,dmda,CategoryChosse) {
  
  # First idea: Calculate the median of the values resulting from the subtraction between DR01 and the values of the DRM columns
  
  subsetDRM<-  df1 %>% select(starts_with("DRM")) 
  
  DR1_subsetDRM<-cbind (df1, setNames(df1$DR1 - subsetDRM, paste0(names(subsetDRM), "_PV"))) 
  
  subset_PV<-select(DR1_subsetDRM,Id, date2,Week, Category, DR1, ends_with("PV")) 
  
  result_median<-subset_PV %>%
    group_by(Id,Category,Week) %>%
    dplyr::summarize(dplyr::across(ends_with("PV"), median),.groups = 'drop')
  
  # Second idea: After obtaining the median, I add the values found with the values of the DRM columns of my df1 database.
  
  Sum_DRM_result_median<-df1%>%
    inner_join(result_median, by = c('Id','Category', 'Week')) %>%
    mutate(across(matches("^DRM\\d+$"), ~.x + get(paste0(cur_column(), '_PV')),
                  .names = '{col}_{col}_PV')) %>%
    select(Id:Category, DRM01_DRM01_PV:last_col())
  
  Sum_DRM_result_median<-data.frame(Sum_DRM_result_median)
  
  # Third idea: The idea here is to specifically filter a line from Sum_DRM_result_median, which will depend on what the user chooses, for that it will be necessary to choose an Id, date and Category.
  
  # This code remove_values_0 I use because sometimes i have values equal to zero so i remove these columns ((this question was solved here: https://stackoverflow.com/questions/69452882/delete-column-depending-on-the-date-and-code-you-choose)  
  remove_values_0 <- df1 %>%
    dplyr::filter(Id==idd,date2 == ymd(dmda), Category == CategoryChosse) %>%
    select(starts_with("DRM")) %>%
    pivot_longer(cols = everything()) %>%
    arrange(desc(row_number())) %>%
    mutate(cs = cumsum(value)) %>%
    dplyr::filter(cs == 0) %>%
    pull(name)
  (dropnames <- paste0(remove_values_0,"_",remove_values_0, "_PV"))
  
  filterid_date_category <- Sum_DRM_result_median %>%
    filter(Id==idd,date2 == ymd(dmda), Category == CategoryChosse) %>%
    select(-any_of(dropnames))
  
  #Fourth idea: After selecting the corresponding row, I need to select the datas for coef calculation. For this, I delete some initial lines, which will depend on the day chosen.
  
  datas <-filterid_date_category %>%
    filter(Id==idd,date2 == ymd(dmda)) %>%
    group_by(Category) %>%
    summarize(across(starts_with("DRM"), sum),.groups = 'drop') %>%
    pivot_longer(cols= -Category, names_pattern = "DRM(.+)", values_to = "val") %>%
    mutate(name = readr::parse_number(name))
  colnames(datas)[-1]<-c("days","numbers")
  
  datas <- datas %>% 
    group_by(Category) %>% 
    slice((ymd(dmda) - min(as.Date(df1$date1) [
      df1$Category == first(Category)])):max(days)+1) %>%
    ungroup
  
  # After I calculate the datas dataset, I used the lm function to obtain the coef value.
  
  mod <- lm(numbers ~ I(days^2), datas)
  coef<-coef(mod)[1]
  val<-as.numeric(coef(mod)[1])
  
  return(val)
  
}

要計算我的df1數據庫中特定ID 、 Date和Category的coef ，我這樣做：

return_coef(df1,"2","2021-12-10","ABC")
[1] 209.262 # This value may vary, as the values in my df1 database vary

要計算所有coef ，我會：

tic()
subset_df1 <- subset(df1, date2 >= date1)

All<-subset_df1%>%
   transmute(
     Id,date2,Category,
     coef = mapply(return_coef, list(cur_data()), Id, as.Date(date2), Category))
toc()
633.38 sec elapsed

Answer 1

您的代碼中存在太多問題。 我們需要從頭開始工作。 一般來說，這里有一些主要問題：

不要多次進行昂貴的操作。 像pivot_*和*_join這樣的東西並不便宜，因為它們改變了整個數據集的結構。 不要隨意使用它們，好像它們是免費提供的。
不要重復自己。 我在您的 function 中多次看到filter(Id == idd, Category ==...) 。 被過濾掉的行不會回來。 這只是浪費計算能力，使您的代碼不可讀。
在編碼之前仔細考慮。 您似乎想要多個idd 、 date2和Category的回歸結果。 那么，function 是否應該被設計為只接受標量輸入，以便我們可以多次運行它，每次都涉及在相對較大的數據集上進行幾個昂貴的數據操作，或者它應該被設計成接受所有輸入，做更少的操作，然后返回它們一次全部？ 這個問題的答案應該很清楚。

現在我將向您展示我將如何解決這個問題。 步驟是

一次找到每組idd 、 dmda和CategoryChosse的相關子集。 我們可以使用一兩個連接來找到對應的子集。 由於我們還需要計算每個Week組的中位數，我們還希望為每個dmda找到位於同一Week組中的相應日期。
Pivot 數據從長到寬，一勞永逸。 使用行 ID 來保留行關系。 調用包含那些“DRMXX” day的列和包含值value的列。
查找每個行 ID 是否存在尾隨零。 使用rev(cumsum(rev(x)) != 0)代替長而低效的管道。
按每組“Id”、“Category”、...、“day”和“Week”計算調整后的中值。 在長數據格式中，按組做事是自然而有效的。
聚合Week組。 這直接來自您的代碼，同時我們還將過濾掉小於每個dmda和每個組的相應date1之間差異的day 。
為識別的每組Id 、 Category和dmda運行lm 。
使用data.table可提高效率。
（可選）使用不同的median function 重寫為 c++，因為基礎 R 中的中位數有點慢。 我從這里得到了中位數 function 。

現在演示這些步驟的代碼

Rcpp::sourceCpp(code = '
#include <Rcpp.h>

// [[Rcpp::export]]
double mediancpp(Rcpp::NumericVector& x) {
  std::size_t n = x.size() / 2;
  std::nth_element(x.begin(), x.begin() + n, x.end());

  if (x.size() % 2) return x[n]; 
  return (x[n] + *std::max_element(x.begin(), x.begin() + n)) / 2.;
}
')

dt_return_intercept <- function(dt1, idd, dmda, category) {
  # type checks
  stopifnot(
    data.table::is.data.table(dt1), 
    length(idd) == length(dmda), 
    length(idd) == length(category)
  )
  dmda <- switch(
    class(dt1$date2), 
    character = as.character(dmda), Date = as.Date(dmda, "%Y-%m-%d"), 
    stop("non-comformable types between `dmda` and `dt1$date2`")
  )
  idd <- as(idd, class(dt1$Id))
  
  # find subsets
  DT <- data.table::setDT(list(Id = idd, date2 = dmda, Category = category, order = seq_along(idd)))
  DT <- dt1[
    dt1[DT, .(Id, Category, date2, Week, order), on = .NATURAL], 
    on = .(Id, Category, Week), allow.cartesian = TRUE
  ]
  DT[, c("rowid", "date1", "date2", "i.date2") := c(
    list(seq_len(.N)), lapply(.SD, as.Date, "%Y-%m-%d")
  ), .SDcols = c("date1", "date2", "i.date2")]
  
  # pivot + type conversion
  DT <- data.table::melt(DT, measure = patterns("DRM(\\d+)"), variable = "day")
  DT[, `:=`(day = as.integer(sub("^\\D+", "", day)), value = as.numeric(value))]
  
  # computations
  DT[, keep := rev(cumsum(rev(value)) != 0), by = "rowid"]
  DT[, value := value + mediancpp(DR1 - value), 
     by = c("Id", "Category", "i.date2", "date1", "day", "Week")]
  DT <- DT[date2 == i.date2 & keep & day > i.date2 - date1, 
           .(value = sum(value), order), 
           by = c("Id", "Category", "i.date2", "date1", "day")]
  DT[, .(out = coef(lm(value ~ I(day^2), .SD))[[1L]], order = order[[1L]]), # coef(...)[[1L]] gives you the intercept, not the coefficient of day^2. Are you sure this is what you want?
     by = c("Id", "Category", "i.date2")][order(order)]$out
}

基准

params <- (params <- unique(df1[df1$date1 <= df1$date2, c(1L, 3L, 4L)]))[sample.int(nrow(params), 20L), ]
dt1 <- data.table::setDT(data.table::copy(df1)) # nothing but a data.table version of `df1`
microbenchmark::microbenchmark(
  mapply(function(x, y, z) return_coef(df1, x, y, z), 
         params$Id, params$date2, params$Category), 
  dt_return_intercept(dt1, params$Id, params$date2, params$Category), 
  dt_return_intercept_base(dt1, params$Id, params$date2, params$Category), # use stats::median instead of mediancpp
  times = 10L, check = "equal"
)

結果如下。 check="equal"不會引發錯誤。 這意味着所有三個函數都返回相同的結果。 這個 function 比你使用mediancpp快 197 倍，比你使用stats::median快約 75 倍。 但是， mediancpp不檢查NA值。 如果您無法確認您的數據是NA免費的，那么您可能應該使用stats::median ，這始終是一個更安全的選擇。

Unit: milliseconds
                                                                                               expr        min         lq       mean     median         uq        max neval
 mapply(function(x, y, z) return_coef(df1, x, y, z), params$Id,      params$date2, params$Category) 16232.2895 17523.3854 17479.1459 17621.4208 17712.9548 17868.1786    10
                                 dt_return_intercept(dt1, params$Id, params$date2, params$Category)    73.1578    80.7950    88.5657    84.8615    90.0589   130.9921    10
                            dt_return_intercept_base(dt1, params$Id, params$date2, params$Category)   191.6221   196.1445   231.4599   235.4874   253.9788   281.4667    10

減少計算系數的處理時間

問題描述

1 個解決方案

解決方案1
0 2022-01-21 21:08:39

減少計算系數的處理時間

問題描述

1 個解決方案

解決方案1 0 2022-01-21 21:08:39

解決方案1
0 2022-01-21 21:08:39