Fix the link-scale footer text for transform, and the transform = exp error in estimate_contrasts()

DESCRIPTION

@@ -1,7 +1,7 @@
 Type: Package
 Package: modelbased
 Title: Estimation of Model-Based Predictions, Contrasts and Means
-Version: 0.17.0.17
+Version: 0.17.0.18
 Authors@R:
     c(person(given = "Dominique",
              family = "Makowski",

NEWS.md

@@ -59,6 +59,17 @@
 
 ## Bug fixes
 
+* For non-linear models, the footer of predictions or contrasts on the
+  link-scale no longer says "FALSE-transformed" or "TRUE-transformed". This
+  footer appears, for example, with `estimate_link()`, or with
+  `estimate_means()` and `predict = "link"`. Without `transform`, the footer
+  now says "link-scale". Except with `backend = "emmeans"`, a function as
+  `transform` gives "transformed link-scale". `estimate_contrasts()` with
+  `predict = "link"` and a function as `transform` (for example
+  `transform = exp`) no longer fails with an error. If the output of an
+  earlier call is the `data` argument, the footer of `estimate_expectation()`,
+  `estimate_prediction()` and `estimate_link()` now names the right scale.
+
 * With `backend = "marginaleffects"`, `estimate_means()`, `estimate_slopes()`
   and `estimate_contrasts()` no longer drop or rename a `by` variable with a
   name such as `type`, `n` or `value`. They also no longer mislabel other

R/estimate_predicted.R

@@ -583,6 +583,7 @@ estimate_relation <- function(
   attr(out, "keep_iterations") <- keep_iterations
   attr(out, "response") <- model_response
   attr(out, "transform") <- !is.null(transform)
+  attr(out, "transform_arg") <- transform
   attr(out, "model") <- model
   attr(out, "datagrid") <- data
   attr(out, "focal_terms") <- grid_specs$at_specs$varname
@@ -598,7 +599,12 @@ estimate_relation <- function(
   if (is.null(footer_predict)) {
     footer_predict <- predict
   }
-  footer_info <- c(grid_specs, list(predict = predict), transform = !is.null(transform))
+  # an earlier output passed as `data` has its own "predict" and "transform"
+  # attributes in `grid_specs`, so we replace them with those of this call
+  footer_info <- grid_specs
+  footer_info$predict <- predict
+  footer_info$transform <- !is.null(transform)
+  footer_info$transform_arg <- transform
   footer_info$predict_used <- footer_predict
   attr(out, "table_footer") <- .table_footer(
     out,
@@ -610,7 +616,7 @@ estimate_relation <- function(
 
   attributes(out) <- c(
     attributes(out),
-    grid_specs[!names(grid_specs) %in% names(attributes(out))]
+    grid_specs[!names(grid_specs) %in% c(names(attributes(out)), "transform_arg")]
   )
 
   # Class

R/get_marginalcontrasts.R

@@ -184,6 +184,7 @@ get_marginalcontrasts <- function(
       contrast = my_args$contrast,
       predict = predict,
       transform = transform,
+      transform_arg = transform,
       comparison = my_args$comparison,
       estimate = estimate,
       p_adjust = p_adjust,

R/get_marginalmeans.R

@@ -238,7 +238,9 @@ get_marginalmeans <- function(
     fun_args$vcov <- FALSE
   }
 
-  # transform reponse?
+  # transform response? we keep the argument as passed by the user for the
+  # table footer
+  transform_arg <- transform
   if (isTRUE(transform)) {
     transform <- insight::get_transformation(model, verbose = FALSE)$inverse
   }
@@ -318,6 +320,7 @@ get_marginalmeans <- function(
         estimate = estimate,
         datagrid = datagrid,
         transform = !is.null(transform),
+        transform_arg = transform_arg,
         iterations = iterations,
         keep_iterations = keep_iterations,
         joint_test = joint_test,
@@ -665,6 +668,8 @@ get_marginalmeans <- function(
 # - slope: the type of slope, e.g. "dx/dy". equals the "slope" argument when
 #   calling avg_slopes()
 # - model_info: object from insight::model_info()
+# - transform_arg: the `transform` argument as passed by the user (`transform`
+#   is often only a logical), used for the scale line of the table footer
 # - renamed_focal: focal terms with the name of an output column, named by
 #   their old names, with the new names "<name>.1" as values
 #' @keywords internal
@@ -696,8 +701,8 @@ get_marginalmeans <- function(
   # fmt: skip
   c(
     "at", "by", "focal_terms", "adjusted_for", "predict", "trend", "comparison",
-    "contrast", "estimate", "p_adjust", "transform", "datagrid", "preserve_range",
-    "coef_name", "slope", "ci", "model_info", "contrast_filter", "null",
+    "contrast", "estimate", "p_adjust", "transform", "transform_arg", "datagrid",
+    "preserve_range", "coef_name", "slope", "ci", "model_info", "contrast_filter", "null",
     "iterations", "keep_iterations", "joint_test", "omnibus_test", "vcov",
     "equivalence", "context_effects", "renamed_focal"
   )

R/table_footer.R

@@ -131,9 +131,10 @@
       predict
     )
     # we may have link-scale and transformation. to avoid confusion, tell this
-    # here
-    if (predict == "link" && !is.null(transform)) {
-      predict <- paste0(transform, "-transformed ", predict)
+    # here. `info$transform` is often only a logical (and always `TRUE` for
+    # emmeans), so we use the `transform` argument as passed by the user
+    if (predict == "link") {
+      predict <- .link_transform_label(info$transform_arg, model)
     }
     # if we have contrasts of slope for GLMs, the default is to calculate
     # ORs or IRRs - in this case, we don't add information about the scale
@@ -225,6 +226,29 @@
 }
 
 
+# name of the link-scale, including a transformation -------------------------
+
+.link_transform_label <- function(transform, model = NULL) {
+  if (is.character(transform) && length(transform) == 1) {
+    # transformation given by name, like "exp"
+    paste0(transform, "-transformed link")
+  } else if (is.function(transform)) {
+    "transformed link"
+  } else if (isTRUE(transform)) {
+    # `transform = TRUE` applies the inverse of the response transformation,
+    # which changes nothing if the response is not transformed
+    trans_fun <- .safe(insight::find_transformation(model))
+    if (is.null(trans_fun) || all(trans_fun == "identity")) {
+      "link"
+    } else {
+      "transformed link"
+    }
+  } else {
+    "link"
+  }
+}
+
+
 # Table footer slopes =========================================================
 
 .table_footer_slopes <- function(x, model = NULL, info = NULL) {

tests/testthat/test-table_footer.R

@@ -53,6 +53,108 @@ test_that("table_footer, prediction intervals", {
 })
 
 
+test_that("table_footer, link-scale without transform", {
+  d <- mtcars
+  d$cyl <- factor(d$cyl)
+  g <- glm(am ~ wt + cyl, data = d, family = binomial)
+  pred_line <- "Predictions are on the link-scale."
+  contr_line <- "Contrasts are on the link-scale."
+
+  out <- utils::capture.output(estimate_link(g, by = "cyl"))
+  expect_true(pred_line %in% out)
+  for (backend in c("marginaleffects", "emmeans")) {
+    out <- utils::capture.output(
+      estimate_means(g, "cyl", predict = "link", backend = backend)
+    )
+    expect_true(pred_line %in% out)
+    out <- utils::capture.output(
+      estimate_contrasts(g, "cyl", predict = "link", backend = backend)
+    )
+    expect_true(contr_line %in% out)
+  }
+})
+
+
+test_that("table_footer, link-scale with transform", {
+  d <- mtcars
+  d$cyl <- factor(d$cyl)
+  g <- glm(am ~ wt + cyl, data = d, family = binomial)
+
+  # a transformation function
+  out <- utils::capture.output(
+    estimate_contrasts(g, "cyl", predict = "link", transform = exp)
+  )
+  expect_true("Contrasts are on the transformed link-scale." %in% out)
+  out <- utils::capture.output(estimate_link(g, by = "cyl", transform = exp))
+  expect_true("Predictions are on the transformed link-scale." %in% out)
+  out <- utils::capture.output(
+    estimate_means(g, "cyl", predict = "link", transform = exp)
+  )
+  expect_true("Predictions are on the transformed link-scale." %in% out)
+
+  # transform = TRUE
+  out <- utils::capture.output(estimate_link(g, by = "cyl", transform = TRUE))
+  expect_false(any(grepl("TRUE-transformed|FALSE-transformed", out)))
+  # the response is not transformed, so `transform = TRUE` changes nothing
+  out <- utils::capture.output(
+    estimate_means(g, "cyl", predict = "link", transform = TRUE)
+  )
+  expect_true("Predictions are on the link-scale." %in% out)
+
+  # name of the transformation
+  out <- utils::capture.output(
+    estimate_contrasts(g, "cyl", predict = "link", transform = "exp")
+  )
+  expect_true("Contrasts are on the exp-transformed link-scale." %in% out)
+})
+
+
+test_that("table_footer, scale of predictions with earlier output as data", {
+  d <- mtcars
+  d$cyl <- factor(d$cyl)
+  g <- glm(am ~ wt + cyl, data = d, family = binomial)
+  resp_line <- "Predictions are on the response-scale."
+
+  out <- utils::capture.output(
+    estimate_expectation(g, data = estimate_link(g, by = "cyl"))
+  )
+  expect_true(resp_line %in% out)
+  out <- utils::capture.output(
+    estimate_prediction(g, data = estimate_link(g, by = "cyl"))
+  )
+  expect_true(resp_line %in% out)
+  out <- utils::capture.output(
+    estimate_link(g, data = estimate_expectation(g, by = "cyl"))
+  )
+  expect_true("Predictions are on the link-scale." %in% out)
+})
+
+
+test_that("table_footer, link-scale for contrasts of predictions and slopes", {
+  d <- mtcars
+  d$cyl <- factor(d$cyl)
+  g <- glm(am ~ wt + cyl, data = d, family = binomial)
+
+  # contrasts of an earlier output
+  out <- utils::capture.output(estimate_contrasts(estimate_link(g, by = "cyl")))
+  expect_true("Contrasts are on the link-scale." %in% out)
+  out <- utils::capture.output(
+    estimate_contrasts(estimate_link(g, by = "cyl", transform = exp))
+  )
+  expect_true("Contrasts are on the transformed link-scale." %in% out)
+
+  # contrasts of slopes
+  out <- utils::capture.output(
+    estimate_contrasts(g, "wt", by = "cyl", predict = "link")
+  )
+  expect_true("Contrasts are on the link-scale." %in% out)
+  out <- utils::capture.output(
+    estimate_contrasts(g, "wt", by = "cyl", predict = "link", transform = exp)
+  )
+  expect_true("Contrasts are on the transformed link-scale." %in% out)
+})
+
+
 test_that("table_footer, no prediction intervals if insight falls back", {
   skip_if_not_installed("mgcv")
   m <- mgcv::gam(mpg ~ s(wt), data = mtcars)