inst/doc/Getting_Started_Advanced.R

In PortfolioTesteR: Test Investment Strategies with English-Like Code

## ----setup, include=FALSE-----------------------------------------------------
knitr::opts_chunk$set(
  collapse = TRUE,
  comment = "#>",
  fig.width = 7,
  fig.height = 5,
  dpi = 96,
  message = FALSE,
  warning = FALSE
)
set.seed(1)

# CRAN vs local
heavy <- identical(Sys.getenv("NOT_CRAN"), "true")  # CRAN sets this to "false"

# Optional backends (Suggests)
has_xgb <- requireNamespace("xgboost", quietly = TRUE)
has_rf  <- requireNamespace("ranger",  quietly = TRUE)

# Sequences are OFF by default (CRAN-safe). Opt-in locally with:
# Sys.setenv(RUN_SEQ = "true")  # or RUN_KERAS_VIGNETTES = "true" (back-compat)
run_seq <- FALSE
run_seq_env <- tolower(Sys.getenv("RUN_SEQ", Sys.getenv("RUN_KERAS_VIGNETTES", "false")))
if (heavy && run_seq_env %in% c("true","1","yes") && requireNamespace("keras", quietly = TRUE)) {
  # only now ask Keras if it's actually usable (this can spin up TF)
  run_seq <- isTRUE(try(keras::is_keras_available(), silent = TRUE))
}

# Base-R helper to sandbox TF Autograph cache per-chunk (no 'withr' usage)
tf_autograph_scope <- function() {
  ag_dir <- file.path(tempdir(), paste0("tf_ag_cache_", as.integer(runif(1, 1, 1e9))))
  dir.create(ag_dir, showWarnings = FALSE, recursive = TRUE)
  old_ag <- Sys.getenv("TF_AUTOGRAPH_CACHE_DIR", unset = NA_character_)
  Sys.setenv(TF_AUTOGRAPH_CACHE_DIR = ag_dir)
  # Ensure cleanup when the chunk completes
  on.exit({
    if (!is.na(old_ag)) Sys.setenv("TF_AUTOGRAPH_CACHE_DIR", old_ag) else Sys.unsetenv("TF_AUTOGRAPH_CACHE_DIR")
    unlink(ag_dir, recursive = TRUE, force = TRUE)
    unlink(Sys.glob(file.path(tempdir(), "__autograph_generated_file*.py")), force = TRUE)
    unlink(file.path(tempdir(), "__pycache__"), recursive = TRUE, force = TRUE)
  }, add = TRUE)
  invisible(NULL)
}

## ----libs_data----------------------------------------------------------------
suppressPackageStartupMessages(library(PortfolioTesteR))
suppressPackageStartupMessages(library(data.table))

# Bundled sample data
data(sample_prices_weekly)
data(sample_prices_daily)

# Optional peek
head(sample_prices_weekly[, 1:6])

## ----baseline_pooled----------------------------------------------------------
# Prepare tabular features and labels
X <- ml_prepare_features(sample_prices_weekly, sample_prices_daily)
Y <- make_labels(sample_prices_weekly, horizon = 4L, type = "log")

# Linear/Ridge baseline
ridge <- ml_make_model("ridge")

set.seed(1)
res_baseline <- ml_backtest(
  features_list = X, labels = Y,
  fit_fn  = ridge$fit,
  predict_fn = ridge$predict,
  schedule = list(is = 104L, oos = 4L, step = 4L),  # 2y IS, 1m OOS, monthly step
  transform = "zscore",                              # IS-only scaling (no leakage)
  selection = list(top_k = 15L),
  weighting = list(method = "rank"),
  prices = sample_prices_weekly,
  initial_capital = 1e5,
  name = "Baseline Ridge (pooled)"
)

print(res_baseline$backtest)
plot(res_baseline$backtest, type = "performance")

## ----ensemble, eval=has_rf || has_xgb-----------------------------------------
# Start with ridge (always available)
models <- list(ml_make_model("ridge"))

# Add RF only if ranger is installed
if (has_rf) {
  models <- c(models, list(ml_make_model("rf", num.trees = if (heavy) 400L else 200L, mtry = 3L)))
}

# Add XGBoost only if xgboost is installed
if (has_xgb) {
  models <- c(models, list(
    ml_make_model(
      "xgboost",
      params  = list(objective = "reg:squarederror", max_depth = 4L, eta = 0.07),
      nrounds = if (heavy) 300L else 150L
    )
  ))
}

# Build the ensemble from whatever is available
ens <- do.call(ml_make_ensemble, models)

set.seed(2)
res_ens <- ml_backtest(
  features_list = X, labels = Y,
  fit_fn = ens$fit, predict_fn = ens$predict,
  schedule = list(is = 104L, oos = 4L, step = 4L),
  transform = "zscore",
  selection = list(top_k = 15L),
  weighting = list(method = "rank"),
  prices = sample_prices_weekly,
  initial_capital = 1e5,
  name = "Ensemble (available learners)"
)

print(res_ens$backtest)
plot(res_ens$backtest, type = "performance")

## ----xgb_per_group, eval=has_xgb----------------------------------------------
symbols <- setdiff(names(sample_prices_weekly), "Date")
gmap    <- demo_sector_map(symbols, n_groups = 4L)  # demo mapping for the sample data

xgb_g <- ml_make_model(
  "xgboost",
  params  = list(objective = "reg:squarederror", max_depth = 3L, eta = 0.05),
  nrounds = if (heavy) 250L else 150L
)

set.seed(3)
res_xgb_sect <- ml_backtest(
  features_list = X, labels = Y,
  fit_fn = xgb_g$fit, predict_fn = xgb_g$predict,
  schedule = list(is = 104L, oos = 4L, step = 4L),
  group = "per_group", group_map = gmap,   # sector-neutral training
  transform = "zscore",
  selection = list(top_k = 15L),
  weighting = list(method = "softmax", temperature = 12),
  prices = sample_prices_weekly,
  initial_capital = 1e5,
  name = "XGBoost (per-sector neutral)"
)

print(res_xgb_sect$backtest)
plot(res_xgb_sect$backtest, type = "performance")

## ----seq_gru_pooled, eval=run_seq---------------------------------------------
# tf_autograph_scope()  # isolate TF Autograph cache to avoid detritus NOTE
# 
# # Build a compact 'returns pyramid' of momentum-like sequences (lagged)
# r1  <- panel_lag(calc_momentum(sample_prices_weekly,  1L), 1L)
# r4  <- panel_lag(calc_momentum(sample_prices_weekly,  4L), 1L)
# r12 <- panel_lag(calc_momentum(sample_prices_weekly, 12L), 1L)
# 
# features_seq <- list(r1 = r1, r4 = r4, r12 = r12)
# Y_seq <- make_labels(sample_prices_weekly, horizon = 4L, type = "log")
# 
# units  <- if (heavy) 32L else 8L
# epochs <- if (heavy) 12L else 4L
# 
# seq_gru <- ml_make_seq_model(
#   "gru",
#   steps  = 26L,
#   units  = units,
#   epochs = epochs,
#   seed   = 42L
# )
# 
# set.seed(42)
# res_seq_gru <- ml_backtest_seq(
#   features_list   = features_seq,
#   labels          = Y_seq,
#   steps           = 26L,
#   horizon         = 4L,
#   fit_fn          = seq_gru$fit,
#   predict_fn      = seq_gru$predict,
#   schedule        = list(is = 104L, oos = 4L, step = 4L),
#   group           = "pooled",
#   normalize       = "zscore",
#   selection       = list(top_k = 10L),
#   weighting       = list(method = "softmax", temperature = 12),
#   prices          = sample_prices_weekly,
#   initial_capital = 1e5,
#   name            = "Seq-GRU (pooled): returns pyramid (26x3)"
# )
# 
# print(res_seq_gru$backtest)
# plot(res_seq_gru$backtest, type = "performance")

## ----seq_gru_per_group, eval=run_seq------------------------------------------
# tf_autograph_scope()  # isolate TF Autograph cache for this chunk too
# 
# symbols <- setdiff(names(sample_prices_weekly), "Date")
# gmap    <- demo_sector_map(symbols, n_groups = 4L)
# 
# units_g  <- if (heavy) 32L else 8L
# epochs_g <- if (heavy) 12L else 4L
# 
# seq_gru_g <- ml_make_seq_model(
#   "gru",
#   steps  = 26L,
#   units  = units_g,
#   epochs = epochs_g,
#   seed   = 123L
# )
# 
# set.seed(123)
# res_seq_gru_g <- ml_backtest_seq(
#   features_list   = features_seq,
#   labels          = Y_seq,
#   steps           = 26L,
#   horizon         = 4L,
#   fit_fn          = seq_gru_g$fit,
#   predict_fn      = seq_gru_g$predict,
#   schedule        = list(is = 104L, oos = 4L, step = 4L),
#   group           = "per_group", group_map = gmap,
#   normalize       = "zscore",
#   selection       = list(top_k = 10L),
#   weighting       = list(method = "softmax", temperature = 12),
#   prices          = sample_prices_weekly,
#   initial_capital = 1e5,
#   name            = "Seq-GRU (per-sector neutral): returns pyramid (26x3)"
# )
# 
# print(res_seq_gru_g$backtest)
# plot(res_seq_gru_g$backtest, type = "performance")

## ----light_tuning, eval=heavy-------------------------------------------------
# topk_vals <- c(8L, 10L, 12L, 15L)
# temp_vals <- c(8, 12, 16)
# 
# score_tbl <- tune_ml_backtest(
#     features_list = X, labels = Y, prices = sample_prices_weekly,
#     fit_fn = ridge$fit, predict_fn = ridge$predict,
#     schedule = list(is = 104L, oos = 4L, step = 4L),
#     grid = list(
#         top_k = topk_vals,
#         temperature = temp_vals,
#         method = "softmax",
#         transform = "zscore"
#     )
# )
# 
# score_tbl[order(-sharpe)][1:10]

## ----tf_cleanup, include=FALSE------------------------------------------------
# Best-effort cleanup of TensorFlow Autograph cache files that can trigger
# "detritus in the temp directory" NOTE
try(unlink(Sys.glob(file.path(tempdir(), "__autograph_generated_file*.py")), force = TRUE), silent = TRUE)
try(unlink(file.path(tempdir(), "__pycache__"), recursive = TRUE, force = TRUE), silent = TRUE)

## ----session------------------------------------------------------------------
sessionInfo()