R/sanitize_shape.R

In vincentarelbundock/gtsummary: Summary Tables and Plots for Statistical Models and Data: Beautiful, Customizable, and Publication-Ready

#' sanity check
#'
#' @noRd
sanitize_shape <- function(shape) {

    if (is.null(shape)) {
        shape <- term + statistic ~ model
    }

    checkmate::assert(
        checkmate::check_null(shape),
        checkmate::check_formula(shape),
        checkmate::check_choice(shape, choices = c("cbind", "rbind", "rcollapse"))
    )

    # interactions with ":" are used to combine columns
    shape_cha <- deparse(shape)
    if (isTRUE(grepl("\\*|\\(", shape_cha))) {
        stop("The * and () characters are not supported in the `shape` formula.", call. = FALSE)
    }
    regex <- "\\b\\w+:\\w+\\b"
    combine <- unlist(regmatches(shape_cha, gregexpr(regex, shape_cha)))

    # remove interactions from the formula since we are going to combine them in get_estimates
    for (com in combine) {
        shape_cha <- gsub(com, gsub(":.*", "", com), shape_cha, fixed = TRUE)
    }
    shape <- stats::as.formula(shape_cha)


    lhs <- all.vars(stats::update(shape, ". ~ NULL"))
    rhs <- all.vars(stats::update(shape, "NULL ~ ."))
    lhs <- setdiff(lhs, ".")
    rhs <- setdiff(rhs, ".")
    variables <- all.vars(shape)
    shape_formula <- shape
    group_name <- setdiff(all.vars(shape_formula), c("term", "model", "statistic"))

    if (length(group_name) == 0) {
        group_name <- NULL
    }

    # partial formulas
    if (!"term" %in% variables && !"statistic" %in% variables) {
        lhs <- c("term", lhs, "statistic")
    } else if (!"statistic" %in% variables) {
        lhs <- c(lhs, "statistic")
    } else if (!"term" %in% variables) {
        lhs <- c("term", lhs)
    }
    if (!"model" %in% variables) {
        rhs <- c("model", rhs)
    }

    shape_formula <- stats::as.formula(
        paste(paste(lhs, collapse = "+"),
              "~",
              paste(rhs, collapse = "+")))

    out <- list(
        "lhs" = lhs,
        "rhs" = rhs,
        "group_name" = group_name,
        "shape_formula" = shape_formula,
        "combine" = combine
    )

    return(out)
}