R/confidence_set_processor.R

In LAGOtrials: Learn-as-You-Go Adaptive Trial Optimization

confidence_set_processor <- function(
    data,
    confidence_set_grid_step_size,
    step_size_results,
    include_center_effects,
    include_time_effects,
    time_effect_optimization_value = NULL,
    intervention_components,
    additional_covariates,
    center_characteristics,
    center_weights_for_outcome_goal,
    include_interaction_terms,
    main_components,
    outcome_name,
    model,
    family_object,
    outcome_goal,
    outcome_type,
    intervention_lower_bounds,
    intervention_upper_bounds,
    center_characteristics_optimization_values,
    confidence_set_alpha,
    cost_list_of_vectors,
    rec_int,
    quiet = FALSE) {
  # assign confidence set step size if not specified
  if (is.null(confidence_set_grid_step_size)) {
    confidence_set_grid_step_size <- step_size_results
  }

  # calculate the confidence set for the recommended interventions
  if (!quiet) {
    cat(paste(
      "If the confidence set calculation takes a long time to run,",
      "please consider changing the confidence set step size. \n"
    ))
  }
  # use exactly the rows glm() fitted, which excludes rows with a missing model variable
  omitted <- stats::na.action(model)
  if (length(omitted) > 0) data <- data[-as.integer(omitted), , drop = FALSE]
  predictors_list <- c(
    if (include_center_effects) "center",
    if (include_time_effects) "period",
    intervention_components,
    if (!is.null(additional_covariates)) additional_covariates,
    if (!is.null(center_characteristics)) center_characteristics
  )
  predictors_list <- gsub("`", "", predictors_list)

  # an explicit NA level of a fixed effect, or a non-reference one elsewhere, is refused
  cluster_cols <- c(
    if (include_center_effects) "center",
    if (include_time_effects) "period"
  )
  na_level <- Filter(function(col) {
    if (!is.factor(data[[col]])) return(FALSE)
    lv <- levels(droplevels(data[[col]]))
    if (col %in% cluster_cols) anyNA(lv) else anyNA(lv[-1])
  }, predictors_list)
  if (outcome_type == "continuous" && length(na_level) > 0) {
    stop(paste0(
      "The confidence set of a continuous outcome cannot use an explicit NA ",
      "level (as from addNA()) in the column(s) ",
      paste0("'", na_level, "'", collapse = ", "), ". Give that level a ",
      "name, or set include_confidence_set = FALSE."
    ))
  }

  # convert columns of the fixed effects to factor type
  if (include_center_effects) data$center <- factor(data$center)
  if (include_time_effects) data$period <- factor(data$period)

  cs <- get_confidence_set(
    # drop = FALSE keeps a single predictor as a data.frame; get_confidence_set
    # indexes predictors_data by column (names(), data[[col]]), which fails if a
    # one-column selection collapses to a vector.
    predictors_data = data[, predictors_list, drop = FALSE],
    # every argument is named: get_confidence_set() takes more of them than it
    # used to, so positional matching would silently pass each one to the
    # argument that now sits in its place
    include_center_effects = include_center_effects,
    center_weights_for_outcome_goal = center_weights_for_outcome_goal,
    include_time_effects = include_time_effects,
    # the confidence set is computed at the same period the recommended
    # intervention and the reported estimated outcome are, so the reported
    # interval and point estimate refer to the same quantity
    time_effect_optimization_value = time_effect_optimization_value,
    additional_covariates = additional_covariates,
    intervention_components = intervention_components,
    include_interaction_terms = include_interaction_terms,
    main_components = main_components,
    # [[ ]] gives a vector for a tibble too, where data[, name] keeps a one-column tibble
    outcome_data = data[[outcome_name]],
    fitted_model = model,
    link = family_object$link,
    outcome_goal = outcome_goal,
    outcome_type = outcome_type,
    intervention_lower_bounds = intervention_lower_bounds,
    intervention_upper_bounds = intervention_upper_bounds,
    confidence_set_grid_step_size = confidence_set_grid_step_size,
    center_characteristics = center_characteristics,
    center_characteristics_optimization_values =
      center_characteristics_optimization_values,
    confidence_set_alpha = confidence_set_alpha,
    # the fixed effects already model the centers and periods, so the
    # variance is not clustered on them
    cluster_id = NULL,
    cost_list_of_vectors = cost_list_of_vectors,
    rec_int = rec_int
  )

  list(
    cs = cs
  )
}