R/shoot_derived.R

In texanshootR: Reproducible Audit Trails for Indefensible Research

# Derived-metric escalation: composite-response constructors.
#
# Triggered when the main search produces no spec with p <= 0.05 and
# the run is still within budget. Each constructor builds a new
# outcome column derived from existing inputs in a way that injects
# structural dependence with the predictors. The package treats these
# as "advanced interpretability transformations" and reports the
# resulting spec faithfully.

derived_constructors <- list(

  derive_per_unit = function(df, response, candidates) {
    denom <- pick_numeric(df, candidates, response)
    if (is.null(denom)) return(NULL)
    new_y <- df[[response]] / df[[denom]]
    list(name = "per_unit",
         expr = sprintf("%s / %s", response, denom),
         denom = denom,
         numerator = response,
         y = new_y)
  },

  derive_density = function(df, response, candidates) {
    area_var <- pick_by_name(df, candidates, c("area", "extent", "size", "patch"))
    if (is.null(area_var)) return(NULL)
    new_y <- df[[response]] / df[[area_var]]
    list(name = "density",
         expr = sprintf("%s / %s", response, area_var),
         denom = area_var,
         numerator = response,
         y = new_y)
  },

  derive_effort_adjusted = function(df, response, candidates) {
    eff <- pick_by_name(df, candidates,
                        c("effort", "sampling", "duration", "time"))
    if (is.null(eff)) return(NULL)
    new_y <- df[[response]] / df[[eff]]
    list(name = "effort_adjusted",
         expr = sprintf("%s / %s", response, eff),
         denom = eff,
         numerator = response,
         y = new_y)
  },

  derive_log_index = function(df, response, candidates) {
    scale_var <- pick_numeric(df, candidates, response)
    if (is.null(scale_var)) return(NULL)
    if (any(df[[response]] <= 0, na.rm = TRUE)) return(NULL)
    if (any(df[[scale_var]] <= 0, na.rm = TRUE)) return(NULL)
    new_y <- log(df[[response]]) / log(df[[scale_var]])
    list(name = "log_index",
         expr = sprintf("log(%s) / log(%s)", response, scale_var),
         denom = scale_var,
         numerator = response,
         y = new_y)
  }
)

pick_numeric <- function(df, candidates, exclude) {
  pool <- setdiff(candidates, exclude)
  pool <- pool[vapply(pool, function(v) {
    is.numeric(df[[v]]) && all(df[[v]] != 0, na.rm = TRUE)
  }, logical(1))]
  if (length(pool) == 0L) NULL else pool[1]
}

pick_by_name <- function(df, candidates, hints) {
  pool <- setdiff(candidates, character())
  pool <- pool[vapply(pool, function(v) is.numeric(df[[v]]), logical(1))]
  for (h in hints) {
    hit <- pool[grepl(h, pool, ignore.case = TRUE)]
    if (length(hit)) return(hit[1])
  }
  NULL
}

# Apply a derived constructor to df: replaces the response column
# with the new outcome and returns the modified df + spec metadata.
apply_derived <- function(df, response, predictors, max_attempts = 3L) {
  for (fn_name in names(derived_constructors)) {
    fn <- derived_constructors[[fn_name]]
    out <- fn(df, response, predictors)
    if (is.null(out)) next
    if (!all(is.finite(out$y))) next
    new_df <- df
    new_df[[response]] <- out$y
    return(list(df = new_df, info = out))
  }
  NULL
}