R/backtransform.R

In marginaleffects: Predictions, Comparisons, Slopes, Marginal Means, and Hypothesis Tests

backtransform <- function(x, transform, draws = NULL) {
    # transform can be a function or a named list of length 1 with a function, but could be NULL
    if (!is.function(transform)) {
        if (is.null(transform[[1]])) {
            return(x)
        }

        transform <- transform[[1]]
    }

    checkmate::assert_data_frame(x)
    checkmate::assert_function(transform)
    cols <- intersect(colnames(x), c("estimate", "conf.low", "conf.high"))

    if (!is.null(draws)) {
        dim_pre <- dim(draws)
        draws <- transform(draws)
        dim_post <- dim(draws)
        if (!identical(dim_pre, dim_post)) {
            stop_sprintf(
                "The `transform` function must return an object of the same class as its input: a matrix input must return a matrix of the same size, and a vector input must return a vector of the same length."
            )
        }
    }

    for (col in cols) {
        out <- transform(x[[col]])
        if (!is.numeric(out) || length(out) != length(x[[col]])) {
            stop_sprintf(
                "The `transform` function must return a numeric vector of the same length as its input (received %s of length %s for a `%s` column of length %s).",
                class(out)[1],
                length(out),
                col,
                length(x[[col]])
            )
        }
        x[[col]] <- out
    }

    # Issue #1204: Some inverse link functions swap the order of low and high.
    # `which()` skips NaN bounds (e.g. `log` of a negative bound) instead of
    # crashing on an `NA` inside `if()`.
    if (all(c("conf.low", "conf.high") %in% colnames(x))) {
        idx <- which(x$conf.high < x$conf.low)
        if (length(idx) > 0) {
            lo <- x[["conf.low"]][idx]
            x[["conf.low"]][idx] <- x[["conf.high"]][idx]
            x[["conf.high"]][idx] <- lo
        }
    }

    for (col in c("std.error", "statistic")) {
        x[[col]] <- NULL
    }

    attr(x, "posterior_draws") <- draws

    return(x)
}