R/visOmopTable.R

In visOmopResults: Graphs and Tables for OMOP Results

#' Format a `<summarised_result>` object into a gt, flextable, or tibble object
#'
#' @param result A `<summarised_result>` object.
#' @param estimateName A named list of estimate names to join, sorted by
#' computation order. Use `<...>` to indicate estimate names.
#' @param header A vector specifying the elements to include in the header.
#' The order of elements matters, with the first being the topmost header.
#' The input vector elements can be:
#' 1) Column names from the split summarised result generated by `splitAll()`
#' 2) Settings specified in the `settings` argument
#' 3) `group`, `strata`, `additional`, `variable`, `estimate`, and/or `settings`
#'    to refer to all columns within these groups
#' 4) Any other input to create overall header labels at the specified location.
#' @param settingsColumns A character vector with the names of settings to
#' include in the table.
#' @param groupColumn Columns to use as group labels. By default, the name of the
#' new group will be the tidy* column names separated by ";". To specify a custom
#' group name, use a named list such as:
#' list("newGroupName" = c("variable_name", "variable_level")).
#'
#' *tidy: The tidy format applied to column names replaces "_" with a space and
#' converts to sentence case. Use `rename` to customize specific column names.
#'
#' @param rename A named vector to customize column names, e.g.,
#' c("Database name" = "cdm_name"). The function renames all column names
#' not specified here into a tidy* format.
#' @param type The desired format of the output table. See `tableType()` for
#' allowed options.
#' @param hide Columns to drop from the output table. By default, `result_id` and
#' `estimate_type` are always dropped.
#' @param showMinCellCount If `TRUE`, suppressed estimates will be indicated with
#' "<\{min_cell_count\}", otherwise, the default `na` defined in `.options` will be
#' used.
#' @param .options A named list with additional formatting options.
#' `visOmopResults::tableOptions()` shows allowed arguments and their default values.
#' @param split `r lifecycle::badge("deprecated")`
#' @param excludeColumns `r lifecycle::badge("deprecated")`
#' @param formatEstimateName `r lifecycle::badge("deprecated")`
#' @param renameColumns `r lifecycle::badge("deprecated")`
#'
#' @return A tibble, gt, or flextable object.
#'
#' @description
#' This function combines the functionalities of `formatEstimateValue()`,
#' `estimateName()`, `formatHeader()`, and `formatTable()`
#' into a single function specifically for `<summarised_result>` objects.
#'
#' @export
#'
#' @examples
#' result <- mockSummarisedResult()
#' result |>
#'   visOmopTable(
#'     estimateName = c("N%" = "<count> (<percentage>)",
#'                      "N" = "<count>",
#'                      "Mean (SD)" = "<mean> (<sd>)"),
#'     header = c("group"),
#'     rename = c("Database name" = "cdm_name"),
#'     groupColumn = strataColumns(result)
#'   )
visOmopTable <- function(result,
                         estimateName = character(),
                         header = character(),
                         settingsColumns = character(),
                         groupColumn = character(),
                         rename = character(),
                         type = "gt",
                         hide = character(),
                         showMinCellCount = TRUE,
                         .options = list(),
                         split = lifecycle::deprecated(),
                         excludeColumns = lifecycle::deprecated(),
                         formatEstimateName = lifecycle::deprecated(),
                         renameColumns = lifecycle::deprecated()) {

  if (lifecycle::is_present(split)) {
    lifecycle::deprecate_warn("0.4.0", "visOmopTable(split)")
  }
  if (lifecycle::is_present(excludeColumns)) {
    lifecycle::deprecate_soft(
      "0.4.0", "visOmopTable(excludeColumns = )", "visOmopTable(hide = )")
    if (missing(hide)) hide <- excludeColumns
  }
  if (lifecycle::is_present(renameColumns)) {
    lifecycle::deprecate_soft(
      "0.4.0", "visOmopTable(renameColumns = )", "visOmopTable(rename = )")
    if (missing(rename)) rename <- renameColumns
  }
  if (lifecycle::is_present(formatEstimateName)) {
    lifecycle::deprecate_soft(
      "0.4.0", "visOmopTable(formatEstimateName = )", "visOmopTable(estimateName = )")
    if (missing(estimateName)) estimateName <- formatEstimateName
  }

  # Tidy results
  result <- omopgenerics::validateResultArguemnt(result)
  resultTidy <- tidySummarisedResult(result, settingsColumns = settingsColumns, pivotEstimatesBy = NULL)

  # .options
  .options <- defaultTableOptions(.options)

  # Backward compatibility ---> to be deleted in the future
  omopgenerics::assertCharacter(header, null = TRUE)
  omopgenerics::assertCharacter(hide, null = TRUE)
  settingsColumns <- validateSettingsColumns(settingsColumns, result)
  bc <- backwardCompatibility(header, hide, result, settingsColumns, groupColumn)
  header <- bc$header
  hide <- bc$hide
  groupColumn <- bc$groupColumn
  if ("variable_level" %in% header) {
    resultTidy <- resultTidy |>
      dplyr::mutate(dplyr::across(dplyr::starts_with("variable"), ~ dplyr::if_else(is.na(.x), .options$na, .x)))
  }

  # initial checks and preparation
  rename <- validateRename(rename, result)
  if (!"cdm_name" %in% rename) rename <- c(rename, "CDM name" = "cdm_name")
  groupColumn <- validateGroupColumn(groupColumn, colnames(resultTidy), sr = result, rename = rename)
  showMinCellCount <- validateShowMinCellCount(showMinCellCount, settings(result))
  # default SR hide columns
  hide <- c(hide, "result_id", "estimate_type") |> unique()
  checkVisTableInputs(header, groupColumn, hide)

  # showMinCellCount
  if (showMinCellCount) {
    if ("min_cell_count" %in% settingsColumns) {
      resultTidy <- resultTidy |>
        dplyr::mutate(estimate_value = dplyr::if_else(
          is.na(.data$estimate_value), paste0("<", base::format(.data$min_cell_count, big.mark = ",")), .data$estimate_value
        ))
    } else {
      resultTidy <- resultTidy |>
        dplyr::left_join(
          settings(result) |> dplyr::select("result_id", "min_cell_count"),
          by = "result_id"
        ) |>
        dplyr::mutate(estimate_value = dplyr::if_else(
          is.na(.data$estimate_value), paste0("<", base::format(.data$min_cell_count, big.mark = ",")), .data$estimate_value
        )) |>
        dplyr::select(!"min_cell_count")
    }
  }

  tableOut <- visTable(
    result = resultTidy,
    estimateName = estimateName,
    header = header,
    groupColumn = groupColumn,
    type = type,
    rename = rename,
    hide = hide,
    .options = .options
  )

  return(tableOut)
}

formatToSentence <- function(x) {
  stringr::str_to_sentence(gsub("_", " ", gsub("&&&", "and", x)))
}

defaultTableOptions <- function(userOptions) {
  defaultOpts <- list(
    decimals = c(integer = 0, percentage = 2, numeric = 2, proportion = 2),
    decimalMark = ".",
    bigMark = ",",
    keepNotFormatted = TRUE,
    useFormatOrder = TRUE,
    delim = "\n",
    includeHeaderName = TRUE,
    includeHeaderKey = TRUE,
    style = "default",
    na = "-",
    title = NULL,
    subtitle = NULL,
    caption = NULL,
    groupAsColumn = FALSE,
    groupOrder = NULL,
    merge = "all_columns"
  )

  for (opt in names(userOptions)) {
    defaultOpts[[opt]] <- userOptions[[opt]]
  }

  return(defaultOpts)
}

backwardCompatibility <- function(header, hide, result, settingsColumns, groupColumn) {
  if (all(is.na(result$variable_level)) & "variable" %in% header) {
    colsVariable <- c("variable_name")
    hide <- c(hide, "variable_level")
  } else {
    colsVariable <- c("variable_name", "variable_level")
  }

  cols <- list(
    "group" = groupColumns(result),
    "strata" = strataColumns(result),
    "additional" = additionalColumns(result),
    "variable" = colsVariable,
    "estimate" = "estimate_name",
    "settings" = settingsColumns,
    "group_name" = character(),
    "strata_name" = character(),
    "additional_name" = character()
  )
  cols$group_level <- cols$group
  cols$strata_level <- cols$strata
  cols$additional_level <- cols$additional

  header <- correctColumnn(header, cols)

  if (is.list(groupColumn)) {
    groupColumn <- purrr::map(groupColumn, \(x) correctColumnn(x, cols))
  } else if (is.character(groupColumn)) {
    groupColumn <- correctColumnn(groupColumn, cols)
  }

  return(list(hide = hide, header = header, groupColumn = groupColumn))
}

correctColumnn <- function(col, cols) {
  purrr::map(col, \(x) if (x %in% names(cols)) cols[[x]] else x) |>
    unlist() |>
    unique()
}