fix: make sure the decoration is applied to the forest plots

[vedhav]

Fixes the Forest plot module decorators mentioned here

• ❌ tm_g_forest_rsp - plot (ggplot2) [plot decorator does not seem to work]
• ❌ tm_g_forest_tte - plot (ggplot2) [plot decorator does not seem to work]

Example app to test

# Load packages
pkgload::load_all()

caption_decorator <- function(default_caption = "I am a good decorator", .var_to_replace = "plot") {
  teal_transform_module(
    label = "Caption",
    ui = function(id) shiny::textInput(shiny::NS(id, "footnote"), "Footnote", value = default_caption),
    server = make_teal_transform_server(
      substitute(
        {
          .var_to_replace <- .var_to_replace + ggplot2::labs(caption = footnote)
        },
        env = list(.var_to_replace = as.name(.var_to_replace))
      )
    )
  )
}

library(dplyr)

# arm_ref_comp <- list(ARMCD = list(ref = "ARM B", comp = c("ARM A", "ARM C")))

arm_ref_comp <- list(
  ACTARMCD = list(ref = "ARM B", comp = c("ARM A", "ARM C")),
  ARM = list(ref = "B: Placebo", comp = c("A: Drug X", "C: Combination"))
)

data <- within(teal_data(), {
  ADSL <- tmc_ex_adsl |>
    mutate(ITTFL = factor("Y") |> with_label("Intent-To-Treat Population Flag")) |>
    mutate(DTHFL = case_when(!is.na(DTHDT) ~ "Y", TRUE ~ "") |> with_label("Subject Death Flag"))

  ADAE <- tmc_ex_adae |>
    filter(!((AETOXGR == 1) & (AESEV == "MILD") & (ARM == "A: Drug X")))

  ADAE$ASTDY <- structure(
    as.double(ADAE$ASTDY, unit = attr(ADAE$ASTDY, "units", exact = TRUE)),
    label = attr(ADAE$ASTDY, "label", exact = TRUE)
  )

  .lbls_adae <- col_labels(tmc_ex_adae)
  ADAE <- tmc_ex_adae %>%
    mutate_if(is.character, as.factor) #' be certain of having factors
  col_labels(ADAE) <- .lbls_adae

  ADTTE <- tmc_ex_adtte

  ADLB <- tmc_ex_adlb |>
    mutate(AVISIT == forcats::fct_reorder(AVISIT, AVISITN, min)) |>
    mutate(
      ONTRTFL = case_when(
        AVISIT %in% c("SCREENING", "BASELINE") ~ "",
        TRUE ~ "Y"
      ) |> with_label("On Treatment Record Flag")
    )

  ADVS <- tmc_ex_advs

  ADRS <- tmc_ex_adrs |>
    mutate(
      AVALC = d_onco_rsp_label(AVALC) |>
        with_label("Character Result/Finding")
    ) |>
    filter(PARAMCD != "OVRINV" | AVISIT == "FOLLOW UP") |>
    filter(PARAMCD %in% c("BESRSPI", "INVET"))

  ADAETTE <- tmc_ex_adaette %>%
    filter(PARAMCD %in% c("AETTE1", "AETTE2", "AETTE3")) %>%
    mutate(is_event = CNSR == 0) %>%
    mutate(n_events = as.integer(is_event))

  .add_event_flags <- function(dat) {
    dat <- dat %>%
      mutate(
        TMPFL_SER = AESER == "Y",
        TMPFL_REL = AEREL == "Y",
        TMPFL_GR5 = AETOXGR == "5",
        TMP_SMQ01 = !is.na(SMQ01NAM),
        TMP_SMQ02 = !is.na(SMQ02NAM),
        TMP_CQ01 = !is.na(CQ01NAM)
      )
    column_labels <- list(
      TMPFL_SER = "Serious AE",
      TMPFL_REL = "Related AE",
      TMPFL_GR5 = "Grade 5 AE",
      TMP_SMQ01 = aesi_label(dat[["SMQ01NAM"]], dat[["SMQ01SC"]]),
      TMP_SMQ02 = aesi_label("Y.9.9.9.9/Z.9.9.9.9 AESI"),
      TMP_CQ01 = aesi_label(dat[["CQ01NAM"]])
    )
    col_labels(dat)[names(column_labels)] <- as.character(column_labels)
    dat
  }

  ADEX <- tmc_ex_adex

  set.seed(1, kind = "Mersenne-Twister")
  .labels <- col_labels(ADEX, fill = FALSE)
  ADEX <- ADEX %>%
    distinct(USUBJID, .keep_all = TRUE) %>%
    mutate(
      PARAMCD = "TDURD",
      PARAM = "Overall duration (days)",
      AVAL = sample(x = seq(1, 200), size = n(), replace = TRUE),
      AVALU = "Days"
    ) %>%
    bind_rows(ADEX)
  col_labels(ADEX) <- .labels

  ADCM <- tmc_ex_adcm

  ADMH <- tmc_ex_admh

  ADCM$CMASTDTM <- ADCM$ASTDTM
  ADCM$CMAENDTM <- ADCM$AENDTM

  ADEG <- tmc_ex_adeg

  # smq
  .names_baskets <- grep("^(SMQ|CQ).*NAM$", names(ADAE), value = TRUE)
  .names_scopes <- grep("^SMQ.*SC$", names(ADAE), value = TRUE)

  .cs_baskets <- choices_selected(
    choices = variable_choices(ADAE, subset = .names_baskets),
    selected = .names_baskets
  )

  .cs_scopes <- choices_selected(
    choices = variable_choices(ADAE, subset = .names_scopes),
    selected = .names_scopes,
    fixed = TRUE
  )

  # summary
  ADSL$EOSDY[1] <- NA_integer_
  ADQS <- tmc_ex_adqs %>%
    filter(ABLFL != "Y" & ABLFL2 != "Y") %>%
    mutate(
      AVISIT = as.factor(AVISIT),
      AVISITN = rank(AVISITN) %>%
        as.factor() %>%
        as.numeric() %>%
        as.factor(),
      AVALBIN = AVAL < 50 # Just as an example to get a binary endpoint.
    ) %>%
    droplevels()
})
join_keys(data) <- default_cdisc_join_keys[names(data)]
adcm_keys <- c("STUDYID", "USUBJID", "ASTDTM", "CMSEQ", "ATC1", "ATC2", "ATC3", "ATC4")
join_keys(data)["ADCM", "ADCM"] <- adcm_keys

# Use in choices selected -----------------------------------------------------

ADSL <- data[["ADSL"]]
ADQS <- data[["ADQS"]]
ADAE <- data[["ADAE"]]
ADTTE <- data[["ADTTE"]]
ADLB <- data[["ADLB"]]
ADAE <- data[["ADAE"]]
ADVS <- data[["ADVS"]]
ADRS <- data[["ADRS"]]
ADAETTE <- data[["ADAETTE"]]
ADEX <- data[["ADEX"]]
ADCM <- data[["ADCM"]]
ADMH <- data[["ADMH"]]
ADEG <- data[["ADEG"]]

# Init ------------------------------------------------------------------------

insert_rrow_decorator <- function(default_caption = "I am a good new row", .var_to_replace = "table") {
  teal_transform_module(
    label = "New rtables row",
    ui = function(id) shiny::textInput(shiny::NS(id, "new_row"), "New row", value = default_caption),
    server = make_teal_transform_server(
      substitute(
        {
          .var_to_replace <- rtables::insert_rrow(.var_to_replace, rtables::rrow(new_row))
        },
        env = list(.var_to_replace = as.name(.var_to_replace))
      )
    )
  )
}

pkgload::load_all()
init(
  data = data,
  modules = modules(
    tm_g_forest_rsp(
      label = "tm_g_forest_rsp",
      dataname = "ADRS",
      arm_var = choices_selected(
        variable_choices(ADSL, c("ARM", "ARMCD")),
        "ARMCD"
      ),
      arm_ref_comp = arm_ref_comp,
      paramcd = choices_selected(
        value_choices(ADRS, "PARAMCD", "PARAM"),
        "INVET"
      ),
      subgroup_var = choices_selected(
        variable_choices(ADSL, names(ADSL)),
        c("BMRKR2", "SEX")
      ),
      strata_var = choices_selected(
        variable_choices(ADSL, c("STRATA1", "STRATA2")),
        "STRATA2"
      ),
      plot_height = c(600L, 200L, 2000L),
      default_responses = list(
        BESRSPI = list(
          rsp = c("Stable Disease (SD)", "Not Evaluable (NE)"),
          levels = c(
            "Complete Response (CR)", "Partial Response (PR)", "Stable Disease (SD)",
            "Progressive Disease (PD)", "Not Evaluable (NE)"
          )
        ),
        INVET = list(
          rsp = c("Complete Response (CR)", "Partial Response (PR)"),
          levels = c(
            "Complete Response (CR)", "Not Evaluable (NE)", "Partial Response (PR)",
            "Progressive Disease (PD)", "Stable Disease (SD)"
          )
        ),
        OVRINV = list(
          rsp = c("Progressive Disease (PD)", "Stable Disease (SD)"),
          levels = c("Progressive Disease (PD)", "Stable Disease (SD)", "Not Evaluable (NE)")
        )
      ),
      decorators = list(plot = caption_decorator())
    ),
    tm_g_forest_tte(
      label = "tm_g_forest_tte",
      dataname = "ADTTE",
      arm_var = choices_selected(
        variable_choices(ADSL, c("ARM", "ARMCD")),
        "ARMCD"
      ),
      arm_ref_comp = arm_ref_comp,
      paramcd = choices_selected(
        value_choices(ADTTE, "PARAMCD", "PARAM"),
        "OS"
      ),
      subgroup_var = choices_selected(
        variable_choices(ADSL, names(ADSL)),
        c("BMRKR2", "SEX")
      ),
      strata_var = choices_selected(
        variable_choices(ADSL, c("STRATA1", "STRATA2")),
        "STRATA2"
      ),
      decorators = list(plot = caption_decorator())
    )
  )
) |> shiny::runApp()

[github-actions]

Unit Tests Summary

    1 files     70 suites   1h 11m 6s ⏱️
  726 tests   614 ✅ 112 💤 0 ❌
1 986 runs  1 759 ✅ 227 💤 0 ❌

Results for commit 811efb1.

♻️ This comment has been updated with latest results.

[m7pr]

well done

[github-actions]

Unit Test Performance Difference

Test Suite	$Status$	Time on main	$±Time$	$±Tests$	$±Skipped$	$±Failures$	$±Errors$
shinytest2-tm_a_mmrm	💚	$750.58$	$-6.08$	$0$	$0$	$0$	$0$
shinytest2-tm_g_barchart_simple	💚	$233.51$	$-2.12$	$0$	$0$	$0$	$0$
shinytest2-tm_g_forest_rsp	💚	$181.10$	$-1.99$	$0$	$0$	$0$	$0$
shinytest2-tm_g_ipp	💚	$113.02$	$-1.73$	$0$	$0$	$0$	$0$
shinytest2-tm_g_km	💚	$278.20$	$-2.37$	$0$	$0$	$0$	$0$
shinytest2-tm_g_lineplot	💚	$89.37$	$-1.27$	$0$	$0$	$0$	$0$
shinytest2-tm_g_pp_adverse_events	💚	$127.85$	$-1.20$	$0$	$0$	$0$	$0$
shinytest2-tm_g_pp_patient_timeline	💚	$250.05$	$-3.10$	$0$	$0$	$0$	$0$
shinytest2-tm_g_pp_vitals	💚	$89.91$	$-1.34$	$0$	$0$	$0$	$0$
shinytest2-tm_t_abnormality_by_worst_grade	💚	$69.75$	$-1.35$	$0$	$0$	$0$	$0$
shinytest2-tm_t_pp_laboratory	💚	$129.33$	$-1.10$	$0$	$0$	$0$	$0$
shinytest2-tm_t_pp_medical_history	💚	$69.12$	$-1.09$	$0$	$0$	$0$	$0$

Additional test case details

Test Suite	$Status$	Time on main	$±Time$	Test Case
shinytest2-tm_g_forest_rsp	💚	$10.47$	$-1.19$	e2e_tm_g_forest_rsp_Changing_rel_width_forest_changes_plot_and_doesn_t_throw_validation_errors.

Results for commit 2396e04

♻️ This comment has been updated with latest results.