R/utils.R

In ERRI: Economic Resilience and Recovery Index

.erri_stop <- function(..., call. = FALSE) {
    stop(..., call. = call.)
}

.as_time_numeric <- function(x) {
    if (inherits(x, "Date") || inherits(x, "POSIXt")) {
        return(as.numeric(x))
    }
    if (is.numeric(x) || is.integer(x)) {
        return(as.numeric(x))
    }
    z <- suppressWarnings(as.numeric(as.character(x)))
    if (anyNA(z)) z <- seq_along(x)
    z
}

.match_shock <- function(time, shock_time) {
    if (length(shock_time) != 1L || is.na(shock_time)) {
        .erri_stop("'shock_time' must be one non-missing value per series.")
    }
    exact <- which(time == shock_time)
    if (length(exact)) return(exact[1L])
    tn <- .as_time_numeric(time)
    sn <- .as_time_numeric(shock_time)[1L]
    idx <- which.min(abs(tn - sn))
    if (!length(idx) || is.na(idx)) .erri_stop("Could not match 'shock_time'.")
    idx
}

.scale_value <- function(y, method) {
    method <- match.arg(method, c("sd", "mean", "none"))
    if (method == "sd") out <- stats::sd(y, na.rm = TRUE)
    if (method == "mean") out <- abs(mean(y, na.rm = TRUE))
    if (method == "none") out <- 1
    if (!is.finite(out) || out <= sqrt(.Machine$double.eps)) out <- 1
    out
}

.validate_weights <- function(weights) {
    nm <- c("resistance", "loss", "recovery", "strength",
            "stability", "transformation")
    if (is.null(weights)) {
        weights <- rep(1 / length(nm), length(nm))
        names(weights) <- nm
        return(weights)
    }
    if (is.null(names(weights)) || !all(nm %in% names(weights))) {
        .erri_stop("'weights' must be a named numeric vector containing: ",
                   paste(nm, collapse = ", "), ".")
    }
    weights <- as.numeric(weights[nm])
    names(weights) <- nm
    if (any(!is.finite(weights)) || any(weights < 0) || sum(weights) <= 0) {
        .erri_stop("Weights must be finite, non-negative, and sum to more than zero.")
    }
    weights / sum(weights)
}

.minmax <- function(x, benefit = TRUE) {
    ok <- is.finite(x)
    out <- rep(NA_real_, length(x))
    if (!any(ok)) return(out)
    r <- range(x[ok])
    if (diff(r) <= sqrt(.Machine$double.eps)) {
        out[ok] <- 0.5
    } else {
        out[ok] <- (x[ok] - r[1L]) / diff(r)
    }
    if (!benefit) out[ok] <- 1 - out[ok]
    out
}

.component_scores <- function(tab) {
    n <- nrow(tab)
    if (n > 1L) {
        data.frame(
            resistance = .minmax(tab$shock_depth, FALSE),
            loss = .minmax(tab$cumulative_loss, FALSE),
            recovery = .minmax(tab$recovery_time, FALSE),
            strength = .minmax(tab$recovery_strength, TRUE),
            stability = .minmax(tab$stability_ratio, FALSE),
            transformation = .minmax(tab$transformation, TRUE),
            check.names = FALSE
        )
    } else {
        # Absolute bounded scores permit a meaningful one-series index.
        data.frame(
            resistance = exp(-pmax(tab$shock_depth, 0)),
            loss = exp(-pmax(tab$cumulative_loss, 0)),
            recovery = 1 / (1 + pmax(tab$recovery_time, 0)),
            strength = 1 - exp(-pmax(tab$recovery_strength, 0)),
            stability = exp(-pmax(tab$stability_ratio, 0)),
            transformation = stats::plogis(tab$transformation),
            check.names = FALSE
        )
    }
}

.run_recovery <- function(gap, epsilon, consecutive) {
    if (length(gap) < consecutive) return(NA_integer_)
    inside <- abs(gap) <= epsilon
    inside[is.na(inside)] <- FALSE
    hit <- stats::filter(as.integer(inside), rep(1, consecutive),
                         sides = 1)
    k <- which(hit >= consecutive)[1L]
    if (is.na(k)) NA_integer_ else as.integer(k - consecutive)
}