R/utils_model_output_helpers.R

In The-Strategy-Unit/723_mh_covid_surge_modelling: Mental Health Covid-19 Surge Modelling

#' Get model output
#'
#' Takes models list and returns a dataframe of the model results
#'
#' @param models the model output list
#' @param start_month what is month 0? should be a date object that is the first of the month
#'
#' @importFrom dplyr %>% bind_rows mutate select everything
#' @importFrom lubridate %m+% day days
#'
#' @return a tibble
#'
#' @export
get_model_output <- function(models, start_month) {
  stopifnot("start_month should be the first of the month" = day(start_month) == 1)
  models %>%
    # combine models
    bind_rows() %>%
    # add in a date column relating to the time value
    # we need to add in separately the month's and days
    mutate(date = start_month %m+%
             months(as.integer(floor(.data$time))) %m+%
             days(as.integer((.data$time - floor(.data$time)) * 30))) %>%
    select(.data$time, .data$date, everything())
}

#' Get Appointments
#'
#' Extracts the average month appointments each treatment generates per month from the params
#'
#' @param params the current `params` object used to model the data
#'
#' @return a tibble of treatments and average monthly appointments
#'
#' @importFrom dplyr %>% bind_cols transmute
#' @importFrom purrr map_dfr
get_appointments <- function(params) {
  params$treatments %>%
    map_dfr(bind_cols, .id = "treatment") %>%
    transmute(.data$treatment, average_monthly_appointments = .data$demand)
}

#' Model Totals
#'
#' Get the total value generated by the model for a given treatment. Can be used to calculate for referrals, treatments
#' etc.
#'
#' @param model_output output from \code{run_model()} and \code{get_model_output()}
#' @param type a character vector of the "type" to total
#' @param treatment a name of a treatment to filter by
#'
#' @return a comma-formatted number for the total for that type/treatment
#'
#' @importFrom dplyr %>% filter pull
#' @importFrom lubridate day
#' @import rlang
model_totals <- function(model_output, type, treatment) {
  model_output %>%
    filter(.data$type == {{type}},
           .data$treatment == {{treatment}},
           day(.data$date) == 1) %>%
    pull(.data$value) %>%
    sum() %>%
    comma()
}

#' Surge Summary
#'
#' Calculates the total surge generated by the model for the provided column.
#'
#' @param model_output output from \code{run_model()} and \code{get_model_output()}
#' @param column the column in `model_output` to calculate the summary for, either "group", "condition" or "treatment"
#'
#' @return a tibble containing a row per group/condition/treatment and the total value generated by the model
#'
#' @importFrom dplyr %>% filter group_by summarise across mutate arrange desc rename starts_with
#' @importFrom purrr compose
#' @importFrom lubridate day
#' @importFrom tidyr pivot_wider
#' @import rlang
surge_summary <- function(model_output, column) {
  model_output %>%
    filter(day(.data$date) == 1,
           !is.na({{column}}),
           grepl("^new-", .data$type)) %>%
    group_by(.data$type, {{column}}) %>%
    summarise(across(.data$value, sum), .groups = "drop") %>%
    pivot_wider(names_from = .data$type, values_from = .data$value) %>%
    mutate(across({{column}}, fct_reorder, .data$`new-referral`)) %>%
    mutate(across(starts_with("new-"), compose(as.integer, round))) %>%
    arrange(desc(.data$`new-referral`)) %>%
    rename(group = {{column}})
}

#' Surge Table
#'
#' Helper function to take output from \code{surge_summary} and produce a table of data for display in the surge tabs.
#'
#' @param model_output output from \code{run_model()} and \code{get_model_output()}
#' @param column the column in `model_output` to calculate the summary for, either "group", "condition" or "treatment"
#' @param column_name what to name the \code{column} in the new table
#'
#' @return a tibble with more descriptive column names
#'
#' @importFrom dplyr %>% rename
#' @import rlang
surge_table <- function(model_output, column, column_name) {
  column <- enquo(column)
  df <- model_output %>%
    surge_summary({{column}}) %>%
    rename(!!column_name := .data$`group`,
           "Total symptomatic over period referrals" = .data$`new-referral`,
           "Total receiving services over period" = .data$`new-treatment`)

  if ("new-at-risk" %in% colnames(df)) {
    df <- df %>%
      rename("Adjusted exposed / at risk @ baseline" = .data$`new-at-risk`)
  }

  df
}

#' Summarise model output
#'
#' Helper function used to filter results of the model output for use in plots and tables
#'
#' @param model_output output from \code{run_model()} and \code{get_model_output()}
#' @param type the row "type" to filter by
#' @param treatments the list of treatments to filter model_output by
#'
#' @return a filtered and summarised version of \code{model_output}
#'
#' @importFrom dplyr %>% filter group_by summarise across
#' @import rlang
summarise_model_output <- function(model_output, type, treatments) {
  model_output %>%
    filter(.data$type == {{type}},
           .data$treatment %in% treatments) %>%
    group_by(.data$date, .add = TRUE) %>%
    summarise(across(.data$value, sum), .groups = "drop_last")
}