Skip to content

Commit

Permalink
301 delayed variable_choices for facet_var in tm_g_gh_boxplot (#313)
Browse files Browse the repository at this point in the history 
Solution for #301 

<details><summary> Working example </summary>

```r
pkgload::load_all(".")
data <- teal_data_module(
  ui <- function(id) {
    ns <- NS(id)
    actionButton(ns("submit"), "Submit")
  },
  server = function(id) {
    moduleServer(id, function(input, output, session) {
      eventReactive(input$submit, {
        data <- within(
          teal_data(),
          {
            ADLB <- teal.data::rADLB
            ADSL <- teal.data::rADSL
            
            library(dplyr)
            library(nestcolor)
            library(stringr)
            #'
            # use non-exported function from goshawk
            h_identify_loq_values <- getFromNamespace("h_identify_loq_values", "goshawk")
            #'
            # original ARM value = dose value
            arm_mapping <- list(
              "A: Drug X" = "150mg QD",
              "B: Placebo" = "Placebo",
              "C: Combination" = "Combination"
            )
            set.seed(1)
            ADSL <- rADSL
            ADLB <- rADLB
            var_labels <- lapply(ADLB, function(x) attributes(x)$label)
            ADLB <- ADLB %>%
              mutate(
                AVISITCD = case_when(
                  AVISIT == "SCREENING" ~ "SCR",
                  AVISIT == "BASELINE" ~ "BL",
                  grepl("WEEK", AVISIT) ~ paste("W", str_extract(AVISIT, "(?<=(WEEK ))[0-9]+")),
                  TRUE ~ as.character(NA)
                ),
                AVISITCDN = case_when(
                  AVISITCD == "SCR" ~ -2,
                  AVISITCD == "BL" ~ 0,
                  grepl("W", AVISITCD) ~ as.numeric(gsub("[^0-9]*", "", AVISITCD)),
                  TRUE ~ as.numeric(NA)
                ),
                AVISITCD = factor(AVISITCD) %>% reorder(AVISITCDN),
                TRTORD = case_when(
                  ARMCD == "ARM C" ~ 1,
                  ARMCD == "ARM B" ~ 2,
                  ARMCD == "ARM A" ~ 3
                ),
                ARM = as.character(arm_mapping[match(ARM, names(arm_mapping))]),
                ARM = factor(ARM) %>% reorder(TRTORD),
                ACTARM = as.character(arm_mapping[match(ACTARM, names(arm_mapping))]),
                ACTARM = factor(ACTARM) %>% reorder(TRTORD),
                ANRLO = 50,
                ANRHI = 75
              ) %>%
              rowwise() %>%
              group_by(PARAMCD) %>%
              mutate(LBSTRESC = ifelse(
                USUBJID %in% sample(USUBJID, 1, replace = TRUE),
                paste("<", round(runif(1, min = 25, max = 30))), LBSTRESC
              )) %>%
              mutate(LBSTRESC = ifelse(
                USUBJID %in% sample(USUBJID, 1, replace = TRUE),
                paste(">", round(runif(1, min = 70, max = 75))), LBSTRESC
              )) %>%
              ungroup()
            #'
            attr(ADLB[["ARM"]], "label") <- var_labels[["ARM"]]
            attr(ADLB[["ACTARM"]], "label") <- var_labels[["ACTARM"]]
            attr(ADLB[["ANRLO"]], "label") <- "Analysis Normal Range Lower Limit"
            attr(ADLB[["ANRHI"]], "label") <- "Analysis Normal Range Upper Limit"
            #'
            # add LLOQ and ULOQ variables
            ALB_LOQS <- h_identify_loq_values(ADLB, "LOQFL")
            ADLB <- left_join(ADLB, ALB_LOQS, by = "PARAM")
            
          }
        )
        datanames <- c("ADLB", "ADSL")
        
        datanames(data) <- datanames
        join_keys(data) <- default_cdisc_join_keys[datanames]
        data
      })
    })
  }
)

# functional subset
cs_facet_var <- choices_selected(
  choices = variable_choices("ADLB", function(data) {
    na.omit(unique(c("ARM", "AVISITCD", names(data)[26:193])))
  }),
  selected = "AVISITCD"
)

app <- init(
  data = data,
  modules = modules(
    tm_g_gh_boxplot(
      label = "Box Plot",
      dataname = "ADLB",
      param_var = "PARAMCD",
      param = choices_selected(c("ALT", "CRP", "IGA"), "ALT"),
      yaxis_var = choices_selected(c("AVAL", "BASE", "CHG"), "AVAL"),
      xaxis_var = choices_selected(c("ACTARM", "ARM", "AVISITCD", "STUDYID"), "ARM"),
      facet_var = cs_facet_var,
      trt_group = choices_selected(c("ARM", "ACTARM"), "ARM"),
      loq_legend = TRUE,
      rotate_xlab = FALSE,
      hline_arb = c(60, 55),
      hline_arb_color = c("grey", "red"),
      hline_arb_label = c("default_hori_A", "default_hori_B"),
      hline_vars = c("ANRHI", "ANRLO", "ULOQN", "LLOQN"),
      hline_vars_colors = c("pink", "brown", "purple", "black"),
    )
  ),
  title = "my teal app"
)

shinyApp(app$ui, app$server)
```

</details>

---------

Co-authored-by: github-actions <41898282+github-actions[bot]@users.noreply.github.com>
  • Loading branch information
@m7pr @github-actions
m7pr and github-actions[bot] authored Oct 7, 2024
1 parent 95a68c3 commit ddfb6d3
Show file tree
Hide file tree
Showing 2 changed files with 20 additions and 11 deletions.
18 changes: 7 additions & 11 deletions R/tm_g_gh_boxplot.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -207,7 +207,6 @@ tm_g_gh_boxplot <- function(label,
dataname = dataname,
param_var = param_var,
trt_group = trt_group,
facet_var = facet_var,
color_manual = color_manual,
shape_manual = shape_manual,
plot_height = plot_height,
Expand Down Expand Up @@ -256,13 +255,6 @@ ui_g_boxplot <- function(id, ...) {
multiple = FALSE
),
uiOutput(ns("axis_selections")),
teal.widgets::optionalSelectInput(
ns("facet_var"),
label = "Facet by",
choices = get_choices(a$facet_var$choices),
selected = a$facet_var$selected,
multiple = FALSE
),
templ_ui_constraint(ns, label = "Data Constraint"), # required by constr_anl_q
if (length(a$hline_vars) > 0) {
teal.widgets::optionalSelectInput(
Expand Down Expand Up @@ -312,7 +304,6 @@ srv_g_boxplot <- function(id,
dataname,
param_var,
trt_group,
facet_var,
color_manual,
shape_manual,
plot_height,
Expand All @@ -331,6 +322,8 @@ srv_g_boxplot <- function(id,
resolved_x <- teal.transform::resolve_delayed(module_args$xaxis_var, env)
resolved_y <- teal.transform::resolve_delayed(module_args$yaxis_var, env)
resolved_param <- teal.transform::resolve_delayed(module_args$param, env)
resolved_facet_var <- teal.transform::resolve_delayed(module_args$facet_var, env)

templ_ui_params_vars(
session$ns,
xparam_choices = resolved_param$choices,
Expand All @@ -339,7 +332,9 @@ srv_g_boxplot <- function(id,
xchoices = resolved_x$choices,
xselected = resolved_x$selected,
ychoices = resolved_y$choices,
yselected = resolved_y$selected
yselected = resolved_y$selected,
facet_choices = resolved_facet_var$choices,
facet_selected = resolved_facet_var$selected
)
})
# reused in all modules
Expand Down Expand Up @@ -477,6 +472,7 @@ srv_g_boxplot <- function(id,
xaxis_var <- input$yaxis_var # nolint
font_size <- input$font_size
trt_group <- input$trt_group
facet_var <- input$facet_var

anl_q()$qenv %>% teal.code::eval_code(
code = bquote({
Expand All @@ -486,7 +482,7 @@ srv_g_boxplot <- function(id,
param_var = .(param_var),
param = .(param),
xaxis_var = .(xaxis_var),
facet_var = .(input$facet_var)
facet_var = .(facet_var)
)
})
)
Expand Down
13 changes: 13 additions & 0 deletions R/utils-templ_ui.r
View file
Original file line number Diff line number Diff line change
Expand Up @@ -27,6 +27,10 @@ templ_ui_params_vars <- function(ns,
ychoices = NULL,
yselected = NULL,
yvar_label = NULL, # variable, e.g. AVAL
# facet_var
facet_choices = NULL,
facet_selected = NULL,

multiple = FALSE) {
if (is.null(xparam_choices) && !is.null(xchoices) && !is.null(yparam_choices)) {
# otherwise, xchoices will appear first without any biomarker to select and this looks odd in the UI
Expand Down Expand Up @@ -69,6 +73,15 @@ templ_ui_params_vars <- function(ns,
ychoices, yselected,
multiple = multiple
)
},
if (!is.null(facet_choices)) {
teal.widgets::optionalSelectInput(
ns("facet_var"),
label = "Facet by",
choices = facet_choices,
selected = facet_selected,
multiple = FALSE
)
}
)
}

0 comments on commit ddfb6d3

Please sign in to comment.