309 fixed power prior

.Rbuildignore

@@ -29,4 +29,5 @@ develop
 ^dev$
 ^\.pre-commit-config\.yaml$
 ^vignettes/original$
-^vignettes/Makefile$
+^vignettes/Makefile$
+^node_modules$

DESCRIPTION

@@ -122,6 +122,7 @@ Collate:
     'outcome_class.R'
     'analysis_class.R'
     'borrowing_details.R'
+    'borrowing_fixed_power_prior.R'
     'borrowing_full.R'
     'borrowing_hierarchical_commensurate.R'
     'borrowing_none.R'

NAMESPACE

@@ -9,6 +9,7 @@ export(beta_prior)
 export(bin_var)
 export(binary_cutoff)
 export(borrowing_details)
+export(borrowing_fixed_power_prior)
 export(borrowing_full)
 export(borrowing_hierarchical_commensurate)
 export(borrowing_none)

R/borrowing_fixed_power_prior.R

@@ -0,0 +1,66 @@
+#' `BorrowingFixedPowerPrior` class
+#'
+#' @slot method_name string. The name of the method.
+#' @slot ext_flag_col character. Name of the external flag column in the matrix.
+#' @slot powers numeric. The fixed values to be used as the powers in the power prior.
+#'
+#' @include borrowing_class.R
+#' @family borrowing classes
+.borrowing_fixed_power_prior <- setClass(
+  "BorrowingFixedPowerPrior",
+  slots = c(
+    power_col = "character"
+  ),
+  prototype = list(
+    method_name = "Borrowing with fixed power prior"
+  ),
+  contains = "Borrowing"
+)
+
+#' Fixed Power Prior Borrowing
+#'
+#' @param ext_flag_col character. Name of the external flag column in the matrix.
+#' @param power_col character. Name of the column containing values to be used as the power parameters.
+#'
+#' @return Object of class [`BorrowingFixedPowerPrior`][BorrowingFixedPowerPrior-class].
+#' @export
+#' @examples
+#' borrowing_fixed_power_prior(
+#'   ext_flag_col = "ext",
+#'   power_col = "power"
+#' )
+borrowing_fixed_power_prior <- function(ext_flag_col, power_col) {
+  assert_string(ext_flag_col)
+  assert_string(power_col)
+  .borrowing_fixed_power_prior(ext_flag_col = ext_flag_col, power_col = power_col)
+}
+
+# show ----
+setMethod(
+  f = "show",
+  signature = "BorrowingFixedPowerPrior",
+  definition = function(object) {
+    callNextMethod()
+  }
+)
+
+# trim cols ----
+#' @rdname trim_cols
+#' @include generics.R
+setMethod(
+  f = "trim_cols",
+  signature = "BorrowingFixedPowerPrior",
+  definition = function(borrowing_object, analysis_object) {
+    get_vars(analysis_object)
+  }
+)
+# get vars -----
+#' @rdname get_vars
+#' @include generics.R
+setMethod(
+  f = "get_vars",
+  signature = "BorrowingFixedPowerPrior",
+  definition = function(object) {
+    c(ext_flag_col = object@ext_flag_col, power_col = object@power_col)
+  }
+)

R/check_data_matrix_has_columns.R

@@ -39,8 +39,8 @@ check_data_matrix_has_columns <- function(object) {
     error_col <- c(error_col, get_vars(object@treatment))
   }
 
-  if (!get_vars(object@borrowing) %in% data_cols) {
-    error_col <- c(error_col, get_vars(object@borrowing))
+  if (any(missing_outcomes <- !get_vars(object@borrowing) %in% data_cols)) {
+    error_col <- c(error_col, get_vars(object@borrowing)[missing_outcomes])
   }
 
   missing_covs <- setdiff(get_vars(object@covariates), data_cols)

R/load_and_interpolate_stan_model.R

@@ -8,7 +8,7 @@
 #' @return String containing the interpolated Stan model
 #' @include outcome_surv_pem.R
 build_model_string <- function(template_domain, template_filename, outcome, borrowing, analysis_obj, ...) {
-  
+
   # Load the Stan template
   template <- load_stan_file(template_domain, template_filename)
 
@@ -72,6 +72,23 @@ setMethod(
   }
 )
 
+### Fixed power prior borrowing ----
+setMethod(
+  f = "load_and_interpolate_stan_model",
+  signature = c("OutcomeSurvExponential", "BorrowingFixedPowerPrior", "ANY"),
+  definition = function(outcome, borrowing, analysis_obj) {
+    model_string <- build_model_string(
+      template_domain = "surv",
+      template_filename = "exp_fpp.stan",
+      outcome = outcome,
+      borrowing = borrowing,
+      analysis_obj = analysis_obj
+    )
+
+    return(model_string)
+  }
+)
+
 ### Hierarchical commensurate prior borrowing ----
 setMethod(
   f = "load_and_interpolate_stan_model",
@@ -110,6 +127,24 @@ setMethod(
   }
 )
 
+### Fixed power prior borrowing ----
+setMethod(
+  f = "load_and_interpolate_stan_model",
+  signature = c("OutcomeSurvWeibullPH", "BorrowingFixedPowerPrior", "ANY"),
+  definition = function(outcome, borrowing, analysis_obj) {
+    model_string <- build_model_string(
+      template_domain = "surv",
+      template_filename = "weib_ph_fpp.stan",
+      outcome = outcome,
+      borrowing = borrowing,
+      analysis_obj = analysis_obj,
+      shape.prior = h_glue("shape_weibull ~ {{get_prior_string(outcome@param_priors$shape_weibull)}} ;")
+    )
+
+    return(model_string)
+  }
+)
+
 ### Hierarchical commensurate prior borrowing ----
 setMethod(
   f = "load_and_interpolate_stan_model",
@@ -149,6 +184,24 @@ setMethod(
   }
 )
 
+### Fixed power prior borrowing ----
+setMethod(
+  f = "load_and_interpolate_stan_model",
+  signature = c("OutcomeSurvPEM", "BorrowingFixedPowerPrior", "ANY"),
+  definition = function(outcome, borrowing, analysis_obj) {
+    model_string <- build_model_string(
+      template_domain = "surv",
+      template_filename = "pem_fpp.stan",
+      outcome = outcome,
+      borrowing = borrowing,
+      analysis_obj = analysis_obj,
+      baseline.prior = get_prior_string(outcome@baseline_prior)
+    )
+
+    return(model_string)
+  }
+)
+
 ### Hierarchical commensurate prior borrowing ----
 setMethod(
   f = "load_and_interpolate_stan_model",
@@ -188,6 +241,23 @@ setMethod(
   }
 )
 
+### Fixed power prior borrowing ----
+setMethod(
+  f = "load_and_interpolate_stan_model",
+  signature = c("OutcomeBinaryLogistic", "BorrowingFixedPowerPrior", "ANY"),
+  definition = function(outcome, borrowing, analysis_obj) {
+    model_string <- build_model_string(
+      template_domain = "bin",
+      template_filename = "logit_fpp.stan",
+      outcome = outcome,
+      borrowing = borrowing,
+      analysis_obj = analysis_obj
+    )
+
+    return(model_string)
+  }
+)
+
 ### Hierarchical commensurate prior borrowing ----
 setMethod(
   f = "load_and_interpolate_stan_model",
@@ -228,6 +298,24 @@ setMethod(
   }
 )
 
+### Fixed power prior borrowing ----
+setMethod(
+  f = "load_and_interpolate_stan_model",
+  signature = c("OutcomeContinuousNormal", "BorrowingFixedPowerPrior", "ANY"),
+  definition = function(outcome, borrowing, analysis_obj) {
+    model_string <- build_model_string(
+      template_domain = "cont",
+      template_filename = "gauss_fpp.stan",
+      outcome = outcome,
+      borrowing = borrowing,
+      analysis_obj = analysis_obj,
+      stdev.prior = h_glue("std_dev_outcome ~ {{get_prior_string(outcome@param_priors$std_dev_outcome)}} ;")
+    )
+
+    return(model_string)
+  }
+)
+
 ### Hierarchical commensurate prior borrowing ----
 setMethod(
   f = "load_and_interpolate_stan_model",

R/prepare_stan_data_inputs.R

@@ -41,7 +41,6 @@ setGeneric(
 #' @return Named list of data inputs with covariates and weights added.
 #' @noRd
 add_covariates_and_weights <- function(data_in, analysis_obj, data_matrix) {
-
   ## Covariate additions
   if (!is.null(analysis_obj@covariates)) {
     data_in[["K"]] <- NROW(analysis_obj@covariates@covariates)
@@ -84,6 +83,27 @@ setMethod(
   }
 )
 
+### Fixed power prior borrowing ----
+setMethod(
+  f = "prepare_stan_data_inputs",
+  signature = c("OutcomeSurvExponentialWeibull", "BorrowingFixedPowerPrior", "ANY"),
+  definition = function(outcome, borrowing, analysis_obj) {
+    data_matrix <- trim_data_matrix(analysis_obj)
+    data_in <- list(
+      N = nrow(data_matrix),
+      trt = data_matrix[, analysis_obj@treatment@trt_flag_col],
+      time = data_matrix[, outcome@time_var],
+      cens = data_matrix[, outcome@cens_var],
+      power = data_matrix[, borrowing@power_col]
+    )
+
+    # Add covariates and weights
+    data_in <- add_covariates_and_weights(data_in, analysis_obj, data_matrix)
+
+    return(data_in)
+  }
+)
+
 ### Hierarchical commensurate prior borrowing ----
 setMethod(
   f = "prepare_stan_data_inputs",
@@ -115,7 +135,6 @@ setMethod(
   f = "prepare_stan_data_inputs",
   signature = c("OutcomeSurvPEM", "BorrowingNoneFull", "ANY"),
   definition = function(outcome, borrowing, analysis_obj) {
-
     analysis_obj@data_matrix <- trim_data_matrix(analysis_obj)
     analysis_obj <- cast_mat_to_long_pem(analysis_obj)
     data_matrix <- analysis_obj@data_matrix
@@ -142,12 +161,43 @@ setMethod(
   }
 )
 
+### Fixed power prior borrowing ----
+setMethod(
+  f = "prepare_stan_data_inputs",
+  signature = c("OutcomeSurvPEM", "BorrowingFixedPowerPrior", "ANY"),
+  definition = function(outcome, borrowing, analysis_obj) {
+    analysis_obj@data_matrix <- trim_data_matrix(analysis_obj)
+    analysis_obj <- cast_mat_to_long_pem(analysis_obj)
+    data_matrix <- analysis_obj@data_matrix
+
+    n_periods <- analysis_obj@outcome@n_periods
+    Z <- matrix(0, nrow = nrow(data_matrix), ncol = n_periods)
+    for (i in seq_len(nrow(data_matrix))) {
+      period <- data_matrix[i, "__period__"]
+      Z[i, period] <- 1
+    }
+    data_in <- list(
+      N = nrow(data_matrix),
+      trt = data_matrix[, analysis_obj@treatment@trt_flag_col],
+      time = data_matrix[, outcome@time_var],
+      cens = data_matrix[, outcome@cens_var],
+      N_periods = max(data_matrix[, "__period__"]),
+      Z = Z,
+      power = data_matrix[, borrowing@power_col]
+    )
+
+    # Add covariates and weights
+    data_in <- add_covariates_and_weights(data_in, analysis_obj, data_matrix)
+
+    return(data_in)
+  }
+)
+
 ### Hierarchical Commensurate Borrowing ----
 setMethod(
   f = "prepare_stan_data_inputs",
   signature = c("OutcomeSurvPEM", "BorrowingHierarchicalCommensurate", "ANY"),
   definition = function(outcome, borrowing, analysis_obj) {
-
     analysis_obj <- cast_mat_to_long_pem(analysis_obj)
     data_matrix <- analysis_obj@data_matrix
 
@@ -197,6 +247,26 @@ setMethod(
   }
 )
 
+### Fixed power prior borrowing ----
+setMethod(
+  f = "prepare_stan_data_inputs",
+  signature = c("OutcomeBinaryLogistic", "BorrowingFixedPowerPrior", "ANY"),
+  definition = function(outcome, borrowing, analysis_obj) {
+    data_matrix <- trim_data_matrix(analysis_obj)
+    data_in <- list(
+      N = nrow(data_matrix),
+      trt = data_matrix[, analysis_obj@treatment@trt_flag_col],
+      y = data_matrix[, outcome@binary_var],
+      power = data_matrix[, borrowing@power_col]
+    )
+
+    # Add covariates and weights
+    data_in <- add_covariates_and_weights(data_in, analysis_obj, data_matrix)
+
+    return(data_in)
+  }
+)
+
 ### Hierarchical commensurate prior borrowing ----
 setMethod(
   f = "prepare_stan_data_inputs",
@@ -241,6 +311,26 @@ setMethod(
   }
 )
 
+### Fixed power prior borrowing ----
+setMethod(
+  f = "prepare_stan_data_inputs",
+  signature = c("OutcomeContinuousNormal", "BorrowingFixedPowerPrior", "ANY"),
+  definition = function(outcome, borrowing, analysis_obj) {
+    data_matrix <- trim_data_matrix(analysis_obj)
+    data_in <- list(
+      N = nrow(data_matrix),
+      trt = data_matrix[, analysis_obj@treatment@trt_flag_col],
+      y = data_matrix[, outcome@continuous_var],
+      power = data_matrix[, borrowing@power_col]
+    )
+
+    # Add covariates and weights
+    data_in <- add_covariates_and_weights(data_in, analysis_obj, data_matrix)
+
+    return(data_in)
+  }
+)
+
 ### Hierarchical commensurate prior borrowing ----
 setMethod(
   f = "prepare_stan_data_inputs",