R/summary_its.R

In multipleITScontrol: Interrupted Time Series with a Control and Multiple Interventions

#' Summarize and Rename Coefficients for an ITS Model
#'
#' This function takes a \code{gls} model object generated by `fit_its_model()`
#' and modifies the summary output by renaming the coefficients, variable names, and other model-related terms
#' to make them easier to interpret in the context of interrupted time series (ITS) analysis.
#'
#' The function modifies various components of the \code{gls} object, including:
#' \itemize{
#'   \item Coefficients
#'   \item Variable names in matrices (e.g., variance-covariance)
#'   \item Terms and factors used in the model
#'   \item Predicted variables
#' }
#'
#' The renamed terms in the model output are specifically tailored to better describe the parameters of
#' ITS models, such as control and pilot group slopes before and after interventions.
#'
#' @param model A \code{gls} model object that was generated by another custom function in the package.
#'
#' @return A modified summary of the \code{gls} model object, where the coefficient names and other relevant
#' model attributes have been renamed to be more interpretable.
#'
#' @details The function provides more meaningful names for ITS models by replacing default coefficient names with:
#' \itemize{
#'   \item \code{(Intercept)} becomes "Control y-axis intercept"
#'   \item \code{x} becomes "Pilot y-axis intercept difference to control"
#'   \item \code{time_index} becomes "Control pre-intervention slope"
#'   \item \code{x:time_index} becomes "Pilot pre-intervention slope difference to control"
#' }
#'
#' Additional terms for up to 3 interventions are automatically renamed, reflecting intervention-related slopes
#' in both control and pilot groups.
#'
#' @export
#' @importFrom purrr map
#' @importFrom nlme gls corARMA
#' @importFrom rlang !! !!! :=
#' @importFrom dplyr recode
#' @importFrom stats setNames terms

summary_its <- function(model) {
  summary_gls <- summary(model)

  name_map <- c(
    "(Intercept)" = "A) Control y-axis intercept",
    "x" = "B) Pilot y-axis intercept difference to control",
    "time_index" = "C) Control pre-intervention slope",
    "x:time_index" = "D) Pilot pre-intervention slope difference to control"
  )

  more_letters <- LETTERS[5:26]

  ptr <- 1

  # Add slopes and levels for up to 3 interventions
  for (i in 1:3) {
    name_map <- c(
      name_map,
      setNames(
        c(
          sprintf("%s) Control intervention %d slope", more_letters[ptr], i),
          sprintf("%s) Pilot intervention %d slope", more_letters[ptr + 1], i),
          sprintf("%s) Control intervention %d level", more_letters[ptr + 2], i),
          sprintf("%s) Pilot intervention %d level difference to control", more_letters[ptr + 3], i)
        ),
        c(
          sprintf("slope_%d_intervention", i),
          sprintf("x:slope_%d_intervention", i),
          sprintf("level_%d_intervention_internal", i),
          sprintf("x:level_%d_intervention_internal", i)
        )
      )
    )

    ptr <- ptr + 4
  }


  new_names_coeffs <- recode(
    names(summary_gls$coefficients),
    !!!name_map
  )

  new_names_row_matrix <- recode(
    rownames(summary_gls$varBeta),
    !!!name_map
  )

  new_names_col_matrix <- recode(
    colnames(summary_gls$varBeta),
    !!!name_map
  )

  new_names_parAssign <- recode(names(summary_gls$parAssign), !!!name_map)

  new_names_row_varBetaFact <- recode(rownames(attr(summary_gls$parAssign, "varBetaFact")), !!!name_map)

  new_names_col_varBetaFact <- recode(colnames(attr(summary_gls$parAssign, "varBetaFact")), !!!name_map)


  names(summary_gls$coefficients) <- new_names_coeffs
  rownames(summary_gls$varBeta) <- new_names_row_matrix
  colnames(summary_gls$varBeta) <- new_names_col_matrix
  names(summary_gls$parAssign) <- new_names_parAssign

  rownames(attr(summary_gls$parAssign, "varBetaFact")) <- new_names_row_varBetaFact
  colnames(attr(summary_gls$parAssign, "varBetaFact")) <- new_names_col_varBetaFact


  terms_obj <- terms(summary_gls)

  variables <- attr(terms_obj, "variables")
  variables <- as.list(variables)

  replace_names <- function(var) {
    var_name <- as.character(var)
    if (var_name %in% names(name_map)) {
      return(as.symbol(name_map[var_name])) # Replace with the new name
    } else {
      return(var) # Keep the original name if not found in the vector
    }
  }

  # Apply the renaming function to each variable in the list
  variables <- lapply(variables, replace_names)

  # Convert the list back to a call and reassign it
  attr(terms_obj, "variables") <- as.call(variables)


  rownames(attr(terms_obj, "factors")) <- recode(rownames(attr(terms_obj, "factors")), !!!name_map)
  colnames(attr(terms_obj, "factors")) <- recode(colnames(attr(terms_obj, "factors")), !!!name_map)


  attr(terms_obj, "term.labels") <- recode(attr(terms_obj, "term.labels"), !!!name_map)


  predvars <- attr(terms_obj, "predvars")
  predvars <- as.list(predvars)
  predvars <- lapply(predvars, replace_names)
  attr(terms_obj, "predvars") <- as.call(predvars)


  names(attr(terms_obj, "dataClasses")) <- recode(names(attr(terms_obj, "dataClasses")), !!!name_map)


  # Define a recursive function using purrr to replace old names with new ones
  replace_recursive <- function(obj, name_map) {
    # Check if the object is a symbol and replace if necessary
    if (is.symbol(obj)) {
      obj_name <- as.character(obj)
      if (obj_name %in% names(name_map)) {
        return(as.symbol(name_map[[obj_name]])) # Replace with new name
      }
    }

    # If the object is a call, replace its arguments
    if (is.call(obj)) {
      updated_args <- map(as.list(obj[-1]), ~ replace_recursive(.x, name_map))
      return(as.call(c(obj[[1]], updated_args)))
    }

    # If it's a list, apply the replacement function to each element
    if (is.list(obj)) {
      return(map(obj, ~ replace_recursive(.x, name_map)))
    }

    # If it's none of the above, return the object unchanged
    return(obj)
  }

  # Access the unnamed sub-object at index 3
  unnamed_subobj <- as.list(terms_obj[[3]])

  # Recursively replace the old variable names with new ones in the unnamed sub-object
  updated_subobj <- replace_recursive(unnamed_subobj, name_map)

  terms_obj[[3]] <- as.call(updated_subobj)

  summary_gls$terms <- terms_obj

  rownames(summary_gls$corBeta) <- recode(
    rownames(summary_gls$corBeta),
    !!!name_map
  )

  colnames(summary_gls$corBeta) <- recode(
    colnames(summary_gls$corBeta),
    !!!name_map
  )

  rownames(summary_gls$tTable) <- recode(
    rownames(summary_gls$tTable),
    !!!name_map
  )

  class(summary_gls) <- c("gls")

  return(summary_gls)
}

# summary_its(model) -> summary_test
#
# sjPlot::tab_model(summary_test)