inst/doc/quickstart.R

In cramR: Cram Method for Efficient Simultaneous Learning and Evaluation

## ----setup, include = FALSE-----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
knitr::opts_chunk$set(
  collapse = TRUE,
  comment = "#>"
)
options(pkgdown.max_print = Inf, width = 1000)
library(cramR)
library(data.table)
library(glmnet)
library(caret)

## -------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
generate_data <- function(n) {
  X <- data.table(
    binary = rbinom(n, 1, 0.5),
    discrete = sample(1:5, n, replace = TRUE),
    continuous = rnorm(n)
  )
  D <- rbinom(n, 1, 0.5)
  treatment_effect <- ifelse(X$binary == 1 & X$discrete <= 2, 1,
                       ifelse(X$binary == 0 & X$discrete >= 4, -1, 0.1))
  Y <- D * (treatment_effect + rnorm(n)) + (1 - D) * rnorm(n)
  list(X = X, D = D, Y = Y)
}

set.seed(123)
data <- generate_data(1000)
X <- data$X; D <- data$D; Y <- data$Y

## -------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
res <- cram_policy(
  X, D, Y,
  batch = 20,
  model_type = "causal_forest",
  learner_type = NULL,
  baseline_policy = as.list(rep(0, nrow(X))),
  alpha = 0.05
)
print(res)

## -------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
custom_fit <- function(X, Y, D, n_folds = 5) {
  treated <- which(D == 1); control <- which(D == 0)
  m1 <- cv.glmnet(as.matrix(X[treated, ]), Y[treated], alpha = 0, nfolds = n_folds)
  m0 <- cv.glmnet(as.matrix(X[control, ]), Y[control], alpha = 0, nfolds = n_folds)
  tau1 <- predict(m1, as.matrix(X[control, ]), s = "lambda.min") - Y[control]
  tau0 <- Y[treated] - predict(m0, as.matrix(X[treated, ]), s = "lambda.min")
  tau <- c(tau0, tau1); X_all <- rbind(X[treated, ], X[control, ])
  final_model <- cv.glmnet(as.matrix(X_all), tau, alpha = 0)
  final_model
}

custom_predict <- function(model, X, D) {
  as.numeric(predict(model, as.matrix(X), s = "lambda.min") > 0)
}

res <- cram_policy(
  X, D, Y,
  batch = 20,
  model_type = NULL,
  custom_fit = custom_fit,
  custom_predict = custom_predict
)
print(res)

## -------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
set.seed(42)
data_df <- data.frame(
  x1 = rnorm(100), x2 = rnorm(100), x3 = rnorm(100), Y = rnorm(100)
)

caret_params <- list(
  method = "lm",
  trControl = trainControl(method = "none")
)

res <- cram_ml(
  data = data_df,
  formula = Y ~ .,
  batch = 5,
  loss_name = "se",
  caret_params = caret_params
)
print(res)

## ----eval = requireNamespace("randomForest", quietly = TRUE)--------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
set.seed(42)

# Generate binary classification dataset
X_data <- data.frame(x1 = rnorm(100), x2 = rnorm(100), x3 = rnorm(100))
Y_data <- rbinom(nrow(X_data), 1, 0.5)
data_df <- data.frame(X_data, Y = Y_data)

# Define caret parameters: predict labels (default behavior)
caret_params_rf <- list(
  method = "rf",
  trControl = trainControl(method = "none")
)

# Run CRAM ML with accuracy as loss
result <- cram_ml(
  data = data_df,
  formula = Y ~ .,
  batch = 5,
  loss_name = "accuracy",
  caret_params = caret_params_rf,
  classify = TRUE
)

print(result)

## ----eval = requireNamespace("randomForest", quietly = TRUE)--------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
set.seed(42)

# Generate binary classification dataset
X_data <- data.frame(x1 = rnorm(100), x2 = rnorm(100), x3 = rnorm(100))
Y_data <- rbinom(nrow(X_data), 1, 0.5)
data_df <- data.frame(X_data, Y = Y_data)

# Define caret parameters for probability output
caret_params_rf_probs <- list(
  method = "rf",
  trControl = trainControl(method = "none", classProbs = TRUE)
)

# Run CRAM ML with logloss as the evaluation loss
result <- cram_ml(
  data = data_df,
  formula = Y ~ .,
  batch = 5,
  loss_name = "logloss",
  caret_params = caret_params_rf_probs,
  classify = TRUE
)

print(result)

## -------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
set.seed(42)
T <- 100; K <- 4
pi <- array(runif(T * T * K, 0.1, 1), dim = c(T, T, K))
for (t in 1:T) for (j in 1:T) pi[j, t, ] <- pi[j, t, ] / sum(pi[j, t, ])
arm <- sample(1:K, T, replace = TRUE)
reward <- rnorm(T, 1, 0.5)

res <- cram_bandit(pi, arm, reward, batch=1, alpha=0.05)
print(res)

## ----cleanup-autograph, include=FALSE-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
autograph_files <- list.files(tempdir(), pattern = "^__autograph_generated_file.*\\.py$", full.names = TRUE)
if (length(autograph_files) > 0) {
  try(unlink(autograph_files, recursive = TRUE, force = TRUE), silent = TRUE)
}