|
| 1 | +##============================================================================= |
| 2 | +#' Variable importance data from a varPro model |
| 3 | +#' |
| 4 | +#' Extracts per-tree importance scores from a fitted \code{varpro} object, |
| 5 | +#' summarises them into an honest boxplot-ready data structure (hinges at |
| 6 | +#' 15th/85th percentile, whiskers at 5th/95th), and optionally retains |
| 7 | +#' class-conditional importance for classification forests. |
| 8 | +#' |
| 9 | +#' @param object A fitted \code{varpro} object (required). |
| 10 | +#' @param local.std Logical; default \code{TRUE}. When \code{TRUE} the |
| 11 | +#' per-tree importances are normalised to z-scale before computing box |
| 12 | +#' statistics. Set to \code{FALSE} to retain the raw importance scale |
| 13 | +#' (required for \code{type = "raw"} in \code{plot.gg_varpro}). |
| 14 | +#' @param cutoff Numeric z-score threshold for variable selection; default |
| 15 | +#' \code{0.79}. Variables with aggregate z > cutoff are flagged |
| 16 | +#' \code{selected = TRUE} in \code{$imp}. |
| 17 | +#' @param faithful Logical; default \code{FALSE}. When \code{TRUE}, |
| 18 | +#' \code{$imp.tree} is retained so \code{plot.gg_varpro} can |
| 19 | +#' overlay per-tree jitter points in \code{plot.gg_varpro}. |
| 20 | +#' @param conditional Logical; default \code{FALSE}. When \code{TRUE} |
| 21 | +#' (classification forests only) extracts the \code{$conditional.z} |
| 22 | +#' matrix and stores it as \code{$conditional}. |
| 23 | +#' @param nvar Integer; retain only the top \code{nvar} variables (by |
| 24 | +#' median per-tree z) after applying the cutoff filter. \code{NULL} keeps all. |
| 25 | +#' @param ... Additional arguments passed to \code{varPro::importance()}. |
| 26 | +#' |
| 27 | +#' @return A named list of class \code{"gg_varpro"} with elements: |
| 28 | +#' \describe{ |
| 29 | +#' \item{\code{$imp}}{Summary data frame: \code{variable} (factor with |
| 30 | +#' levels ordered by descending median per-tree z), \code{z} (aggregate |
| 31 | +#' z-score from \code{importance()}), \code{selected} (logical, |
| 32 | +#' \code{z > cutoff}).} |
| 33 | +#' \item{\code{$imp.tree}}{\code{NULL} when \code{faithful = FALSE}; |
| 34 | +#' otherwise an ntree x p matrix of per-tree importance values.} |
| 35 | +#' \item{\code{$stats}}{Per-variable summary: \code{variable}, |
| 36 | +#' \code{median}, \code{q05}, \code{q15}, \code{q85}, \code{q95} |
| 37 | +#' (on z-scale when \code{local.std = TRUE}, raw when \code{FALSE}), |
| 38 | +#' plus \code{mean} (raw importance mean, always stored).} |
| 39 | +#' \item{\code{$conditional}}{\code{NULL} when \code{conditional = FALSE}; |
| 40 | +#' otherwise a data frame with columns \code{variable}, \code{class}, |
| 41 | +#' \code{z} (one row per variable x class combination).} |
| 42 | +#' } |
| 43 | +#' A \code{"provenance"} attribute carries \code{family}, \code{local.std}, |
| 44 | +#' \code{cutoff}, \code{faithful}, \code{conditional}, \code{xvar.names}, |
| 45 | +#' and \code{n}. |
| 46 | +#' |
| 47 | +#' @seealso \code{\link{plot.gg_varpro}}, \code{\link{gg_vimp}} |
| 48 | +#' |
| 49 | +#' @examples |
| 50 | +#' \donttest{ |
| 51 | +#' set.seed(42) |
| 52 | +#' vp <- varPro::varpro(mpg ~ ., data = mtcars, ntree = 50) |
| 53 | +#' gg <- gg_varpro(vp) |
| 54 | +#' print(gg) |
| 55 | +#' plot(gg) |
| 56 | +#' } |
| 57 | +#' |
| 58 | +#' @importFrom varPro importance |
| 59 | +#' @export |
| 60 | +gg_varpro <- function(object, |
| 61 | + local.std = TRUE, |
| 62 | + cutoff = 0.79, |
| 63 | + faithful = FALSE, |
| 64 | + conditional = FALSE, |
| 65 | + nvar = NULL, |
| 66 | + ...) { |
| 67 | + |
| 68 | + ## ---- Validation + coercion ------------------------------------------------ |
| 69 | + local.std <- .validate_varpro_imp_inputs(object, local.std, faithful, conditional) |
| 70 | + |
| 71 | + ## ---- Call importance (local.std=FALSE gives mean & std columns) ----------- |
| 72 | + imp_out <- varPro::importance(object, local.std = FALSE, ...) |
| 73 | + |
| 74 | + ## ---- Build per-tree importance matrix from object$results ----------------- |
| 75 | + imp_tree_mat <- .build_varpro_imp_tree(object) |
| 76 | + |
| 77 | + ## ---- Build tidy data structures ------------------------------------------ |
| 78 | + dfs <- .build_varpro_imp_dfs(imp_out, imp_tree_mat, object$family, |
| 79 | + cutoff, nvar, faithful, local.std, conditional) |
| 80 | + |
| 81 | + ## ---- Assemble result ------------------------------------------------------ |
| 82 | + result <- structure( |
| 83 | + list( |
| 84 | + imp = dfs$imp, |
| 85 | + imp.tree = dfs$imp_tree, |
| 86 | + stats = dfs$stats, |
| 87 | + conditional = dfs$conditional |
| 88 | + ), |
| 89 | + class = c("gg_varpro", "list") |
| 90 | + ) |
| 91 | + |
| 92 | + attr(result, "provenance") <- list( |
| 93 | + family = object$family, |
| 94 | + local.std = local.std, # resolved value (may differ from arg when faithful=TRUE) |
| 95 | + cutoff = cutoff, |
| 96 | + faithful = faithful, |
| 97 | + conditional = conditional, |
| 98 | + xvar.names = object$xvar.names, |
| 99 | + n = nrow(object$x) |
| 100 | + ) |
| 101 | + |
| 102 | + result |
| 103 | +} |
| 104 | + |
| 105 | +## ---- Internal helpers ------------------------------------------------------- |
| 106 | + |
| 107 | +#' @keywords internal |
| 108 | +.validate_varpro_imp_inputs <- function(object, local.std, faithful, conditional) { |
| 109 | + if (missing(object) || is.null(object)) { |
| 110 | + stop("'object' must be a fitted varpro object.", call. = FALSE) |
| 111 | + } |
| 112 | + if (!inherits(object, "varpro")) { |
| 113 | + stop("'object' must be a varpro fit (class \"varpro\").", call. = FALSE) |
| 114 | + } |
| 115 | + if (conditional && !identical(object$family, "class")) { |
| 116 | + stop("conditional=TRUE requires a classification forest ", |
| 117 | + "(object$family == \"class\").", call. = FALSE) |
| 118 | + } |
| 119 | + invisible(local.std) |
| 120 | +} |
| 121 | + |
| 122 | +#' Build per-tree importance matrix from varpro object results |
| 123 | +#' |
| 124 | +#' Reconstructs the ntree x p per-tree importance matrix from |
| 125 | +#' \code{object$results}, replicating the aggregation performed internally |
| 126 | +#' by \code{varPro:::.importance.varpro.workhorse}. |
| 127 | +#' @keywords internal |
| 128 | +.build_varpro_imp_tree <- function(object) { |
| 129 | + dta <- object$results |
| 130 | + xvar.names <- object$xvar.names |
| 131 | + |
| 132 | + dta$variable <- factor(xvar.names[dta$variable]) |
| 133 | + xvarused.names <- levels(dta$variable) |
| 134 | + p <- length(xvarused.names) |
| 135 | + wt.vec <- rep(1, p) |
| 136 | + names(wt.vec) <- xvarused.names |
| 137 | + |
| 138 | + trees <- sort(unique(dta$tree)) |
| 139 | + ntree.used <- length(trees) |
| 140 | + tree.idx <- match(dta$tree, trees) |
| 141 | + var.idx <- match(as.character(dta$variable), xvarused.names) |
| 142 | + grp <- tree.idx + (var.idx - 1L) * ntree.used |
| 143 | + |
| 144 | + w <- dta$n.oob |
| 145 | + numer <- dta$imp * w |
| 146 | + numer[is.na(numer)] <- 0 |
| 147 | + numer.sum <- rowsum(numer, grp, reorder = FALSE) |
| 148 | + denom.sum <- rowsum(w, grp, reorder = FALSE) |
| 149 | + ratio <- as.numeric(numer.sum[, 1L] / denom.sum[, 1L]) |
| 150 | + ratio[!is.finite(ratio)] <- 0 |
| 151 | + |
| 152 | + imp_tree <- matrix(0, nrow = ntree.used, ncol = p, |
| 153 | + dimnames = list(as.character(trees), xvarused.names)) |
| 154 | + ## g.rows are the grp keys (1..ntree.used*p); decode back to (tree, var) indices. |
| 155 | + ## reorder=FALSE preserves insertion order but rownames() always give the |
| 156 | + ## original grp key values, so the modular decode is stable regardless of order. |
| 157 | + g.rows <- as.integer(rownames(numer.sum)) |
| 158 | + imp_tree[cbind(((g.rows - 1L) %% ntree.used) + 1L, |
| 159 | + ((g.rows - 1L) %/% ntree.used) + 1L)] <- ratio |
| 160 | + sweep(imp_tree, 2L, wt.vec, `*`) |
| 161 | +} |
| 162 | + |
| 163 | +#' Compute per-variable box statistics from a per-tree importance matrix |
| 164 | +#' |
| 165 | +#' When \code{local.std = TRUE} the columns of \code{mat} are standardised |
| 166 | +#' to unit variance before computing quantiles so that the display scale |
| 167 | +#' matches the aggregate z-score. The \code{mean} column always stores raw |
| 168 | +#' (unstandardised) column means. |
| 169 | +#' @keywords internal |
| 170 | +.varpro_imp_stats <- function(mat, local.std = TRUE) { |
| 171 | + if (local.std) { |
| 172 | + sd_j <- apply(mat, 2L, stats::sd, na.rm = TRUE) |
| 173 | + sd_j[sd_j < .Machine$double.eps] <- 1 # guard zero-variance columns |
| 174 | + # z_ij = imp_ij / sd_j so that mean(z_ij) == aggregate z_j from importance() |
| 175 | + display_mat <- sweep(mat, 2L, sd_j, FUN = "/") |
| 176 | + } else { |
| 177 | + display_mat <- mat |
| 178 | + } |
| 179 | + data.frame( |
| 180 | + variable = colnames(mat), |
| 181 | + median = apply(display_mat, 2L, stats::quantile, probs = 0.50, |
| 182 | + na.rm = TRUE), |
| 183 | + q05 = apply(display_mat, 2L, stats::quantile, probs = 0.05, |
| 184 | + na.rm = TRUE), |
| 185 | + q15 = apply(display_mat, 2L, stats::quantile, probs = 0.15, |
| 186 | + na.rm = TRUE), |
| 187 | + q85 = apply(display_mat, 2L, stats::quantile, probs = 0.85, |
| 188 | + na.rm = TRUE), |
| 189 | + q95 = apply(display_mat, 2L, stats::quantile, probs = 0.95, |
| 190 | + na.rm = TRUE), |
| 191 | + mean = colMeans(mat, na.rm = TRUE), |
| 192 | + stringsAsFactors = FALSE, |
| 193 | + row.names = NULL |
| 194 | + ) |
| 195 | +} |
| 196 | + |
| 197 | +#' Build the tidy importance data structures from importance() output |
| 198 | +#' @keywords internal |
| 199 | +.build_varpro_imp_dfs <- function(imp_out, imp_tree_mat, family, cutoff, nvar, |
| 200 | + faithful, local.std, conditional) { |
| 201 | + is_class <- identical(family, "class") |
| 202 | + |
| 203 | + ## Unpack importance() data frame — different shapes per family |
| 204 | + if (is_class && is.list(imp_out) && !is.data.frame(imp_out)) { |
| 205 | + imp_df_raw <- imp_out$unconditional |
| 206 | + cond_mat <- if (conditional) imp_out$conditional.z else NULL |
| 207 | + } else { |
| 208 | + imp_df_raw <- imp_out |
| 209 | + cond_mat <- NULL |
| 210 | + } |
| 211 | + |
| 212 | + ## Replace NaN z with 0 for sorting/selection |
| 213 | + z_vec <- imp_df_raw$z |
| 214 | + z_vec[!is.finite(z_vec)] <- 0 |
| 215 | + |
| 216 | + ## $imp: one row per variable |
| 217 | + imp_df <- data.frame( |
| 218 | + variable = rownames(imp_df_raw), |
| 219 | + z = as.numeric(z_vec), |
| 220 | + selected = as.numeric(z_vec) > cutoff, |
| 221 | + stringsAsFactors = FALSE |
| 222 | + ) |
| 223 | + |
| 224 | + ## Keep only columns present in both imp_df and imp_tree_mat |
| 225 | + keep_vars <- imp_df$variable[imp_df$variable %in% colnames(imp_tree_mat)] |
| 226 | + imp_tree_k <- imp_tree_mat[, keep_vars, drop = FALSE] |
| 227 | + |
| 228 | + ## $stats: box quantiles per variable (full set before nvar truncation) |
| 229 | + stats_df <- .varpro_imp_stats(imp_tree_k, local.std = local.std) |
| 230 | + |
| 231 | + ## Apply nvar truncation by median z (spec: "top-nvar by median z") |
| 232 | + if (!is.null(nvar)) { |
| 233 | + top_vars <- stats_df$variable[order(-stats_df$median)][ |
| 234 | + seq_len(min(nvar, nrow(stats_df)))] |
| 235 | + imp_df <- imp_df[imp_df$variable %in% top_vars, , drop = FALSE] |
| 236 | + stats_df <- stats_df[stats_df$variable %in% top_vars, , drop = FALSE] |
| 237 | + } |
| 238 | + |
| 239 | + ## Order $imp and $stats rows + factor levels by descending median z |
| 240 | + var_order <- stats_df$variable[order(-stats_df$median)] |
| 241 | + imp_df$variable <- factor(imp_df$variable, levels = var_order) |
| 242 | + stats_df$variable <- factor(stats_df$variable, levels = var_order) |
| 243 | + ## Reorder rows to match factor levels (avoids row-order / level mismatch) |
| 244 | + imp_df <- imp_df[order(imp_df$variable), , drop = FALSE] |
| 245 | + stats_df <- stats_df[order(stats_df$variable), , drop = FALSE] |
| 246 | + rownames(imp_df) <- NULL |
| 247 | + rownames(stats_df) <- NULL |
| 248 | + |
| 249 | + ## $conditional: tidy class-conditional z-scores |
| 250 | + cond_df <- NULL |
| 251 | + if (!is.null(cond_mat)) { |
| 252 | + cond_df <- data.frame( |
| 253 | + variable = rep(rownames(cond_mat), ncol(cond_mat)), |
| 254 | + class = rep(colnames(cond_mat), each = nrow(cond_mat)), |
| 255 | + z = as.vector(cond_mat), |
| 256 | + stringsAsFactors = FALSE |
| 257 | + ) |
| 258 | + cond_df <- cond_df[cond_df$variable %in% keep_vars, , drop = FALSE] |
| 259 | + cond_df$variable <- factor(cond_df$variable, |
| 260 | + levels = levels(imp_df$variable)) |
| 261 | + } |
| 262 | + |
| 263 | + list( |
| 264 | + imp = imp_df, |
| 265 | + imp_tree = if (faithful) imp_tree_k else NULL, |
| 266 | + stats = stats_df, |
| 267 | + conditional = cond_df |
| 268 | + ) |
| 269 | +} |
0 commit comments