tests/testthat/test-multiple-ts.R

In jeremyrcoyle/sl3: Pipelines for Machine Learning and Super Learning

context("test_multiple_ts.R -- Lrnr_multiple_ts")

library(data.table)
library(origami)
library(sl3)
library(R6)
library(delayed)
library(dplyr)

set.seed(49753)
if (packageVersion("origami") > "1.0.3") {
  # Simulate simple AR(2) process
  data <- matrix(arima.sim(model = list(ar = c(.9, -.2)), n = 200))
  id <- c(rep("Series_1", 50), rep("Series_2", 50), rep("Series_3", 50), rep("Series_4", 50))

  data <- data.frame(data)
  data$id <- as.factor(id)

  data <- data %>%
    group_by(id) %>%
    dplyr::mutate(time = 1:n())

  data$W1 <- rbinom(200, 1, 0.6)
  data$W2 <- rbinom(200, 1, 0.2)

  data <- as.data.table(data)

  folds <- origami::make_folds(data,
    t = max(data$time),
    id = data$id,
    time = data$time,
    fold_fun = folds_rolling_window_pooled,
    window_size = 20,
    validation_size = 15,
    gap = 0,
    batch = 10
  )


  task <- sl3_Task$new(
    data = data, outcome = "data",
    time = "time", id = "id",
    covariates = c("W1", "W2"),
    folds = folds
  )

  train_task <- training(task, fold = task$folds[[1]])
  valid_task <- validation(task, fold = task$folds[[1]])


  # Learners
  lrnr_lasso <- make_learner(Lrnr_glmnet, alpha = 1)
  lrnr_mean <- make_learner(Lrnr_mean)
  lrnr_arima <- Lrnr_arima$new()
  lrnr_exp_smooth <- Lrnr_expSmooth$new()

  multiple_ts_arima <- Lrnr_multiple_ts$new(
    learner = lrnr_arima
  )


  stack <- make_learner(Stack, unlist(list(lrnr_mean, multiple_ts_arima),
    recursive = TRUE
  ))


  test_that("Lrnr_multiple_ts fits each time-series separately", {
    multiple_ts_arima_fit <- multiple_ts_arima$train(train_task)
    multiple_ts_arima_preds <- multiple_ts_arima_fit$predict(valid_task)

    sub_data_s1 <- multiple_ts_arima_fit$fit_object$Series_1$training_task$data
    sub_data_f1 <- multiple_ts_arima_fit$fit_object$Series_1$training_task$folds

    expect_true(length(multiple_ts_arima_preds) == 60)
    expect_true(length(multiple_ts_arima_fit$fit_object) == 4)
    expect_true(nrow(sub_data_s1) == 20)
    #
    # expect_true(length(sub_data_f1[[1]]$validation_set) == 15)
    # expect_true(length(sub_data_f1[[2]]$validation_set) == 15)
  })

  test_that("Lrnr_multiple_ts fits multiple learners separately", {
    fit_stack <- stack$train(train_task)
    pred_stack <- fit_stack$predict(valid_task)

    expect_true(ncol(pred_stack) == 2)
    expect_true(nrow(pred_stack) == 60)
  })
}