add glm.nb

R/robin_glm.R

@@ -10,8 +10,10 @@
 #' @param vcov (`function`) A function to calculate the variance-covariance matrix of the treatment effect,
 #' including `vcovHC` and `gvcov`.
 #' @param family (`family`) A family object of the glm model.
-#' @param ... Additional arguments passed to `vcov`. For finer control of glm, refer to usage of `treatment_effect`,
-#' `difference`, `risk_ratio`, `odds_ratio`.
+#' @param vcov_args (`list`) Additional arguments passed to `vcov`.
+#' @param ... Additional arguments passed to `glm` or `glm.nb`.
+#' @details
+#' If family is `MASS::negative.binomial(NA)`, the function will use `MASS::glm.nb` instead of `glm`.
 #' @export
 #' @examples
 #' robin_glm(
@@ -21,14 +23,23 @@
 #' )
 robin_glm <- function(
     formula, data, treatment, contrast = "difference",
-    contrast_jac = NULL, vcov = gvcov, family = gaussian, ...) {
+    contrast_jac = NULL, vcov = "gvcov", family = gaussian(), vcov_args = list(), ...) {
   attr(formula, ".Environment") <- environment()
-  fit <- glm(formula, family = family, data = data)
+  # check if using negative.binomial family with NA as theta.
+  # If so, use MASS::glm.nb instead of glm.
+  if (identical(family$family, "Negative Binomial(NA)")) {
+    fit <- MASS::glm.nb(formula, data = data, ...)
+  } else {
+    fit <- glm(formula, family = family, data = data, ...)
+  }
   pc <- predict_counterfactual(fit, treatment, data)
   has_interaction <- h_interaction(formula, treatment)
-  if (has_interaction && identical(vcov, vcovHC) && !identical(contrast, "difference")) {
+  if (
+    has_interaction && (identical(vcov, "vcovHC") || identical(vcov, vcovHC)) &&
+      !identical(contrast, "difference")) {
     stop(
-      "Huber-White variance estimator is ONLY supported when the expected outcome difference is estimated using a linear model without treatment-covariate interactions; see the 2023 FDA guidance."
+      "Huber-White variance estimator is ONLY supported when the expected outcome difference is estimated",
+      "using a linear model without treatment-covariate interactions; see the 2023 FDA guidance."
     )
   }
   if (identical(contrast, "difference")) {
@@ -45,7 +56,7 @@ robin_glm <- function(
         numDeriv::jacobian(contrast, x)
       }
     }
-    treatment_effect(pc, eff_measure = contrast, eff_jacobian = contrast_jac, variance = vcov, ...)
+    treatment_effect(pc, eff_measure = contrast, eff_jacobian = contrast_jac, variance = vcov, vcov_args = vcov_args)
   }
 }
 

R/treatment_effect.R

@@ -6,21 +6,26 @@
 #' @param variance (`function`) Variance function.
 #' @param eff_measure (`function`) Treatment effect measurement function.
 #' @param eff_jacobian (`function`) Treatment effect jacobian function.
+#' @param vcov_args (`list`) Additional arguments for variance.
 #' @param ... Additional arguments for variance.
 #'
 #' @export
-treatment_effect <- function(object, pair, variance, eff_measure, eff_jacobian, ...) {
+treatment_effect <- function(object, pair, variance, eff_measure, eff_jacobian, vcov_args, ...) {
   UseMethod("treatment_effect")
 }
 
 #' @export
 treatment_effect.prediction_cf <- function(
-    object, pair = names(object), variance = gvcov, eff_measure, eff_jacobian, ...) {
+    object, pair = names(object), variance = "gvcov", eff_measure, eff_jacobian, vcov_args = list(), ...) {
   assert(
+    test_string(variance),
     test_function(variance),
     test_null(variance)
   )
   assert_function(eff_measure)
+  if (missing(pair)) {
+    pair <- names(object)
+  }
   assert_vector(pair)
   assert(
     test_subset(pair, names(object)),
@@ -30,8 +35,16 @@ treatment_effect.prediction_cf <- function(
     pair <- names(object)[pair]
   }
   trt_effect <- unname(eff_measure(object[pair]))
+  if (test_string(variance)) {
+    variance_name <- variance
+    variance <- match.fun(variance)
+  } else if (test_function(variance)) {
+    variance_name <- "function"
+  } else {
+    variance_name <- "none"
+  }
   if (!is.null(variance)) {
-    inner_variance <- variance(object, ...)[pair, pair]
+    inner_variance <- do.call(variance, c(list(object), vcov_args))[pair, pair]
     if (missing(eff_jacobian)) {
       trt_jac <- numDeriv::jacobian(eff_measure, object[pair])
     } else {
@@ -47,8 +60,9 @@ treatment_effect.prediction_cf <- function(
   structure(
     .Data = trt_effect,
     name = pair_names[lower.tri(pair_names)],
+    marginal_mean = object,
     fit = attr(object, "fit"),
-    vartype = deparse(substitute(variance)),
+    vartype = variance_name,
     treatment = attr(object, "treatment_formula"),
     variance = diag(trt_var),
     class = "treatment_effect"
@@ -59,26 +73,18 @@ treatment_effect.prediction_cf <- function(
 #' @export
 #' @inheritParams predict_counterfactual
 treatment_effect.lm <- function(
-    object, pair = names(object), variance = gvcov, eff_measure, eff_jacobian,
-    treatment, data = find_data(object), ...) {
+    object, pair, variance = gvcov, eff_measure, eff_jacobian,
+    treatment, vcov_args = list(), data = find_data(object), ...) {
   pc <- predict_counterfactual(object, data = data, treatment)
-  if (missing(pair)) {
-    treatment_effect(pc, pair = , , variance = variance, eff_measure = eff_measure, eff_jacobian = eff_jacobian, ...)
-  } else {
-    treatment_effect(pc, pair, variance = variance, eff_measure = eff_measure, eff_jacobian = eff_jacobian, ...)
-  }
+  treatment_effect(pc, pair = pair, variance = variance, eff_measure = eff_measure, eff_jacobian = eff_jacobian, ...)
 }
 
 #' @export
 treatment_effect.glm <- function(
     object, pair, variance = gvcov, eff_measure, eff_jacobian,
-    treatment, data = find_data(object), ...) {
+    treatment, vcov_args = list(), data = find_data(object), ...) {
   pc <- predict_counterfactual(object, treatment, data)
-  if (missing(pair)) {
-    treatment_effect(pc, pair = , , variance = variance, eff_measure = eff_measure, eff_jacobian = eff_jacobian, ...)
-  } else {
-    treatment_effect(pc, pair, variance = variance, eff_measure = eff_measure, eff_jacobian = eff_jacobian, ...)
-  }
+  treatment_effect(pc, pair = pair, variance = variance, eff_measure = eff_measure, eff_jacobian = eff_jacobian, ...)
 }
 
 #' @rdname treatment_effect
@@ -173,11 +179,18 @@ h_lower_tri_idx <- function(n) {
 print.treatment_effect <- function(x, ...) {
   cat("Treatment Effect\n")
   cat("-------------\n")
-  cat("Model        : ", deparse(attr(x, "fit")$formula), "\n")
+  cat("Model        : ", deparse(as.formula(attr(x, "fit"))), "\n")
   cat("Randomization: ", deparse(attr(x, "treatment")), "\n")
+  cat("Marginal Mean: \n")
+  print(attr(x, "marginal_mean"))
+
   cat("Variance Type: ", attr(x, "vartype"), "\n")
-  trt_sd <- sqrt(attr(x, "variance"))
-  z_value <- x / trt_sd
+  if (identical(attr(x, "vartype"), "none")) {
+    trt_sd <- rep(NA, length(x))
+  } else {
+    trt_sd <- sqrt(attr(x, "variance"))
+  }
+  z_value <- as.numeric(x) / trt_sd
   p <- 2 * pnorm(abs(z_value), lower.tail = FALSE)
   coef_mat <- matrix(
     c(
@@ -194,5 +207,5 @@ print.treatment_effect <- function(x, ...) {
     coef_mat,
     zap.ind = 3,
     digits = 3
-  )
+  )  
 }

tests/testthat/_snaps/treatment_effect.md

@@ -7,7 +7,13 @@
       -------------
       Model        :  y_b ~ treatment * s1 + covar 
       Randomization:  treatment ~ s1 
-      Variance Type:  variance 
+      Marginal Mean: 
+      counter-factual prediction
+      
+            pbo      trt1      trt2 
+      0.3560965 0.5806957 0.6213865 
+      
+      Variance Type:  function 
                   Estimate Std.Err Z Value  Pr(>z)    
       trt1 - pbo    0.2246  0.0477    4.71 2.5e-06 ***
       trt2 - pbo    0.2653  0.0475    5.58 2.4e-08 ***
@@ -22,13 +28,63 @@
     Output
       Treatment Effect
       -------------
-      Model        :  NULL 
+      Model        :  y ~ treatment * s1 + covar 
       Randomization:  treatment ~ s1 
-      Variance Type:  variance 
+      Marginal Mean: 
+      counter-factual prediction
+      
+            pbo      trt1      trt2 
+      0.2003208 0.7639709 0.9712499 
+      
+      Variance Type:  function 
                   Estimate Std.Err Z Value  Pr(>z)    
       trt1 - pbo     0.564   0.101    5.60 2.2e-08 ***
       trt2 - pbo     0.771   0.101    7.61 2.8e-14 ***
       trt2 - trt1    0.207   0.107    1.94   0.052 .  
       ---
       Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
 
+# treatment_effect works if variance is not used
+
+    Code
+      treatment_effect(fit_binom, treatment = treatment ~ s1, eff_measure = h_diff,
+      variance = NULL)
+    Output
+      Treatment Effect
+      -------------
+      Model        :  y_b ~ treatment * s1 + covar 
+      Randomization:  treatment ~ s1 
+      Marginal Mean: 
+      counter-factual prediction
+      
+            pbo      trt1      trt2 
+      0.3560965 0.5806957 0.6213865 
+      
+      Variance Type:  none 
+                  Estimate Std.Err Z Value Pr(>z)
+      trt1 - pbo    0.2246      NA      NA     NA
+      trt2 - pbo    0.2653      NA      NA     NA
+      trt2 - trt1   0.0407      NA      NA     NA
+
+# treatment_effect works if pair is integer
+
+    Code
+      treatment_effect(fit_binom, pair = c(1, 2), treatment = treatment ~ s1,
+      eff_measure = h_diff)
+    Output
+      Treatment Effect
+      -------------
+      Model        :  y_b ~ treatment * s1 + covar 
+      Randomization:  treatment ~ s1 
+      Marginal Mean: 
+      counter-factual prediction
+      
+            pbo      trt1      trt2 
+      0.3560965 0.5806957 0.6213865 
+      
+      Variance Type:  function 
+                 Estimate Std.Err Z Value  Pr(>z)    
+      trt1 - pbo   0.2246  0.0477    4.71 2.5e-06 ***
+      ---
+      Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
+

tests/testthat/_snaps/variance.md

@@ -8,6 +8,16 @@
       trt1  4.523445e-07  1.164889e-03 -7.709031e-07
       trt2 -9.709004e-06 -7.709031e-07  1.170214e-03
 
+---
+
+    Code
+      vcovHC(pc)
+    Output
+                     pbo          trt1          trt2
+      pbo   1.106024e-03  4.523445e-07 -9.709004e-06
+      trt1  4.523445e-07  1.164889e-03 -7.709031e-07
+      trt2 -9.709004e-06 -7.709031e-07  1.170214e-03
+
 # gvcov works
 
     Code
@@ -21,7 +31,37 @@
 ---
 
     Code
-      gvcov(pc, randomization = "permute_block")
+      gvcov(pc)
+    Output
+                    pbo         trt1         trt2
+      pbo  1.128902e-03 1.856234e-05 1.333885e-05
+      trt1 1.856234e-05 1.184599e-03 2.178112e-05
+      trt2 1.333885e-05 2.178112e-05 1.157268e-03
+
+---
+
+    Code
+      gvcov(pc)
+    Output
+                    pbo         trt1         trt2
+      pbo  1.128902e-03 1.856234e-05 1.333885e-05
+      trt1 1.856234e-05 1.184599e-03 2.178112e-05
+      trt2 1.333885e-05 2.178112e-05 1.157268e-03
+
+---
+
+    Code
+      gvcov(pc, decompose = FALSE)
+    Output
+                    pbo         trt1         trt2
+      pbo  1.127076e-03 1.856234e-05 1.333885e-05
+      trt1 1.856234e-05 1.179430e-03 2.178112e-05
+      trt2 1.333885e-05 2.178112e-05 1.164046e-03
+
+---
+
+    Code
+      gvcov(pc)
     Output
                     pbo         trt1         trt2
       pbo  1.128902e-03 1.856234e-05 1.333885e-05

tests/testthat/test-robin_glm.R

@@ -14,7 +14,7 @@ test_that("robin_glm works correctly", {
     robin_glm(
       y ~ treatment * s1,
       data = dummy_data, treatment = treatment ~ s1,
-      contrast = "difference", vcov = vcovHC
+      contrast = "difference", vcov = "vcovHC"
     )
   )
   expect_silent(robin_glm(y_b ~ treatment * s1, data = dummy_data, treatment = treatment ~ s1, contrast = "difference"))
@@ -24,9 +24,23 @@ test_that("robin_glm works correctly", {
     robin_glm(
       y_b ~ treatment * s1,
       data = dummy_data, treatment = treatment ~ s1,
-      contrast = "odds_ratio", vcov = vcovHC
+      contrast = "odds_ratio", vcov = "vcovHC"
     ),
     "Huber-White variance estimator is ONLY"
   )
   expect_silent(robin_glm(y_b ~ treatment * s1, data = dummy_data, treatment = treatment ~ s1, contrast = h_diff))
 })
+
+
+test_that("robin_glm works for glm.nb", {
+  dummy_data2 <- dummy_data
+  dummy_data2$y_b <- rep(seq_len(10), nrow(dummy_data2) / 10)
+  expect_silent(
+    robin_glm(
+      y_b ~ treatment * s1,
+      data = dummy_data2, treatment = treatment ~ s1,
+      family = MASS::negative.binomial(theta = NA),
+      contrast = "difference", vcov = "vcovHC"
+    )
+  )
+})