## ----setup, include=FALSE-----------------------------------------------------
is_check_env <- nzchar(Sys.getenv("_R_CHECK_PACKAGE_NAME_"))
.vig_tmp_root <- file.path(tempdir(), "ddesonn-vig-logs")
dir.create(.vig_tmp_root, recursive = TRUE, showWarnings = FALSE)
options(DDESONN_OUTPUT_ROOT = .vig_tmp_root)
Sys.setenv(DDESONN_ARTIFACTS_ROOT = .vig_tmp_root)
knitr::opts_chunk$set(
echo = FALSE,
message = FALSE,
warning = FALSE,
dpi = 96,
fig.retina = 1,
results = "asis",
cache.path = file.path(.vig_tmp_root, "cache", "")
)
if (!requireNamespace("DDESONN", quietly = TRUE)) {
stop(
"DDESONN must be installed to build this vignette. ",
"Run: install.packages('DDESONN') (or your install flow) then rebuild vignettes.",
call. = FALSE
)
}
library(DDESONN)
# ============================================================
# VIGNETTE SAFETY SWITCH (DEFAULT OFF)
# ============================================================
build_artifacts <- FALSE && !is_check_env
.dd_out_root <- file.path(.vig_tmp_root, "DDESONN_vignette_logs")
outD <- file.path(.dd_out_root, "scenarioD_ensemble_temp")
if (isTRUE(build_artifacts)) {
dir.create(outD, recursive = TRUE, showWarnings = FALSE)
}
# ============================================================
# HTML-only styling
# Wrapped strictly in HTML output guard to avoid pandoc ??? artifacts
# ============================================================
if (knitr::is_html_output()) {
cat(knitr::asis_output("
"))
}
# ============================================================
# Helpers
# ============================================================
find_run_dir <- function(output_root, do_ensemble) {
runs_root <- file.path(
ddesonn_artifacts_root(output_root),
if (isTRUE(do_ensemble)) "EnsembleRuns" else "SingleRuns"
)
if (!dir.exists(runs_root)) return(NULL)
dirs <- list.dirs(runs_root, recursive = FALSE, full.names = TRUE)
if (!length(dirs)) return(NULL)
dirs[order(file.info(dirs)$mtime, decreasing = TRUE)][1]
}
show_log_table <- function(log_df, title, n_show = 10L, key_cols = character()) {
if (!knitr::is_html_output()) return(invisible(NULL))
cat(knitr::asis_output(sprintf(
"
%s
", title
)))
if (!is.data.frame(log_df) || !NROW(log_df)) {
cat(knitr::asis_output("(no rows)
"))
return(invisible(NULL))
}
df <- utils::head(log_df, n_show)
if (length(key_cols)) {
keep <- intersect(key_cols, names(df))
if (length(keep)) df <- df[, keep, drop = FALSE]
}
if ("message" %in% names(df)) {
df$message <- gsub("[\r\n\t]+", " ", df$message)
}
tab <- knitr::kable(df, format = "html", escape = TRUE)
cat(knitr::asis_output(paste0("", tab, "
")))
}
## ----data-prep----------------------------------------------------------------
set.seed(111)
ext_dir <- system.file("extdata", package = "DDESONN")
hf_path <- file.path(ext_dir, "heart_failure_clinical_records.csv")
df <- read.csv(hf_path)
y_all <- matrix(as.integer(df$DEATH_EVENT), ncol = 1)
x_all <- as.matrix(df[, setdiff(names(df), "DEATH_EVENT")])
storage.mode(x_all) <- "double"
n <- nrow(x_all)
idx <- sample.int(n)
n_train <- floor(0.70 * n)
n_valid <- floor(0.15 * n)
i_tr <- idx[1:n_train]
i_va <- idx[(n_train + 1):(n_train + n_valid)]
i_te <- idx[(n_train + n_valid + 1):n]
x_train <- scale(x_all[i_tr, ])
y_train <- y_all[i_tr, ]
x_valid <- scale(x_all[i_va, ])
y_valid <- y_all[i_va, ]
x_test <- scale(x_all[i_te, ])
y_test <- y_all[i_te, ]
## ----scenario-d-run-----------------------------------------------------------
res_D <- ddesonn_run(
x = x_train,
y = y_train,
classification_mode = "binary",
hidden_sizes = c(64, 32),
seeds = 1L,
do_ensemble = TRUE,
num_networks = 2L,
num_temp_iterations = 2L,
validation = list(x = x_valid, y = y_valid),
test = list(x = x_test, y = y_test),
training_overrides = list(
init_method = "he",
optimizer = "adagrad",
lr = 0.125,
lambda = 0.00028,
activation_functions = list(relu, relu, sigmoid),
dropout_rates = list(0.10),
loss_type = "CrossEntropy",
validation_metrics = TRUE,
num_epochs = 360,
final_summary_decimals = 6L
),
output_root = if (isTRUE(build_artifacts)) outD else NULL
)
logs_D <- res_D$runs[[1]]$tables
main_cols <- c("serial","iteration","epoch","phase","metric_name","metric_value","message","timestamp")
movement_cols <- c("serial","iteration","epoch","param_name","from","to","delta","message","timestamp")
change_cols <- c("serial","iteration","epoch","layer","target","param_name","grad_norm","update_norm","message","timestamp")
## ----scenario-d-display-------------------------------------------------------
show_log_table(logs_D$main_log, "Scenario D - Main Log", key_cols = main_cols)
show_log_table(logs_D$movement_log, "Scenario D - Movement Log", key_cols = movement_cols)
show_log_table(logs_D$change_log, "Scenario D - Change Log", key_cols = change_cols)
if (knitr::is_html_output()) {
cat(knitr::asis_output("
Note: Tables below are preview-capped for vignette readability.
Full tables remain available in res_D$runs[[1]]$tables.
Artifact writing is OFF by default for CRAN-safety.
"))
}