R/printCrudeAndAdjustedModel.R

In gforge/Greg: Regression Helper Functions

#' Output crude and adjusted model data
#'
#' Prints table for a fitted object. It prints by default a latex table but can
#' also be converted into a HTML table that should be more compatible with common
#' word processors. For details run \code{vignette("printCrudeAndAdjustedModel")}
#'
#' @section Warning:
#' If you call this function and you've changed any of the variables
#' used in the original call, i.e. the premises are changed, this function will not
#' remember the original values and the statistics will be faulty!
#'
#' @param model A regression model fit, i.e. the returned object from your
#'  regression function, or the output from \code{\link{getCrudeAndAdjustedModelData}()}
#' @param order A vector with regular expressions for each group, use if youe
#'  want to reorder the groups in another way than what you've used in your original
#'  function. You can also use this in order to skip certain variables from the output.
#' @param digits The number of digits to round to
#' @param ci_lim A limit vector number that specifies if any values should be
#'  abbreviated above or below this value, for instance a value of 1000
#'  would give a value of \code{> -1000} for a value of 1001. This gives
#'  a prettier table when you have very wide confidence intervals.
#' @param sprintf_ci_str A string according to \code{\link{sprintf}()} to
#'  write the confidence interval where the first \%s is the lower and
#'  the second the upper. You can choose to set this through setting the option
#'  \code{sprintf_ci_str}, e.g. \code{options(sprintf_ci_str = "\%s - \%s")}.
#' @param add_references True if it should use the data set to look for
#'  references, otherwise supply the function with a vector with names.
#'  Sometimes you want to indicate the reference row for each group.
#'  This needs to be just as many as the  groups as the order identified.
#'  Use NA if you don't want to have a reference for that particular group.
#' @param add_references_pos The position where a reference should be added.
#'  Sometimes you don't want the reference to be at the top, for instance
#'  if you have age groups then you may have < 25, 25-39, 40-55, > 55 and
#'  you have the reference to be 25-39 then you should set the reference
#'  list for \code{age_groups} as \code{add_references_pos = list(age_groups = 2)}
#'  so that you have the second group as the position for the reference.
#' @param reference_zero_effect Used with references, tells if zero effect
#'  is in exponential form, i.e. \code{exp(0) = 1}, or in regular format,
#'  i.e. \code{0 = 0} (can be set to any value)
#' @param groups If you wish to have other than the default \code{rgroup} names
#'  for the grouping parameter
#' @param rowname.fn A function that takes a row name and sees if it needs
#'  beautifying. The function has only one parameter the coefficients name and
#'  should return a string or expression.
#' @param use_labels If the rowname.fn function doesn't change the name then
#'  the label should be used instead of the name, that is if there is a
#'  label and it isn't a factor.
#' @param desc_column Add descriptive column to the crude and adjusted table
#' @param desc_args The description arguments that are to be used for the
#'  the description columns. The options/arguments should be generated by the
#'  \code{\link{caDescribeOpts}} function.
#' @param impute_args A list with additional arguments if the provided input is
#'  a imputed object. Currently the list options \code{coef_change} and
#'  \code{variance.inflation} are supported. If you want both columns then
#'  the simplest way is to provide the list:
#'  \code{list(coef_change = TRUE, variance.inflation = TRUE)}.
#'  The \code{coef_change} adds a column with the change in coefficients due to
#'  the imputation, the the "raw" model is subtracted from the imputed results.
#'  The "raw" model is the unimputed model, \code{coef(imputed_model) - coef(raw_model)}.
#'  The \code{variance.inflation} adds the \code{variance.inflation.impute} from the
#'  \code{\link[Hmisc:transcan]{fit.mult.impute}()} to a separate column. See the description
#'  for the \code{variance.inflation.impute} in in the \code{\link[Hmisc:transcan]{fit.mult.impute}()}
#'  description.
#'  Both arguments can be customized by providing a \code{list}. The list can have
#'  the elements \code{type}, \code{name}, \code{out_str}, and/or \code{digits}.
#'  The \code{type} can for \code{coef_change}/\code{variance.impute} be either
#'  "percent" or "ratio", note that \code{variance.inflation.impute} was not
#'  originally intended to be interpreted as \%. The default for \code{coef_change} is to
#'  have "diff", that gives the absolute difference in the coefficient.
#'  The \code{name} provides the column name, the \code{out_str} should be a string
#'  that is compatible with \code{\link[base]{sprintf}()} and also contains an argument
#'  for accepting a float value, e.g. "%.0f%%" is used by default iun the coef_change
#'  column. The \code{digits} can be used if you are not using the \code{out_str}
#'  argument, it simply specifies the number of digits to show. See the example
#'  for how for a working example.
#'  \emph{Note} that currently only the \code{\link[Hmisc:transcan]{fit.mult.impute}()}
#'  is supported by this option.
#' @param ... Passed onto the Hmisc::\code{\link[Hmisc]{latex}()} function, or to
#'  the \code{\link[htmlTable]{htmlTable}()} via the \code{\link[base]{print}()} call. Any variables that match
#'  the formals of \code{\link{getCrudeAndAdjustedModelData}()} are identified
#'  and passed on in case you have provided a model and not the returned element
#'  from the \code{\link{getCrudeAndAdjustedModelData}()} call.
#'
#' @return \code{matrix} Returns a matrix of class printCrudeAndAdjusted that
#'  has a default print method associated with
#'
#' @importFrom Gmisc insertRowAndKeepAttr
#' @importFrom Gmisc fastDoCall
#' @importFrom methods setClass
#'
#' @example inst/examples/printCrudeAndAdjustedModel_example.R
#'
#' @family crudeAndAdjusted functions
#' @rdname printCrudeAndAdjustedModel
#' @export
printCrudeAndAdjustedModel <- function(model,
                                       order,
                                       digits = 2,
                                       ci_lim = c(-Inf, Inf),
                                       sprintf_ci_str = getOption("sprintf_ci_str", "%s to %s"),
                                       add_references,
                                       add_references_pos,
                                       reference_zero_effect,
                                       groups,
                                       rowname.fn,
                                       use_labels = TRUE,
                                       desc_column = FALSE,
                                       desc_args = caDescribeOpts(digits = digits),
                                       impute_args,
                                       ...) {
  dot_args <- list(...)

  if (is.null(model)) {
    stop("The model argument that you've provided is null. Expecting output from
         getCrudeAndAdjustedModelData or a plain regression model")
  }

  if (!"matrix" %in% class(model)) {
    # Convert the model that should be a model into a matrix that
    # originally was expected
    gca_args <- list(model = model)
    if (!missing(order)) {
      gca_args$var_select <- order
    }

    for (n in names(dot_args)[names(dot_args) %in%
      names(formals(getCrudeAndAdjustedModelData))]) {
      gca_args[[n]] <- dot_args[[n]]
      dot_args[[n]] <- NULL
    }

    x <- fastDoCall(getCrudeAndAdjustedModelData, gca_args)
  } else {
    x <- model
    model <- attr(model, "model")
  }
  ds <- prGetModelData(model)

  if (missing(reference_zero_effect)) {
    reference_zero_effect <- ifelse(all("lm" %in% class(model)) ||
      "ols" %in% class(model) ||
      (inherits(model, "glm") && model$family$link == "identity"), 0, 1)
  }
  if (is.numeric(reference_zero_effect)) {
    reference_zero_effect <- txtRound(reference_zero_effect, digits = digits)
  }

  # You need references if you're going to have a descriptive column
  if (missing(add_references) &&
    desc_column) {
    add_references <- TRUE
    add_references_pos <- list()
  }

  # Initialize the add_references_pos to a value if add_reference is used
  if (!missing(add_references) &&
    missing(add_references_pos)) {
    add_references_pos <- list()
  }

  if (!inherits(desc_args, "desc_list")) {
    stop("You need to use the caDescribeOpts() for the desc_args argument!")
  }

  if (!missing(impute_args) &&
    !inherits(model, "fit.mult.impute")) {
    stop(
      "You aim to use the arguments aimed for imputed results but unfortunately",
      " the provided model type that you have provided does not support this feature.",
      " The only compatible imputation is the one based upon the fit.mult.impute",
      " at this model and your model does not carry that class name:",
      " '", paste(class(model), collapse = "', '"), "'"
    )
  } else if (!missing(impute_args) &&
    any(!names(impute_args) %in% c(
      "coef_change",
      "variance.inflation"
    ))) {
    invalid_args <- names(impute_args)[!names(impute_args) %in% c(
      "coef_change",
      "variance.inflation"
    )]
    warning(
      "The imputation arguments (impute_args):",
      "'", paste(invalid_args, collapse = "', '"), "'",
      " provided are invalid and will be ignored by the function.",
      " Currently only arguments coef_change and variance.inflation",
      " are accepted."
    )
  }

  # The rms doesn't getCrudeAndAdjusted doesn't handle the intercept
  intercept <- ifelse(inherits(model, "rms"), FALSE, TRUE)
  var_names <- prGetModelVariables(
    model = model,
    add_intercept = intercept,
    remove_interaction_vars = TRUE,
    remove_splines = TRUE
  )
  var_order <-
    prMapVariable2Name(
      var_names = var_names,
      available_names = rownames(x),
      data = ds,
      force_match = FALSE
    )

  # Prettify the output
  x <- prCaPrepareCrudeAndAdjusted(
    x = x,
    ci_lim = ci_lim,
    digits = digits,
    sprintf_ci_str = sprintf_ci_str
  )

  if (!missing(order)) {
    reordered_groups <-
      prCaReorderReferenceDescribe(
        x = x,
        model = model,
        order = order,
        var_order = var_order,
        add_references = add_references,
        add_references_pos = add_references_pos,
        reference_zero_effect = reference_zero_effect,
        ds = ds,
        desc_column = desc_column,
        desc_args = desc_args,
        use_labels = use_labels
      )
  } else {
    reordered_groups <- x
    if (!missing(add_references)) {
      reordered_groups <-
        prCaAddRefAndStat(
          model = model,
          var_order = var_order,
          add_references = add_references,
          add_references_pos = add_references_pos,
          reference_zero_effect = reference_zero_effect,
          values = reordered_groups,
          ds = ds,
          desc_column = desc_column,
          desc_args = desc_args,
          use_labels = use_labels
        )
    }
  }

  # The prCaAddRefAndStat adds references and updates the
  # var_order accordingly, therefore we need to change
  # the var_order according to the reordered_groups if it exists
  if (!is.null(attr(reordered_groups, "var_order"))) {
    var_order <- attr(reordered_groups, "var_order")
    attr(reordered_groups, "var_order") <- NULL
  }

  reordered_groups <- prCaSetRownames(
    reordered_groups,
    var_order,
    rowname.fn,
    use_labels,
    ds
  )


  coef_name <- ifelse("coxph" %in% class(model),
    "HR",
    ifelse("lrm" %in% class(model) |
      ("glm" %in% class(model) &&
        model$family$family == "binomial"),
    "OR",
    "Coef"
    )
  )
  if (desc_column) {
    extra_cols <- ncol(reordered_groups) - 4
    attr(reordered_groups, "align") <- c(rep("r", times = extra_cols), rep(c("r", "c"), times = 2))
    attr(reordered_groups, "n.cgroup") <- c(extra_cols, 2, 2)
    attr(reordered_groups, "cgroup") <- c("", "Crude", "Adjusted")
  } else {
    attr(reordered_groups, "align") <- rep(c("r", "c"), times = 2)
    attr(reordered_groups, "n.cgroup") <- c(2, 2)
    attr(reordered_groups, "cgroup") <- c("Crude", "Adjusted")
  }

  if (!missing(impute_args)) {
    impute_cols <- prCaGetImputationCols(
      impute_args = impute_args,
      output_mtrx = reordered_groups,
      model = model,
      data = ds
    )

    if (is.matrix(impute_cols)) {
      # Merge with original
      tmp <- cbind(reordered_groups, impute_cols)
      reordered_groups <- copyAllNewAttributes(reordered_groups, tmp)
      attr(reordered_groups, "align") <- c(
        attr(reordered_groups, "align"),
        rep("r", times = ncol(impute_cols))
      )
      attr(reordered_groups, "n.cgroup") <- c(
        attr(reordered_groups, "n.cgroup"),
        ncol(impute_cols)
      )
      attr(reordered_groups, "cgroup") <- c(
        attr(reordered_groups, "cgroup"),
        "Imputation effect"
      )
    }
  }

  # Create rgroup and n.rgroup stuff if any variable is a factor
  if (any(sapply(var_order, function(var) !is.null(var$lvls)))) {
    rgroup <- n.rgroup <- c()
    for (vn in names(var_order)) {
      if (var_order[[vn]]$no_rows == 1) {
        if (length(rgroup) == 0 ||
          tail(rgroup, 1) != "") {
          rgroup <- c(
            rgroup,
            ""
          )
          n.rgroup <- c(
            n.rgroup,
            1
          )
        } else {
          n.rgroup[length(rgroup)] <-
            n.rgroup[length(rgroup)] + 1
        }
      } else {
        rname <- prCaGetRowname(vn = vn, use_labels = use_labels, dataset = ds)
        if (!missing(rowname.fn)) {
          rname <- rowname.fn(rname)
        }
        rgroup <- c(
          rgroup,
          rname
        )
        n.rgroup <- c(
          n.rgroup,
          var_order[[vn]]$no_rows
        )
      }
    }

    if (!missing(groups)) {
      if (length(groups) == length(rgroup)) {
        rgroup <- groups
      } else {
        warning(
          "You have wanted to use groups but the number of rgroups identified ",
          " by the automatic add_reference (", length(rgroup), " rgroups)",
          " is not equal the number of groups provided by you (", length(groups), ").",
          "\n You have provided the groups: ", paste(groups, collapse = ", "),
          "\n and the rgroups are: ", paste(rgroup, collapse = ", ")
        )
      }
    }

    attr(reordered_groups, "rgroup") <- rgroup
    attr(reordered_groups, "n.rgroup") <- n.rgroup
  }

  structure(reordered_groups,
    class = c("printCrudeAndAdjusted", class(reordered_groups)),
    header = sub("(Crude|Adjusted)", coef_name, colnames(reordered_groups)),
    rowlabel.just = "l",
    rowlabel = "Variable",
    other = dot_args
  )
}

setClass("printCrudeAndAdjusted", contains = "matrix")

#' @param ... outputs from \code{printCrudeAndAdjusted}. If mixed then it defaults to rbind.data.frame
#' @param alt.names If you don't want to use named arguments for the \code{tspanner} attribute in the \code{rbind}
#'  or the \code{cgroup} in the \code{cbind} but a vector with names then use this argument.
#' @param deparse.level  backward compatibility
#'
#' @rdname printCrudeAndAdjustedModel
#' @export
#' @keywords internal
rbind.printCrudeAndAdjusted <-
  function(..., alt.names, deparse.level = 1) {
    pca <- list(...)
    first_elmnt <- pca[[1]]

    all_non_pca <- all(sapply(pca, function(elmnt) inherits(elmnt, "printCrudeAndAdjusted")))
    pca <- prClearPCAclass(pca)
    pca_args <- c(
      pca,
      list(deparse.level = deparse.level)
    )
    ret <- do.call(rbind, pca_args)
    if (!all_non_pca) {
      # Keep the attributes that don't relate to the row counts
      ret <- copyAllNewAttributes(
        from = first_elmnt,
        to = ret,
        attr2skip = c("rgroup", "n.rgroup", "tspanner", "n.tspanner")
      )
      return(ret)
    }

    ret <- copyAllNewAttributes(
      from = first_elmnt,
      to = ret
    )
    for (n in sprintf("%srgroup", c("", "n."))) {
      attr(ret, n) <- lapply(pca, function(x) attr(x, n)) |>
        unlist()
    }

    if (missing(alt.names)) {
      if (is.null(names(pca))) {
        return(ret)
      }

      alt.names <- names(pca)
    } else if (length(alt.names) != length(pca)) {
      stop(
        "If you are going to use alt.names for the tspanner",
        " you must supply the same length of arguments.",
        " alt.names is currently '", length(alt.names), "'",
        " and not '", length(pca), "' as expected"
      )
    }

    attr(ret, "tspanner") <- alt.names
    attr(ret, "n.tspanner") <- sapply(pca, nrow, USE.NAMES = FALSE)
    return(ret)
  }

#' @param x The output object from the \code{printCrudeAndAdjustedModel} function
#' @rdname printCrudeAndAdjustedModel
#' @export
#' @keywords internal
print.printCrudeAndAdjusted <- function(x, ...) {
  prPrintCAstring(x, ...) |>
    print()
}

#' @export
#' @keywords internal
#' @rdname printCrudeAndAdjustedModel
htmlTable.printCrudeAndAdjusted <- function(x, ...) {
  prPrintCAstring(x, ...) |>
    print()
}

#' @rdname printCrudeAndAdjustedModel
#' @export
#' @importFrom Gmisc copyAllNewAttributes
#'
#' @keywords internal
`[.printCrudeAndAdjusted` <- function(x, i, j, ...) {
  ret <- NextMethod()
  # Unfortunately I can't get around this hack :-(
  # Since a drop = FALSE argument is ignored
  if (is.null(dim(ret))) {
    tmp <- x
    class(tmp) <- class(tmp)[class(tmp) != "printCrudeAndAdjusted"]
    ret <- tmp[i, j, drop = FALSE]
    rm(tmp)
  }
  attr2skip <- c("dimnames", "dim")
  if (!missing(i)) {
    attr2skip <- c(attr2skip, "rgroup", "n.rgroup")
  }
  if (!missing(j)) {
    attr2skip <- c(attr2skip, "cgroup", "n.cgroup")
    attr(x, "header") <- attr(x, "header")[j]
    align <- attr(x, "align")
    if (length(align) < ncol(x)) {
      align <- c(
        align,
        rep(tail(align, 1),
          times = ncol(x) - length(align)
        )
      )
    }
    attr(x, "align") <- align[j]
  }

  copyAllNewAttributes(x, ret, attr2skip = attr2skip)
}

#' @rdname printCrudeAndAdjustedModel
#' @export
#' @importFrom Gmisc copyAllNewAttributes
#'
#' @keywords internal
cbind.printCrudeAndAdjusted <- function(..., alt.names, deparse.level = 1) {
  # cbind is an internal generics and thus doesn't
  # work with the NextMethod()
  pca <- list(...)
  tmp <- list()
  for (i in 1:length(pca)) {
    if (!is.null(pca[[i]])) {
      tmp[[length(tmp) + 1]] <- pca[[i]]
    }
  }
  pca <- tmp
  if (length(pca) == 1) {
    return(pca[[1]])
  }

  pca_args <- c(
    prClearPCAclass(pca),
    list(deparse.level = deparse.level)
  )
  # Check that names are the same in all models
  org_names <- rownames(pca_args[[1]])
  for (i in 2:length(pca_args)) {
    if (!all(org_names == rownames(pca_args[[i]]))) {
      stop("Rownames don't match up between the models")
    }
  }
  ret <- do.call(cbind, pca_args)
  attr2skip <- c("dimnames", "dim")
  attr2skip <- c(attr2skip, "cgroup", "n.cgroup", "header")

  ret <- copyAllNewAttributes(pca[[1]], ret, attr2skip = attr2skip)
  if (missing(alt.names)) {
    if (!is.null(names(pca))) {
      alt.names <- names(pca)
    }
  } else if (length(alt.names) != length(pca)) {
    stop("The alt.names have to have the same length as the number of arguments")
  }
  if (missing(alt.names)) {
    return(ret)
  }

  attr(ret, "cgroup") <- alt.names
  attr(ret, "n.cgroup") <- sapply(pca, ncol, USE.NAMES = FALSE)
  return(ret)
}

#' Removes the printCrudeAndAdjusted class from arguments
#'
#' @return list
#' @keywords internal
prClearPCAclass <- function(pca) {
  all_non_pca <- all(sapply(pca, function(elmnt) inherits(elmnt, "printCrudeAndAdjusted")))
  for (i in 1:length(pca)) {
    if (!is.null(pca[[i]])) {
      class(pca[[i]]) <-
        class(pca[[i]])[class(pca[[i]]) != "printCrudeAndAdjusted"]
    }
  }
  return(pca)
}

#' @rdname printCrudeAndAdjustedModel
#' @export
#' @importFrom knitr knit_print
#' @importFrom knitr asis_output
#'
#' @keywords internal
knit_print.printCrudeAndAdjusted <- function(x,
                                             ...) {
  prPrintCAstring(x, ...) |>
    asis_output()
}

#' Prep for printing
#'
#' Since we have both the \code{\link[base]{print}()} and the
#' \code{\link[knitr]{knit_print}()} that we need to call it is
#' useful to have a common string preparation.
#' \emph{Note:} Currently knit_print doesn't work as expected...
#'
#' @inheritParams print.printCrudeAndAdjusted
#' @keywords internal
prPrintCAstring <- function(x, ...) {
  # Since we have the htmlTable.printCrudeAndAdjusted we need to remove
  # the class in order to avoid infinite loop
  class(x) <- class(x)[!class(x) %in% "printCrudeAndAdjusted"]
  call_args <- list(
    x = x,
    rowlabel.just = attr(x, "rowlabel.just"),
    rowlabel = attr(x, "rowlabel"),
    align = attr(x, "align")
  )
  if (!is.null(attr(x, "header"))) {
    call_args$header <- attr(x, "header")
  }
  if (!is.null(attr(x, "cgroup"))) {
    call_args$cgroup <- attr(x, "cgroup")
    call_args$n.cgroup <- attr(x, "n.cgroup")
  }

  if (!is.null(attr(x, "rgroup"))) {
    call_args[["rgroup"]] <- attr(x, "rgroup")
    call_args[["n.rgroup"]] <- attr(x, "n.rgroup")
  }

  if (!is.null(attr(x, "tspanner"))) {
    call_args[["tspanner"]] <- attr(x, "tspanner")
    call_args[["n.tspanner"]] <- attr(x, "n.tspanner")
  }

  if (length(attr(x, "other")) > 0) {
    other <- attr(x, "other")
    for (option in names(other)) {
      if (nchar(option) > 0) call_args[[option]] <- other[[option]]
    }
  }

  dots <- list(...)
  if (length(dots) > 0) {
    for (option in names(dots)) {
      if (nchar(option) > 0) call_args[[option]] <- dots[[option]]
    }
  }

  fastDoCall(htmlTable, call_args)
}

#' @param object The output object from the printCrudeAndAdjustedModel function
#' @seealso \code{\link[Hmisc]{latex}()} for details.
#' @rdname printCrudeAndAdjustedModel
#' @method latex printCrudeAndAdjusted
#' @export
#' @keywords internal
#' @importFrom Hmisc latex
#' @importFrom Hmisc latexTranslate
latex.printCrudeAndAdjusted <- function(object, ...) {
  call_list <-
    list(
      colheads = attr(object, "header"),
      rowlabel.just = attr(object, "rowlabel.just"),
      rowlabel = attr(object, "rowlabel"),
      rowname = latexTranslate(rownames(object)),
      cgroup = attr(object, "cgroup"),
      n.cgroup = attr(object, "n.cgroup"),
      align = attr(object, "align")
    )

  if (!is.null(attr(object, "rgroup"))) {
    call_list[["rgroup"]] <- attr(object, "rgroup")
    call_list[["n.rgroup"]] <- attr(object, "n.rgroup")
  }

  dots <- list(...)
  if (length(dots) > 0) {
    for (option in names(dots)) {
      if (nchar(option) > 0) {
        call_list[option] <- dots[[option]]
      }
    }
  }

  return(fastDoCall(latex, call_list))
}


#' A function for gathering all the description options
#'
#' Since there are so many different description options
#' for the \code{\link{printCrudeAndAdjustedModel}()} function they
#' have been gathered into a list. This function is simply a
#' helper in order to generate a valid list.
#'
#' @param show_tot_perc Show percentages for the total column
#' @param numb_first Whether to show the number before the percentages
#' @param continuous_fn Stat function used for the descriptive statistics,
#'  defaults to \code{\link{describeMean}()}
#' @param prop_fn Stat function used for the descriptive statistics,
#'  defaults to \code{\link{describeFactors}()} since there has to be a reference
#'  in the current setup.
#' @param factor_fn Stat function used for the descriptive statistics,
#'  defaults to \code{\link{describeFactors}()}
#' @param digits Number of digits to use in the descriptive columns.
#'  Defaults to the general digits if not specified.
#' @param colnames The names of the two descriptive columns. By default
#'  Total and Event.
#' @return \code{list} Returns a list with all the options
#' @export
caDescribeOpts <- function(show_tot_perc = FALSE,
                           numb_first = TRUE,
                           continuous_fn = describeMean,
                           prop_fn = describeFactors,
                           factor_fn = describeFactors,
                           digits = 1,
                           colnames = c("Total", "Event")) {
  desc_list <-
    list(
      show_tot_perc = show_tot_perc,
      numb_first = numb_first,
      useNA = "no", # Can't have missing in regr. output
      digits = digits,
      colnames = colnames
    )

  if (is.character(describeMean)) {
    describeMean <- get(describeMean)
  }

  if (is.character(describeProp)) {
    describeProp <- get(describeProp)
  }

  if (is.character(describeFactors)) {
    describeFactors <- get(describeFactors)
  }

  desc_list$continuous_fn <- describeMean
  desc_list$prop_fn <- describeProp
  desc_list$factor_fn <- describeFactors

  class(desc_list) <- c("desc_list", class(desc_list))
  return(desc_list)
}