R/add_totals.R

In pxmake: Make PX-Files in R

#' Add total level to variable
#'
#' Add a new level to a variables which is the sum of all other levels.
#'
#' @inheritParams add_totals_to_df
#' @param variable Name of variable to add total level to.
#' @param level_name Total level name.
#'
#' @returns A data frame
#' @keywords internal
add_total_level_to_var <- function(df,
                                   variable,
                                   level_name = "Total",
                                   sum_var = "value",
                                   na_rm = TRUE) {
  column_order <- names(df)

  df |>
    dplyr::group_by(across(-any_of(c(variable, sum_var)))) |>
    dplyr::summarise(
      !!sum_var := sum(!!rlang::sym(sum_var), na.rm = !!na_rm)
    ) |>
    dplyr::ungroup() |>
    dplyr::mutate({{ variable }} := level_name) |>
    dplyr::bind_rows(df) |>
    dplyr::relocate(all_of(column_order))
}

#' Add total levels to multiple variables
#'
#' Wrapper around \link{add_total_level_to_var} to add levels to total level to
#' multiple variables.
#'
#' @inheritParams px_add_totals
#' @param df Data frame to add total levels to.
#' @param variables List of variables to add total levels to.
#' @param level_names Names of total levels. Should have length 1 or same length
#' as `variables`.
#' @param sum_var String, name of variable to sum over.
#' @keywords internal
add_totals_to_df <- function(df,
                             variables,
                             level_names,
                             sum_var = "value",
                             na_rm = TRUE) {
  params <- data.frame(variables = variables, level_names = level_names)

  for (i in seq_len(nrow(params))) {
    df <- add_total_level_to_var(df,
      variable = params$variables[i],
      level_name = params$level_names[i],
      sum_var = sum_var,
      na_rm = !!na_rm
    )
  }

  df
}

#' @rdname px_add_totals.px
#' @export
px_add_totals <- function(x, value, na_rm = TRUE, validate) {
  UseMethod("px_add_totals")
}

#' @title Add total levels to variables
#'
#' @description
#' Adds a total level, which is the sum of the figures for all other levels of
#' the variable.
#'
#' The default name of the total level is 'Total', unless \link{px_elimination}
#' is set, in which case the elimination code is used.
#'
#' @param x A px object
#' @param value A character vector of variables to add total levels to.
#' @param na_rm Optional. Logical. If TRUE, NAs are removed before summing.
#' @eval param_validate()
#'
#' @returns A px object
#'
#' @seealso [px_elimination]
#'
#' @examples
#' # Create small px object example
#' x0 <- px(subset(population_gl, age == "65+"))
#' px_data(x0)
#'
#' # Add total level to one variable
#' x1 <- px_add_totals(x0, "gender")
#' px_data(x1)
#'
#' # Add total level to multiple variables
#' x2 <- px_add_totals(x0, c("gender", "age"))
#' px_data(x2)
#'
#' # The name of the total level can be changed with px_elimination()
#' x3 <-
#'   x0 |>
#'   px_elimination("T") |>
#'   px_add_totals("gender")
#'
#' px_data(x3)
#'
#' @export
px_add_totals.px <- function(x, value, na_rm = TRUE, validate = TRUE) {
  elimination <-
    px_elimination(x)

  values_not_in_elimination <-
    value[!value %in% elimination$`variable-code`]

  if (length(values_not_in_elimination) > 0) {
    default_elimination <-
      dplyr::tibble(
        `variable-code` = values_not_in_elimination,
        elimination = "Total"
      )

    x <- px_elimination(x, dplyr::bind_rows(elimination, default_elimination))
  }

  params <-
    x$variables1 |>
    dplyr::filter(.data$`variable-code` %in% value) |>
    dplyr::distinct(.data$`variable-code`, .data$elimination)

  x$data <-
    add_totals_to_df(x$data,
      variables = params$`variable-code`,
      level_names = params$elimination,
      sum_var = px_figures(x),
      na_rm = !!na_rm
    )

  return_px(x, validate)
}