Сделать цикл внутри функции быстрее в R

Question

Пример данных

set.seed(123)
df <- data.frame(day = 1:365, Precp = sample(1:30, 365, replace = T), 
  ETo = sample(1:10,  365, replace = T), top.FC = 23, CN = 61, DC = 0.4)

Эти данные имеют день года, количество осадков и суммарное испарение, а также некоторые константы, такие как top.FC, CN и DC.Для данного дня i функция water.update рассчитывает почвенную воду для дня i

water.update <- function(WAT0, RAIN.i, ETo.i, CN, DC, top.FC){ 

S = 25400/CN - 254;  IA = 0.2*S

if (RAIN.i > IA) { RO = (RAIN.i - 0.2 * S)^2/(RAIN.i + 0.8 * S)
} else { 
RO = 0 
}

if (WAT0 + RAIN.i - RO > top.FC) { 
DR = DC * (WAT0 + RAIN.i - RO - top.FC) 
} else { 
DR = 0 
}    
dWAT = RAIN.i - RO - DR - ETo.i
WAT1 = WAT0 + dWAT
WAT1 <- ifelse(WAT1 < 0, 0, WAT1) 
return(list(WAT1,RO,DR))
} 

Функция water.model применяет water.update для всех дней.Он рекурсивный, т.е. каждый день почвенная вода нуждается в почвенной воде предыдущего дня.Следовательно, цикл в функции water.model.

water.model <- function(dat){

 top.FC  <- unique(dat$top.FC)    

 # I make a vector to store the results 
 dat$WAT <- -9999.9
 dat$RO <- -9999.9
 dat$DR <- -9999.9

# First day (day 1) has a default value
dat$WAT[1] <- top.FC/2 # assuming top soil water is half the content on day 1   
dat$RO[1] <- NA 
dat$DR[1] <- NA

# Now calculate water content for day 2 onwards  

for(d in 1:(nrow(dat)-1)){

 dat[d + 1,7:9] <- water.update(WAT0 = dat$WAT[d], 
                                 RAIN.i = dat$Precp[d + 1], 
                                 ETo.i = dat$ETo[d + 1], 
                                 CN = unique(dat$CN), 
                                 DC = unique(dat$DC),
                                 top.FC = unique(dat$top.FC))
 }
 return(dat)
}


 ptm <- proc.time()
 result <- water.model(df)
 proc.time() - ptm

    user  system elapsed 
    0.18    0.00    0.17 

Цикл for в этом случае неизбежен, поскольку он использует содержание воды предыдущего дня для определения содержания воды текущего дня.

Есть ли более быстрый способ написать вышеуказанную функцию?Я ищу для ускорения этого кода.Причина в том, что мои реальные данные намного больше.

Answer 1

Использование Rcpp и data.table.Приведенный ниже код работает, но я получаю немного отличающиеся результаты от кода R, который вы предоставили.Я подозреваю, что это связано с тем, как я интерпретировал, какие индексы вы использовали для отставания / отведения различных столбцов, но без знания предметной области того, что представляют эти вещи, мне трудно интуитивно понять, какой должна быть правильная логика.Надеюсь, это хорошая отправная точка!

Создайте отдельный файл с именем WaterModel.cpp со следующим содержимым:

#include <Rcpp.h>
using namespace Rcpp;

// [[Rcpp::export]]

List WaterModel(NumericVector RAIN,
                NumericVector ETo,
                double CN,
                double DC,
                double topFC) {

  double S = 25400/CN - 254;
  double IA = 0.2*S;

  int n = RAIN.length();
  NumericVector WAT(n);
  NumericVector RO(n);
  NumericVector DR(n);

  WAT[0] = topFC/2;

  for (int i = 1; i < n; i++) {

    if (RAIN[i] > IA) {
      RO[i] = pow((RAIN[i-1] - 0.2 * S),2) / (RAIN[i-1] + 0.8 * S);
    } else { 
      RO[i] = 0;
    }

    if (WAT[i-1] + RAIN[i-1] - RO[i-1] > topFC) { 
      DR[i] = DC * (WAT[i-1] + RAIN[i-1] - RO[i-1] - topFC) ;
    } else { 
      DR[i] = 0 ;
    } 

    WAT[i] = WAT[i-1] + RAIN[i-1] - RO[i-1] - DR[i-1] - ETo[i-1];

    if (WAT[i] < 0){
      WAT[i] = 0;
    }

  }
    return Rcpp::List::create(Rcpp::Named("WAT") = WAT,
                              Rcpp::Named("RO") = RO,
                              Rcpp::Named("DR") = DR);

}

Затем используйте Rcpp::sourceCpp() для его получения.Затем вы можете оставить свои константы вне data.table и сохранить их как отдельные значения вместо того, чтобы повторять их для каждой отдельной строки.Это избавляет нас от необходимости выделять полные векторы в функции C++, когда все, что нам действительно нужно, это одно двойное значение и должно сэкономить время и память.

library(data.table)
library(Rcpp)

set.seed(123)
DT <- data.table(day = 1:365,
                 Precp = sample(1:30, 365, replace = T), 
                 ETo = sample(1:10,  365, replace = T))

## Don't make constant columns just to store constants
Const_topFC = 23
Const_CN = 61
Const_DC = 0.4

Rcpp::sourceCpp("WaterModel.cpp")

DT[,c("WAT","RO","DR"):= WaterModel(Precp,ETo,Const_CN,Const_DC,Const_topFC)]

DT
#       day Precp ETo     WAT  RO        DR
#   1:   1     9   8 11.50000  0  0.0000000
#   2:   2    24   2 12.50000  0  0.0000000
#   3:   3    13   1 34.50000  0  5.4000000
#   4:   4    27   5 41.10000  0  9.8000000
#   5:   5    29   5 53.30000  0 18.0400000
# ---                                     
# 361: 361     5   8 30.10327  0  8.6166592
# 362: 362     6   9 18.48661  0  4.8413088
# 363: 363    27   7 10.64530  0  0.5946452
# 364: 364    10   8 30.05066  0  5.8581216
# 365: 365    11   1 26.19254  0  6.8202636