R/update_saved.R

In adaptr: Adaptive Trial Simulator

#' Update previously saved simulation results
#'
#' This function updates a previously saved `"trial_results"` object created and
#' saved by [run_trials()] using a previous version of `adaptr`, allowing the
#' results from these previous simulations to be post-processed (including
#' performance metric calculation, printing and plotting) without errors by this
#' version of the package. The function should be run only once per saved
#' simulation object and will issue a warning if the object is already up to
#' date. And overview of the changes made according to the `adaptr` package
#' version used to generate the original object is provided in **Details**.\cr
#' **NOTE:** some values cannot be updated and will be set to `NA` (the
#' posterior estimates from the 'final' analysis conducted after the last
#' adaptive analysis and including outcome data for all patients), and thus
#' using both `raw_ests = TRUE` and `final_ests = TRUE` in the
#' [extract_results()] and [summary()] functions will lead to missing values for
#' some of the values calculated for updated simulation objects.\cr
#' **NOTE:** other objects created by the `adaptr` package, i.e., trial
#' specifications generated by
#' [setup_trial()] / [setup_trial_binom()] / [setup_trial_norm()] and single
#' simulation results from [run_trials()] when not included in as part of the
#' returned output from [run_trials()] should be re-created by re-running the
#' relevant code using the updated version of `adaptr`; if manually re-loaded
#' from previous sessions, they may cause errors and problems with the updated
#' version of the package.
#'
#' @param path single character; the path to the saved `"trial_results"`-object
#'   containing the simulations saved by [run_trials()].
#' @param version passed to [saveRDS()] when saving the updated object, defaults
#'   to `NULL` (as in [saveRDS()]), which means that the current default version
#'   is used.
#' @param compress passed to [saveRDS()] when saving the updated object,
#'   defaults to `TRUE` (as in [saveRDS()]), see [saveRDS()] for other options.
#'
#' @details
#'
#' The following changes are made according to the version of `adaptr` used to
#' generate the original `"trial_results"` object:
#'   \itemize{
#'     \item `v1.2.0+`: updates version number and the `reallocate_probs`
#'       argument in the embedded trial specification.
#'     \item `v1.1.1 or earlier`: updates version number and everything related
#'       to follow-up and data collection lag (in these versions, the
#'       `randomised_at_looks` argument in the [setup_trial()] functions did not
#'       exist, but for practical purposes was identical to the number of
#'       patients with available data at each look) and the `reallocate_probs`
#'       argument in the embedded trial specification.
#'    }
#'
#' @return Invisibly returns the updated `"trial_results"`-object.
#'
#' @export
#'
#' @seealso
#' [run_trials()].
#'
update_saved_trials <- function(path, version = NULL, compress = TRUE) {
  # Check if file exists at path
  if (!file.exists(path)) stop0("path must be a valid path to a trial_results-object.")
  object <- readRDS(path)
  if (!inherits(object, "trial_results")) {
    stop0("path must lead to a valid trial_results-object previously saved by run_trials().")
  }
  prev_version <- object$adaptr_version
  save_object <- TRUE
  if (isTRUE(!is.null(prev_version) & prev_version == .adaptr_version)) { # Already up-to-date
    save_object <- FALSE
    warning0("path leads to a trial_results-object that is already up to date; object not updated.")
  } else if (is.null(prev_version)) { # Saved by version 1.1.1 or earlier

    # Do the updating

    # Update the trial_spec-part of the object, re-arrange order of objects, set class
    object$trial_spec$randomised_at_looks <- object$trial_spec$data_looks
    object$trial_spec <- c(object$trial_spec, list(rescale_probs = NULL))
    object$trial_spec <- object$trial_spec[c("trial_arms", "rescale_probs", "data_looks", "max_n", "look_after_every",
                                             "n_data_looks", "randomised_at_looks", "control", "control_prob_fixed",
                                             "inferiority", "superiority", "equivalence_prob", "equivalence_diff",
                                             "equivalence_only_first", "futility_prob", "futility_diff", "futility_only_first",
                                             "highest_is_best", "soften_power", "best_arm", "cri_width", "n_draws", "robust",
                                             "description", "add_info", "fun_y_gen", "fun_draws", "fun_raw_est")]
    class(object$trial_spec) <- c("trial_spec", "list")

    # Update the trial_results-part of the object
    object$adaptr_version <- .adaptr_version

    # Update all resulting individual trial_result objects, re-arrange order of objects, set class
    sparse <- object$sparse

    for (i in 1:object$n_rep) {
      tmp <- object$trial_results[[i]]
      tmp$followed_n <- tmp$final_n
      tmp$trial_res$sum_ys_all <- tmp$trial_res$sum_ys
      tmp$trial_res$ns_all <- tmp$trial_res$ns
      tmp$trial_res$raw_ests_all <- tmp$trial_res$raw_ests
      tmp$trial_res[, c("post_ests_all", "post_errs_all", "lo_cri_all", "hi_cri_all")] <- NA
      tmp$trial_res <- tmp$trial_res[, c("arms", "true_ys", "start_probs", "fixed_probs", "min_probs", "max_probs",
                                         "sum_ys", "ns", "sum_ys_all", "ns_all", "raw_ests", "post_ests", "post_errs",
                                         "lo_cri", "hi_cri", "raw_ests_all", "post_ests_all", "post_errs_all", "lo_cri_all",
                                         "hi_cri_all", "final_status", "status_look", "status_probs", "final_alloc", "probs_best_last")]

      if (!sparse) { # Update results for non-sparse objects
        tmp$randomised_at_looks <- tmp$looks
        tmp$max_randomised <- tmp$max_n
        for (l in seq_along(tmp$all_looks)) { # Update results for each look
          tmp$all_looks[[l]]$sum_ys_all <- tmp$all_looks[[l]]$sum_ys
          tmp$all_looks[[l]]$ns_all <- tmp$all_looks[[l]]$ns
          tmp$all_looks[[l]] <- tmp$all_looks[[l]][c("arms", "old_status", "new_status", "sum_ys", "sum_ys_all", "ns", "ns_all",
                                                     "old_alloc", "probs_best", "new_alloc")]
        }
      }


      object$trial_results[[i]] <- if (sparse) {
        tmp[c("final_status", "final_n", "followed_n", "trial_res", "seed", "sparse")]
      } else {
        tmp[c("final_status", "final_n", "followed_n", "max_n", "max_randomised", "looks", "planned_looks", "randomised_at_looks",
              "start_control", "final_control", "control_prob_fixed", "inferiority", "superiority", "equivalence_prob",
              "equivalence_diff", "equivalence_only_first", "futility_prob", "futility_diff", "futility_only_first",
              "highest_is_best", "soften_power", "best_arm", "trial_res", "all_looks", "allocs", "ys", "seed", "description",
              "add_info", "cri_width", "n_draws", "robust", "sparse")]
      }
      class(object$trial_results[[i]]) <- c("trial_result", "list")
    }
  } else if (.adaptr_version >= "1.2.0") {
    # Update the trial_spec-part of the object, re-arrange order of objects, set class
    object$trial_spec <- c(object$trial_spec, list(rescale_probs = NULL))
    object$trial_spec <- object$trial_spec[c("trial_arms", "rescale_probs", "data_looks", "max_n", "look_after_every",
                                             "n_data_looks", "randomised_at_looks", "control", "control_prob_fixed",
                                             "inferiority", "superiority", "equivalence_prob", "equivalence_diff",
                                             "equivalence_only_first", "futility_prob", "futility_diff", "futility_only_first",
                                             "highest_is_best", "soften_power", "best_arm", "cri_width", "n_draws", "robust",
                                             "description", "add_info", "fun_y_gen", "fun_draws", "fun_raw_est")]
    class(object$trial_spec) <- c("trial_spec", "list")

    # Updated the version number
    object$adaptr_version <- .adaptr_version
  }
  # Save and return invisibly
  if (save_object) {
    saveRDS(object, file = path, version = version, compress = compress)
  }
  invisible(object)
}



#' Update previously saved calibration result
#'
#' This function updates a previously saved `"trial_calibration"`-object created
#' and saved by [calibrate_trial()] using a previous version of `adaptr`,
#' including the embedded trial specification and trial results objects
#' (internally using the [update_saved_trials()] function). This allows the
#' use of calibration results, including the calibrated trial specification and
#' the best simulations results from the calibration process, to be used without
#' errors by this version of the package. The function should be run only once
#' per saved simulation object and will issue a warning if the object is already
#' up to date. And overview of the changes made according to the `adaptr` package
#' version used to generate the original object is provided in **Details**.\cr
#'
#' @param path single character; the path to the saved
#'   `"trial_calibration"`-object containing the calibration result saved by
#'   [calibrate_trial()].
#' @param version passed to [saveRDS()] when saving the updated object, defaults
#'   to `NULL` (as in [saveRDS()]), which means that the current default version
#'   is used.
#' @param compress passed to [saveRDS()] when saving the updated object,
#'   defaults to `TRUE` (as in [saveRDS()]), see [saveRDS()] for other options.
#'
#' @details
#'
#' The following changes are made according to the version of `adaptr` used to
#' generate the original `"trial_calibration"` object:
#'   \itemize{
#'     \item `v1.3.0+`: updates version number of the
#'       `"trial_calibration"`-object and updates the embedded
#'       `"trial_results"`-object (saved in `$best_sims`, if any) and
#'       `"trial_spec"`-objects (saved in `$input_trial_spec` and
#'       `$best_trial_spec`) as described in [update_saved_trials()].
#'    }
#'
#' @return Invisibly returns the updated `"trial_calibration"`-object.
#'
#' @export
#'
#' @seealso
#' [run_trials()].
#'
update_saved_calibration <- function(path, version = NULL, compress = TRUE) {
  # Check if file exists at path
  if (!file.exists(path)) stop0("path must be a valid path to a trial_calibration-object.")
  object <- readRDS(path)
  if (!inherits(object, "trial_calibration")) {
    stop0("path must lead to a valid trial_calibration-object previously saved by calibrate_trial().")
  }
  prev_version <- object$adaptr_version
  save_object <- TRUE
  if (isTRUE(!is.null(prev_version) & prev_version == .adaptr_version)) { # Already up-to-date
    save_object <- FALSE
    warning0("path leads to a trial_calibration-object that is already up to date; object not updated.")
  } else { # Currently, the same is done for all previous versions - update later if required

    # Update overall object
    object$adaptr_version <- .adaptr_version

    # Update the input and updated trial specifications
    # Only contents changed after calibration introduced updated
    if (!"rescale_probs" %in% names(object$input_trial_spec)) { # if rescale_probs is missing, add to both
      object$input_trial_spec <- c(object$input_trial_spec, list(rescale_probs = NULL))
      object$best_trial_spec <- c(object$best_trial_spec, list(rescale_probs = NULL))
      list_order <- c("trial_arms", "rescale_probs", "data_looks", "max_n", "look_after_every",
                      "n_data_looks", "randomised_at_looks", "control", "control_prob_fixed",
                      "inferiority", "superiority", "equivalence_prob", "equivalence_diff",
                      "equivalence_only_first", "futility_prob", "futility_diff", "futility_only_first",
                      "highest_is_best", "soften_power", "best_arm", "cri_width", "n_draws", "robust",
                      "description", "add_info", "fun_y_gen", "fun_draws", "fun_raw_est")
      object$input_trial_spec <- object$input_trial_spec[list_order]
      class(object$input_trial_spec) <- c("trial_spec", "list")
      object$best_trial_spec <- object$best_trial_spec[list_order]
      class(object$best_trial_spec) <- c("trial_spec", "list")
    }

    # Updated a saved results object if any (not saved if new simulations not necessary for calibration)
    if (!is.null(object$best_sims)) {
      # Save in a temporary file to allow updated_saved_trials to update it
      tmp_file <- tempfile()
      on.exit(try(file.remove(tmp_file)), add = TRUE, after = FALSE)
      saveRDS(object$best_sims, file = tmp_file, version = version, compress = compress)
      object$best_sims <- update_saved_trials(tmp_file, version = version, compress = compress)
    }

  }
  # Save and return invisibly
  if (save_object) {
    saveRDS(object, file = path, version = version, compress = compress)
  }
  invisible(object)
}