case weights

DESCRIPTION

@@ -71,7 +71,7 @@ Encoding: UTF-8
 Depends:
     R (>= 4.1.0)
 Roxygen: list(markdown = TRUE)
-RoxygenNote: 7.3.1
+RoxygenNote: 7.3.2
 Config/testthat/edition: 3
 Imports:
     checkmate,
@@ -83,7 +83,8 @@ Imports:
     Matrix,
     mvtnorm,
     future,
-    simsurv
+    simsurv,
+    lamW
 Suggests:
     cmdstanr,
     survival,
@@ -121,10 +122,12 @@ Collate:
     'borrowing_class.R'
     'outcome_class.R'
     'analysis_class.R'
+    'borrowing_case_weights.R'
     'borrowing_details.R'
     'borrowing_full.R'
     'borrowing_hierarchical_commensurate.R'
     'borrowing_none.R'
+    'case_weight_helpers.R'
     'cast_mat_to_long_pem.R'
     'check_data_matrix_has_columns.R'
     'cmdstan.R'

NAMESPACE

@@ -8,6 +8,7 @@ export(bernoulli_prior)
 export(beta_prior)
 export(bin_var)
 export(binary_cutoff)
+export(borrowing_case_weights)
 export(borrowing_details)
 export(borrowing_full)
 export(borrowing_hierarchical_commensurate)
@@ -96,11 +97,20 @@ importFrom(graphics,par)
 importFrom(graphics,plot)
 importFrom(graphics,rect)
 importFrom(mvtnorm,rmvnorm)
+importFrom(stats,approxfun)
 importFrom(stats,as.formula)
 importFrom(stats,complete.cases)
+importFrom(stats,density)
 importFrom(stats,formula)
+importFrom(stats,glm)
 importFrom(stats,model.matrix)
 importFrom(stats,pnorm)
+importFrom(stats,poisson)
+importFrom(stats,predict)
+importFrom(stats,reformulate)
+importFrom(stats,rexp)
 importFrom(stats,setNames)
+importFrom(stats,update)
+importFrom(stats,vcov)
 importFrom(utils,head)
 importFrom(utils,packageVersion)

R/borrowing_case_weights.R

@@ -0,0 +1,93 @@
+#' `BorrowingCaseWeights` 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 p
+#' @slot q
+#' @slot c
+#'
+#' @include borrowing_class.R
+#' @family borrowing classes
+.borrowing_case_weights <- setClass(
+  "BorrowingCaseWeights",
+  slots = c(
+    p = "numeric",
+    q = "numeric",
+    c = "numeric",
+    samples = "numeric"
+  ),
+  prototype = list(
+    method_name = "Borrowing with case weights power prior"
+  ),
+  contains = "Borrowing",
+  validity = function(object) {
+    # check bounds on p, q, c?
+    return(TRUE)
+  }
+)
+
+#' Case Weights Power Prior borrowing
+#'
+#' @param ext_flag_col character. Name of the external flag column in the matrix.
+#' @param q The scale parameter in the global transform
+#' @param c The shift parameter in the global transform
+#' @param p The power used in the polynomial transform.
+#' @param samples A numeric vector with 2 values: the number of samples for all observations, the number of samples of
+#'
+#'
+#' @details
+#'
+#' ## Method
+#' For details on the transformation parameters, see equation 9 and 10 in the supplementary material of
+#'  Kwiatkowski et al.
+#'
+#' ## External Control
+#'
+#' The `ext_flag_col` argument refers to the column in the data matrix that
+#' contains the flag indicating a patient is from the external control cohort.
+#'
+#'
+#' @references
+#'
+#' Kwiatkowski, E., Zhu, J., Li, X., Pang, H., Lieberman, G., & Psioda, M. A. (2024).
+#'  Case weighted power priors for hybrid control analyses with time-to-event data.
+#'   __Biometrics, 80(2), ujae019__. \doi{10.1093/biomtc/ujae019}
+#'
+#' @return Object of class [`BorrowingCaseWeights`][BorrowingCaseWeights-class].
+#' @export
+#' @examples
+#' borrowing_case_weights(
+#'   ext_flag_col = "ext",
+#'   p = 1,
+#'   q = 50,
+#'   c = 0,
+#'   samples = c(100, 100)
+#' )
+borrowing_case_weights <- function(ext_flag_col, p = 1, c = 0, q = 500, samples = c(100, 100)) {
+  assert_string(ext_flag_col)
+  .borrowing_case_weights(ext_flag_col = ext_flag_col, p = p, c = c, q = q, samples = samples)
+}
+
+# show ----
+setMethod(
+  f = "show",
+  signature = "BorrowingCaseWeights",
+  definition = function(object) {
+    callNextMethod()
+    cat("Case Weight Transformations:\n")
+    show(object@c)
+    show(object@q)
+    show(object@p)
+  }
+)
+
+# trim cols ----
+#' @rdname trim_cols
+#' @include generics.R
+setMethod(
+  f = "trim_cols",
+  signature = "BorrowingCaseWeights",
+  definition = function(borrowing_object, analysis_object) {
+    return(get_vars(analysis_object))
+  }
+)