bp_1 <-ggplot(adlb, aes(x = ARMCD, y = AVAL)) +stat_summary(geom ="boxplot", fun.data = five_num, fill = fc, color = oc) +stat_summary(geom ="point", fun = mean, size =3, shape =8) +labs(title ="Box Plot of Laboratory Test Results",subtitle =paste("Visit:", adlb$AVISIT[1]),caption ="The whiskers extend to the minimum and maximum values.",x ="Treatment Group",y =paste0(adlb$PARAMCD[1], " (", adlb$AVALU[1], ")") ) + theme_bpplot <-bp_annos(bp_1, oc)plot
Experimental use!
WebR is a tool allowing you to run R code in the web browser. Modify the code below and click run to see the results. Alternatively, copy the code and click here to open WebR in a new tab.
bp_3 <-ggplot(adlb, aes(x = ARMCD, y = AVAL)) +stat_summary(geom ="boxplot", fun.data = five_num,fun.args =list(probs =c(0.05, 0.25, 0.5, 0.75, 0.95)), fill = fc, color = oc ) +stat_summary(geom ="point", fun = mean, size =3, shape =8) +labs(title ="Box Plot of Laboratory Test Results",subtitle =paste("Visit:", adlb$AVISIT[1]),caption ="The whiskers extend to the 5th and 95th percentile. Values outside the whiskers have not been plotted.",x ="Treatment Group",y =paste0(adlb$PARAMCD[1], " (", adlb$AVALU[1], ")") ) + theme_bpplot <-bp_annos(bp_3, oc)plot
Experimental use!
WebR is a tool allowing you to run R code in the web browser. Modify the code below and click run to see the results. Alternatively, copy the code and click here to open WebR in a new tab.
bp_4 <-ggplot(adlb, aes(x = ARMCD, y = AVAL)) +stat_summary(geom ="boxplot", fun.data = five_num,fun.args =list(probs =c(0.05, 0.25, 0.5, 0.75, 0.95)), fill = fc, color = oc ) +stat_summary(geom ="point", fun = get_outliers, shape =1) +stat_summary(geom ="point", fun = mean, size =3, shape =8) +labs(title ="Box Plot of Laboratory Test Results",subtitle =paste("Visit:", adlb$AVISIT[1]),caption ="The whiskers extend to the 5th and 95th percentile.",x ="Treatment Group",y =paste0(adlb$PARAMCD[1], " (", adlb$AVALU[1], ")") ) + theme_bpplot <-bp_annos(bp_4, oc)plot
Experimental use!
WebR is a tool allowing you to run R code in the web browser. Modify the code below and click run to see the results. Alternatively, copy the code and click here to open WebR in a new tab.
adlb_o <- adlb %>%group_by(ARMCD) %>%mutate(OUTLIER = AVAL <quantile(AVAL, 0.01) | AVAL >quantile(AVAL, 0.99)) %>%filter(OUTLIER ==TRUE) %>%select(ARMCD, AVAL, USUBJID)# Next step may be study-specific: shorten USUBJID to make annotation labels# next 2 lines of code split USUBJID by "-" and take the last syllable as IDn_split <-max(vapply(strsplit(adlb_o$USUBJID, "-"), length, numeric(1)))adlb_o$ID <-vapply(strsplit(adlb_o$USUBJID, "-"), `[[`, n_split, FUN.VALUE ="a")bp_5 <-ggplot(adlb, aes(x = ARMCD, y = AVAL)) +stat_summary(geom ="boxplot", fun.data = five_num,fun.args =list(probs =c(0.01, 0.25, 0.5, 0.75, 0.99)), fill = fc, color = oc ) +stat_summary(geom ="point", fun = mean, size =3, shape =8) +geom_point(data = adlb_o, aes(x = ARMCD, y = AVAL), shape =1) +geom_text(data = adlb_o, aes(x = ARMCD, y = AVAL, label = ID), size =3, hjust =-0.2) +labs(title ="Box Plot of Laboratory Test Results",subtitle =paste("Visit:", adlb$AVISIT[1]),caption ="The whiskers extend to the largest and smallest observed value within 1.5*IQR.",x ="Treatment Group",y =paste0(adlb$PARAMCD[1], " (", adlb$AVALU[1], ")") ) + theme_bpplot <-bp_annos(bp_5, oc)plot
Experimental use!
WebR is a tool allowing you to run R code in the web browser. Modify the code below and click run to see the results. Alternatively, copy the code and click here to open WebR in a new tab.
bp_6 <-ggplot(adlb, aes(x = ARMCD, y = AVAL)) +geom_boxplot(fill = fc, color = oc) +stat_summary(geom ="point", fun = mean, size =3, shape =5) +labs(title ="Box Plot of Laboratory Test Results",subtitle =paste("Visit:", adlb$AVISIT[1]),caption ="The whiskers extend to the minimum and maximum values.",x ="Treatment Group",y =paste0(adlb$PARAMCD[1], " (", adlb$AVALU[1], ")") ) + theme_bpplot <-bp_annos(bp_6, oc)plot
Experimental use!
WebR is a tool allowing you to run R code in the web browser. Modify the code below and click run to see the results. Alternatively, copy the code and click here to open WebR in a new tab.
adsl <- random.cdisc.data::cadsladlb <- random.cdisc.data::cadlbadlb_v <- adlb %>%filter(PARAMCD =="ALT"& AVISIT %in%c("WEEK 1 DAY 8", "WEEK 2 DAY 15", "WEEK 3 DAY 22", "WEEK 4 DAY 29"))bp_7 <-ggplot(adlb_v, aes(x = AVISIT, y = AVAL)) +stat_summary(geom ="boxplot",fun.data = five_num,position =position_dodge2(.5),aes(fill = ARMCD, color = ARMCD) ) +stat_summary(geom ="point",fun = mean,aes(group = ARMCD),size =3,shape =8,position =position_dodge2(1) ) +labs(title ="Box Plot of Laboratory Test Results",caption ="The whiskers extend to the minimum and maximum values.",x ="Visit",y =paste0(adlb$PARAMCD[1], " (", adlb$AVALU[1], ")") ) + theme_bpplot <-bp_annos(bp_7, oc, 2)plot
Experimental use!
WebR is a tool allowing you to run R code in the web browser. Modify the code below and click run to see the results. Alternatively, copy the code and click here to open WebR in a new tab.
bp_8 <-ggplot(adlb_v, aes(x = ARMCD, y = AVAL)) +stat_summary(geom ="boxplot",fun.data = five_num,position =position_dodge2(width = .5),aes(fill = AVISIT, color = AVISIT) ) +stat_summary(geom ="point",fun = mean,aes(group = AVISIT),size =3,shape =8,position =position_dodge2(1) ) +labs(title ="Box Plot of Laboratory Test Results",caption ="The whiskers extend to the minimum and maximum values.",x ="Treatment Group",y =paste0(adlb$PARAMCD[1], " (", adlb$AVALU[1], ")") ) + theme_bpplot <-bp_annos(bp_8, oc, 2)plot
Experimental use!
WebR is a tool allowing you to run R code in the web browser. Modify the code below and click run to see the results. Alternatively, copy the code and click here to open WebR in a new tab.
# Make wide dataset with summary statisticsadlb_wide <- adlb %>%group_by(ARMCD) %>%summarise(n =n(),mean =round(mean(AVAL), 1),median =round(median(AVAL), 1),median_ci =paste(round(DescTools::MedianCI(AVAL)[1:2], 1), collapse =" - "),q1_q3 =paste(round(quantile(AVAL, c(0.25, 0.75)), 1), collapse =" - "),min_max =paste0(round(min(AVAL), 1), "-", max(round(AVAL, 2))) )# Make long datasetadlb_long <- tidyr::gather(adlb_wide, key = type, value = stat, n:min_max)adlb_long <- adlb_long %>%mutate(type_lbl =case_when( type =="n"~"n", type =="mean"~"Mean", type =="median"~"Median", type =="median_ci"~"95% CI for Median", type =="q1_q3"~"25% and 75%-ile", type =="min_max"~"Min - Max" ))adlb_long$type_lbl <-factor(adlb_long$type_lbl,levels =c("Min - Max", "25% and 75%-ile", "95% CI for Median", "Median", "Mean", "n"))bp_9 <-ggplot(adlb, aes(x = ARMCD, y = AVAL)) +stat_summary(geom ="boxplot", fun.data = five_num, fill = fc, color = oc) +stat_summary(geom ="point", fun = mean, size =3, shape =8) +labs(title ="Box Plot of Laboratory Test Results",subtitle =paste("Visit:", adlb$AVISIT[1]),x ="Treatment Group",y =paste0(adlb$PARAMCD[1], " (", adlb$AVALU[1], ")") ) + theme_bptbl_theme <-theme(panel.border =element_blank(),panel.grid.major =element_blank(),panel.grid.minor =element_blank(),axis.ticks =element_blank(),axis.title =element_blank(),axis.text.y =element_text(face ="plain"),axis.text.x =element_blank())tbl_1 <-ggplot(adlb_long, aes(x = ARMCD, y = type_lbl, label = stat), vjust =10) +geom_text(size =3) +scale_y_discrete(labels =levels(adlb_long$type_lbl)) +theme_bw() + tbl_theme +labs(caption ="The whiskers extend to the minimum and maximum values.") + theme_bpplot <- cowplot::plot_grid(bp_annos(bp_9, oc), tbl_1,rel_heights =c(4, 2),ncol =1, nrow =2, align ="v")plot
Experimental use!
WebR is a tool allowing you to run R code in the web browser. Modify the code below and click run to see the results. Alternatively, copy the code and click here to open WebR in a new tab.
tbl_2 <- adlb_long %>%filter(type =="n") %>%ggplot(aes(x = ARMCD, y = type_lbl, label = stat)) +geom_text(size =3) +scale_y_discrete(labels ="n") +theme_bw() + tbl_theme +labs(caption ="The whiskers extend to the minimum and maximum values.") + theme_bpplot <- cowplot::plot_grid(bp_annos(bp_9, oc), tbl_2,rel_heights =c(6, 1),ncol =1, nrow =2, align ="v")plot
Experimental use!
WebR is a tool allowing you to run R code in the web browser. Modify the code below and click run to see the results. Alternatively, copy the code and click here to open WebR in a new tab.
Code
library(dplyr)library(ggplot2)library(nestcolor)adlb <- random.cdisc.data::cadlbadlb <- adlb %>%filter(PARAMCD =="ALT"& AVISIT =="WEEK 2 DAY 15")# Definition of boxplot boundaries and whiskersfive_num <-function(x, probs =c(0, 0.25, 0.5, 0.75, 1)) { r <-quantile(x, probs)names(r) <-c("ymin", "lower", "middle", "upper", "ymax") r}# get outliers based on quantile# for outliers based on IQR see coef in geom_boxplotget_outliers <-function(x, probs =c(0.05, 0.95)) { r <-subset(x, x <quantile(x, probs[1]) |quantile(x, probs[2]) < x)if (!is.null(x)) { x_names <-subset(names(x), x <quantile(x, probs[1]) |quantile(x, probs[2]) < x)names(r) <- x_names } r}# create theme used for all plotstheme_bp <-theme(plot.title =element_text(hjust =0),plot.subtitle =element_text(hjust =0),plot.caption =element_text(hjust =0),panel.background =element_rect(fill ="white", color ="grey50"))# assign fill color and outline colorfc <-"#eaeef5"oc <-getOption("ggplot2.discrete.fill")[1]# get plot metadata data to derive coordinates for adding annotationsbp_annos <-function(bp, color, annos =1) { bp_mdat <-ggplot_build(bp)$data[[1]]if (annos ==1) { bp <- bp +geom_segment(data = bp_mdat, aes(x = xmin + (xmax - xmin) /4, xend = xmax - (xmax - xmin) /4,y = ymax, yend = ymax ), linewidth = .5, color = color) +geom_segment(data = bp_mdat, aes(x = xmin + (xmax - xmin) /4, xend = xmax - (xmax - xmin) /4,y = ymin, yend = ymin ), linewidth = .5, color = color) } else { bp <- bp +geom_segment(data = bp_mdat, aes(x = xmin + (xmax - xmin) /4, xend = xmax - (xmax - xmin) /4,y = ymax, yend = ymax ), linewidth = .5, color = color) +geom_segment(data = bp_mdat, aes(x = xmin + (xmax - xmin) /4, xend = xmax - (xmax - xmin) /4,y = ymin, yend = ymin ), linewidth = .5, color = color) +geom_segment(data = bp_mdat, aes(x = xmin, xend = xmax,y = middle, yend = middle ), colour = color, linewidth = .5) }return(bp)}
library(teal.modules.general)## Data reproducible codedata <-teal_data()data <-within(data, {library(tern) ADSL <- random.cdisc.data::cadsl ADLB <- random.cdisc.data::cadlb# If PARAMCD and AVISIT are not factors, convert to factors# Also fill in missing values with "<Missing>" ADLB <- ADLB %>%df_explicit_na(omit_columns =setdiff(names(ADLB), c("PARAMCD", "AVISIT")),char_as_factor =TRUE )# If statment below fails, pre-process ADLB to be one record per# study, subject, param and visit eg. filter with ANLFL = 'Y'stopifnot(nrow(ADLB) ==nrow(unique(ADLB[, c("STUDYID", "USUBJID", "PARAMCD", "AVISIT")])))})datanames <-c("ADSL", "ADLB")datanames(data) <- datanamesjoin_keys(data) <- default_cdisc_join_keys[datanames]## Reusable Configuration For ModulesADSL <- data[["ADSL"]]ADLB <- data[["ADLB"]]## Setup Appapp <-init(data = data,modules =modules(tm_g_bivariate(x =data_extract_spec(dataname ="ADSL",select =select_spec(label ="Select variable:",choices =names(ADSL),selected ="ARMCD",fixed =FALSE ) ),y =data_extract_spec(dataname ="ADLB",filter =list(filter_spec(vars =c("PARAMCD"),choices =levels(ADLB$PARAMCD),selected =levels(ADLB$PARAMCD)[1],multiple =FALSE,label ="Choose lab parameter" ),filter_spec(vars =c("AVISIT"),choices =levels(ADLB$AVISIT),selected =levels(ADLB$AVISIT)[1],multiple =FALSE,label ="Choose visit" ) ),select =select_spec(label ="Select variable:",choices =names(ADLB),selected ="AVAL",multiple =FALSE,fixed =TRUE ) ),row_facet =data_extract_spec(dataname ="ADLB",select =select_spec(label ="Select variables:",choices =names(ADLB),selected =NULL,multiple =FALSE,fixed =FALSE ) ),col_facet =data_extract_spec(dataname ="ADLB",select =select_spec(label ="Select variables:",choices =names(ADLB),selected =NULL,multiple =FALSE,fixed =FALSE ) ) ) ))shinyApp(app$ui, app$server)
Warning: Removed 8000 rows containing non-finite outside the scale range
(`stat_boxplot()`).
Experimental use!
shinylive allow you to modify to run shiny application entirely in the web browser. Modify the code below and click re-run the app to see the results. The performance is slighly worse and some of the features (e.g. downloading) might not work at all.
#| '!! shinylive warning !!': |#| shinylive does not work in self-contained HTML documents.#| Please set `embed-resources: false` in your metadata.#| standalone: true#| viewerHeight: 800#| editorHeight: 200#| components: [viewer, editor]#| layout: vertical# -- WEBR HELPERS --options(webr_pkg_repos = c("r-universe" = "https://insightsengineering.r-universe.dev", getOption("webr_pkg_repos")))# -- APP CODE --library(teal.modules.general)## Data reproducible codedata <- teal_data()data <- within(data, { library(tern) ADSL <- random.cdisc.data::cadsl ADLB <- random.cdisc.data::cadlb # If PARAMCD and AVISIT are not factors, convert to factors # Also fill in missing values with "<Missing>" ADLB <- ADLB %>% df_explicit_na( omit_columns = setdiff(names(ADLB), c("PARAMCD", "AVISIT")), char_as_factor = TRUE ) # If statment below fails, pre-process ADLB to be one record per # study, subject, param and visit eg. filter with ANLFL = 'Y' stopifnot(nrow(ADLB) == nrow(unique(ADLB[, c("STUDYID", "USUBJID", "PARAMCD", "AVISIT")])))})datanames <- c("ADSL", "ADLB")datanames(data) <- datanamesjoin_keys(data) <- default_cdisc_join_keys[datanames]## Reusable Configuration For ModulesADSL <- data[["ADSL"]]ADLB <- data[["ADLB"]]## Setup Appapp <- init( data = data, modules = modules( tm_g_bivariate( x = data_extract_spec( dataname = "ADSL", select = select_spec( label = "Select variable:", choices = names(ADSL), selected = "ARMCD", fixed = FALSE ) ), y = data_extract_spec( dataname = "ADLB", filter = list( filter_spec( vars = c("PARAMCD"), choices = levels(ADLB$PARAMCD), selected = levels(ADLB$PARAMCD)[1], multiple = FALSE, label = "Choose lab parameter" ), filter_spec( vars = c("AVISIT"), choices = levels(ADLB$AVISIT), selected = levels(ADLB$AVISIT)[1], multiple = FALSE, label = "Choose visit" ) ), select = select_spec( label = "Select variable:", choices = names(ADLB), selected = "AVAL", multiple = FALSE, fixed = TRUE ) ), row_facet = data_extract_spec( dataname = "ADLB", select = select_spec( label = "Select variables:", choices = names(ADLB), selected = NULL, multiple = FALSE, fixed = FALSE ) ), col_facet = data_extract_spec( dataname = "ADLB", select = select_spec( label = "Select variables:", choices = names(ADLB), selected = NULL, multiple = FALSE, fixed = FALSE ) ) ) ))shinyApp(app$ui, app$server)