Title: | 'shiny' Widgets for 'teal' Applications |
---|---|
Description: | Collection of 'shiny' widgets to support 'teal' applications. Enables the manipulation of application layout and plot or table settings. |
Authors: | Dawid Kaledkowski [aut, cre], Pawel Rucki [aut], Mahmoud Hallal [aut], Nikolas Burkoff [aut], Maciej Nasinski [aut], Konrad Pagacz [aut], Junlue Zhao [aut], F. Hoffmann-La Roche AG [cph, fnd] |
Maintainer: | Dawid Kaledkowski <[email protected]> |
License: | Apache License 2.0 |
Version: | 0.4.2.9023 |
Built: | 2024-11-22 15:24:58 UTC |
Source: | https://github.com/insightsengineering/teal.widgets |
basic_table_args
object
This function has to be used to build an input for a basic_table_args
argument.
The basic_table_args
argument should be a part of every module which contains any rtables
object.
Arguments are validated to match their rtables
equivalents.
For more details see the vignette: vignette("custom-basic-table-arguments", package = "teal.widgets")
.
basic_table_args(...)
basic_table_args(...)
... |
arguments compatible with |
(basic_table_args
) object.
resolve_basic_table_args()
to resolve multiple objects into one using pre-defined priorities.
parse_basic_table_args()
to parse resolved list into list of calls.
basic_table_args(subtitles = "SUBTITLE")
basic_table_args(subtitles = "SUBTITLE")
Cleans and organizes output to account for NAs and remove empty rows. Wrapper around shiny::brushedPoints
.
clean_brushedPoints(data, brush)
clean_brushedPoints(data, brush)
data |
( |
brush |
( |
A data.frame
of selected rows.
brush <- list( mapping = list( x = "AGE", y = "BMRKR1" ), xmin = 30, xmax = 40, ymin = 0.7, ymax = 10, direction = "xy" ) data <- data.frame( STUDYID = letters[1:20], USUBJID = LETTERS[1:20], AGE = sample(25:40, size = 20, replace = TRUE), BMRKR1 = runif(20, min = 0, max = 12) ) nrow(clean_brushedPoints(data, brush)) data$AGE[1:10] <- NA nrow(clean_brushedPoints(data, brush))
brush <- list( mapping = list( x = "AGE", y = "BMRKR1" ), xmin = 30, xmax = 40, ymin = 0.7, ymax = 10, direction = "xy" ) data <- data.frame( STUDYID = letters[1:20], USUBJID = LETTERS[1:20], AGE = sample(25:40, size = 20, replace = TRUE), BMRKR1 = runif(20, min = 0, max = 12) ) nrow(clean_brushedPoints(data, brush)) data$AGE[1:10] <- NA nrow(clean_brushedPoints(data, brush))
A custom widget with draggable elements that can be put into buckets.
draggable_buckets(input_id, label, elements = character(), buckets)
draggable_buckets(input_id, label, elements = character(), buckets)
input_id |
( |
label |
( |
elements |
( |
buckets |
( |
shinyvalidate
validation can be used with this widget. See example below.
the HTML
code comprising an instance of this widget
library(shiny) ui <- fluidPage( draggable_buckets("id", "Choices #1", c("a", "b"), c("bucket1", "bucket2")), draggable_buckets("id2", "Choices #2", letters, c("vowels", "consonants")), verbatimTextOutput("out"), verbatimTextOutput("out2") ) server <- function(input, output) { iv <- shinyvalidate::InputValidator$new() iv$add_rule( "id", function(data) if (length(data[["bucket1"]]) == 0) "There should be stuff in bucket 1" ) iv$enable() observeEvent(list(input$id, input$id2), { print(isolate(input$id)) print(isolate(input$id2)) }) output$out <- renderPrint({ iv$is_valid() input$id }) output$out2 <- renderPrint(input$id2) } if (interactive()) shinyApp(ui, server) # With default elements in the bucket ui <- fluidPage( draggable_buckets("id", "Choices #1", c("a", "b"), list(bucket1 = character(), bucket2 = c("c"))), verbatimTextOutput("out") ) server <- function(input, output) { observeEvent(input$id, { print(isolate(input$id)) }) output$out <- renderPrint(input$id) } if (interactive()) shinyApp(ui, server)
library(shiny) ui <- fluidPage( draggable_buckets("id", "Choices #1", c("a", "b"), c("bucket1", "bucket2")), draggable_buckets("id2", "Choices #2", letters, c("vowels", "consonants")), verbatimTextOutput("out"), verbatimTextOutput("out2") ) server <- function(input, output) { iv <- shinyvalidate::InputValidator$new() iv$add_rule( "id", function(data) if (length(data[["bucket1"]]) == 0) "There should be stuff in bucket 1" ) iv$enable() observeEvent(list(input$id, input$id2), { print(isolate(input$id)) print(isolate(input$id2)) }) output$out <- renderPrint({ iv$is_valid() input$id }) output$out2 <- renderPrint(input$id2) } if (interactive()) shinyApp(ui, server) # With default elements in the bucket ui <- fluidPage( draggable_buckets("id", "Choices #1", c("a", "b"), list(bucket1 = character(), bucket2 = c("c"))), verbatimTextOutput("out") ) server <- function(input, output) { observeEvent(input$id, { print(isolate(input$id)) }) output$out <- renderPrint(input$id) } if (interactive()) shinyApp(ui, server)
lenghtMenu
property
Maps the lengthMenu
selected value property of DT::datatable
to a shiny
variable.
get_dt_rows(dt_name, dt_rows)
get_dt_rows(dt_name, dt_rows)
dt_name |
|
dt_rows |
|
(shiny::tagList
) A shiny tagList
.
library(shiny) library(DT) ui <- function(id) { ns <- NS(id) tagList( DTOutput(ns("data_table")), get_dt_rows(ns("data_table"), ns("dt_rows")) ) } # use the input$dt_rows in the Shiny Server function server <- function(id) { moduleServer(id, function(input, output, session) { output$data_table <- renderDataTable( { iris }, options = list(pageLength = input$dt_rows) ) }) } if (interactive()) { shinyApp( ui = ui("my_table_module"), server = function(input, output, session) server("my_table_module") ) }
library(shiny) library(DT) ui <- function(id) { ns <- NS(id) tagList( DTOutput(ns("data_table")), get_dt_rows(ns("data_table"), ns("dt_rows")) ) } # use the input$dt_rows in the Shiny Server function server <- function(id) { moduleServer(id, function(input, output, session) { output$data_table <- renderDataTable( { iris }, options = list(pageLength = input$dt_rows) ) }) } if (interactive()) { shinyApp( ui = ui("my_table_module"), server = function(input, output, session) server("my_table_module") ) }
ggplot2_args
object
Constructor of ggplot2_args
class of objects.
The ggplot2_args
argument should be a part of every module which contains any ggplot2
graphics.
The function arguments are validated to match their ggplot2
equivalents.
For more details see the vignette: vignette("custom-ggplot2-arguments", package = "teal.widgets")
.
ggplot2_args(labs = list(), theme = list())
ggplot2_args(labs = list(), theme = list())
labs |
(named |
theme |
(named |
(ggplot2_args
) object.
resolve_ggplot2_args()
to resolve multiple objects into one using pre-defined priorities.
parse_ggplot2_args()
to parse resolved list into list of calls.
ggplot2_args( labs = list(title = "TITLE"), theme = list(title = ggplot2::element_text(size = 20)) )
ggplot2_args( labs = list(title = "TITLE"), theme = list(title = ggplot2::element_text(size = 20)) )
Alternative to shiny::modalDialog
. Create a nested modal popup that can be shown/hidden
using jQuery
and modal id
, without disturbing the parent modal.
nested_closeable_modal(id, ..., modal_args = list(easyClose = TRUE))
nested_closeable_modal(id, ..., modal_args = list(easyClose = TRUE))
id |
( |
... |
( |
modal_args |
( |
(shiny.tag
) returns HTML
for shiny
module UI which can be nested into a modal popup
library(shiny) library(shinyjs) ui <- fluidPage( useShinyjs(), actionButton("show_1", "$(\"#modal_1\").modal(\"show\")"), nested_closeable_modal( "modal_1", modal_args = list( size = "l", title = "First Modal", easyClose = TRUE, footer = NULL ), tags$div( "This modal can be closed by running", tags$code("$(\"#modal_1\").modal(\"hide\")"), "in the JS console!", tags$br(), "Note that the second modal is placed right within this modal", tags$br(), "Alternatively, calling the", tags$code("removeModal()"), "will remove all the active modal popups", tags$br(), tags$br(), actionButton("show_2", "$(\"#modal_2\").modal(\"show\")"), actionButton("hide_1", "$(\"#modal_1\").modal(\"hide\")"), nested_closeable_modal( id = "modal_2", modal_args = list( size = "m", title = "Second Modal", footer = NULL, easyClose = TRUE ), tags$div( "This modal can be closed by running", tags$code("$(\"#modal_1\").modal(\"hide\")"), "in the JS console!", "Note that removing the parent will remove the child. But, reopening will remember the open state of child", actionButton("hide_2", "$(\"#modal_2\").modal(\"hide\")"), actionButton("hide_all", "$(\"#modal_1\").modal(\"hide\")") ) ) ) ) ) server <- function(input, output) { observeEvent(input$show_1, { runjs("$(\"#modal_1\").modal(\"show\")") }) observeEvent(input$show_2, { runjs("$(\"#modal_2\").modal(\"show\")") }) observeEvent(c(input$hide_1, input$hide_all), { runjs("$(\"#modal_1\").modal(\"hide\")") }) observeEvent(input$hide_2, { runjs("$(\"#modal_2\").modal(\"hide\")") }) } if (interactive()) { shinyApp(ui, server) }
library(shiny) library(shinyjs) ui <- fluidPage( useShinyjs(), actionButton("show_1", "$(\"#modal_1\").modal(\"show\")"), nested_closeable_modal( "modal_1", modal_args = list( size = "l", title = "First Modal", easyClose = TRUE, footer = NULL ), tags$div( "This modal can be closed by running", tags$code("$(\"#modal_1\").modal(\"hide\")"), "in the JS console!", tags$br(), "Note that the second modal is placed right within this modal", tags$br(), "Alternatively, calling the", tags$code("removeModal()"), "will remove all the active modal popups", tags$br(), tags$br(), actionButton("show_2", "$(\"#modal_2\").modal(\"show\")"), actionButton("hide_1", "$(\"#modal_1\").modal(\"hide\")"), nested_closeable_modal( id = "modal_2", modal_args = list( size = "m", title = "Second Modal", footer = NULL, easyClose = TRUE ), tags$div( "This modal can be closed by running", tags$code("$(\"#modal_1\").modal(\"hide\")"), "in the JS console!", "Note that removing the parent will remove the child. But, reopening will remember the open state of child", actionButton("hide_2", "$(\"#modal_2\").modal(\"hide\")"), actionButton("hide_all", "$(\"#modal_1\").modal(\"hide\")") ) ) ) ) ) server <- function(input, output) { observeEvent(input$show_1, { runjs("$(\"#modal_1\").modal(\"show\")") }) observeEvent(input$show_2, { runjs("$(\"#modal_2\").modal(\"show\")") }) observeEvent(c(input$hide_1, input$hide_all), { runjs("$(\"#modal_1\").modal(\"hide\")") }) observeEvent(input$hide_2, { runjs("$(\"#modal_2\").modal(\"hide\")") }) } if (interactive()) { shinyApp(ui, server) }
pickerInput
Wrapper for shinyWidgets::pickerInput()
with additional features.
When fixed = TRUE
or when the number of choices
is less or equal to 1 (see fixed_on_single
),
the pickerInput
widget is hidden and non-interactive widget will be displayed
instead. Toggle of HTML
elements is just the visual effect to avoid displaying
pickerInput
widget when there is only one choice.
optionalSelectInput( inputId, label = NULL, choices = NULL, selected = NULL, multiple = FALSE, sep = NULL, options = list(), label_help = NULL, fixed = FALSE, fixed_on_single = FALSE, width = NULL ) updateOptionalSelectInput( session, inputId, label = NULL, selected = NULL, choices = NULL )
optionalSelectInput( inputId, label = NULL, choices = NULL, selected = NULL, multiple = FALSE, sep = NULL, options = list(), label_help = NULL, fixed = FALSE, fixed_on_single = FALSE, width = NULL ) updateOptionalSelectInput( session, inputId, label = NULL, selected = NULL, choices = NULL )
inputId |
The |
label |
Display label for the control, or |
choices |
List of values to select from. If elements of the list are named then that name rather than the value is displayed to the user. |
selected |
The initially selected value (or multiple values if |
multiple |
Is selection of multiple items allowed? |
sep |
( |
options |
List of options, see pickerOptions for all available options. To limit the number of selection possible, see example below. |
label_help |
( |
fixed |
( |
fixed_on_single |
( |
width |
( |
session |
( |
(shiny.tag
) HTML tag with pickerInput
widget and
non-interactive element listing selected values.
library(shiny) # Create a minimal example data frame data <- data.frame( AGE = c(25, 30, 40, 35, 28), SEX = c("Male", "Female", "Male", "Female", "Male"), PARAMCD = c("Val1", "Val2", "Val3", "Val4", "Val5"), PARAM = c("Param1", "Param2", "Param3", "Param4", "Param5"), AVISIT = c("Visit1", "Visit2", "Visit3", "Visit4", "Visit5"), stringsAsFactors = TRUE ) ui_grid <- function(...) { fluidPage( fluidRow( lapply(list(...), function(x) column(4, wellPanel(x))) ) ) } ui <- ui_grid( tags$div( optionalSelectInput( inputId = "c1", label = "Fixed choices", choices = LETTERS[1:5], selected = c("A", "B"), fixed = TRUE ), verbatimTextOutput(outputId = "c1_out") ), tags$div( optionalSelectInput( inputId = "c2", label = "Single choice", choices = "A", selected = "A" ), verbatimTextOutput(outputId = "c2_out") ), tags$div( optionalSelectInput( inputId = "c3", label = "NULL choices", choices = NULL ), verbatimTextOutput(outputId = "c3_out") ), tags$div( optionalSelectInput( inputId = "c4", label = "Default", choices = LETTERS[1:5], selected = "A" ), verbatimTextOutput(outputId = "c4_out") ), tags$div( optionalSelectInput( inputId = "c5", label = "Named vector", choices = c(`A - value A` = "A", `B - value B` = "B", `C - value C` = "C"), selected = "A" ), verbatimTextOutput(outputId = "c5_out") ), tags$div( selectInput( inputId = "c6_choices", label = "Update choices", choices = letters, multiple = TRUE ), optionalSelectInput( inputId = "c6", label = "Updated choices", choices = NULL, multiple = TRUE, fixed_on_single = TRUE ), verbatimTextOutput(outputId = "c6_out") ) ) server <- function(input, output, session) { observeEvent(input$c6_choices, ignoreNULL = FALSE, { updateOptionalSelectInput( session = session, inputId = "c6", choices = input$c6_choices, selected = input$c6_choices ) }) output$c1_out <- renderPrint(input$c1) output$c2_out <- renderPrint(input$c2) output$c3_out <- renderPrint(input$c3) output$c4_out <- renderPrint(input$c4) output$c5_out <- renderPrint(input$c5) output$c6_out <- renderPrint(input$c6) } if (interactive()) { shinyApp(ui, server) }
library(shiny) # Create a minimal example data frame data <- data.frame( AGE = c(25, 30, 40, 35, 28), SEX = c("Male", "Female", "Male", "Female", "Male"), PARAMCD = c("Val1", "Val2", "Val3", "Val4", "Val5"), PARAM = c("Param1", "Param2", "Param3", "Param4", "Param5"), AVISIT = c("Visit1", "Visit2", "Visit3", "Visit4", "Visit5"), stringsAsFactors = TRUE ) ui_grid <- function(...) { fluidPage( fluidRow( lapply(list(...), function(x) column(4, wellPanel(x))) ) ) } ui <- ui_grid( tags$div( optionalSelectInput( inputId = "c1", label = "Fixed choices", choices = LETTERS[1:5], selected = c("A", "B"), fixed = TRUE ), verbatimTextOutput(outputId = "c1_out") ), tags$div( optionalSelectInput( inputId = "c2", label = "Single choice", choices = "A", selected = "A" ), verbatimTextOutput(outputId = "c2_out") ), tags$div( optionalSelectInput( inputId = "c3", label = "NULL choices", choices = NULL ), verbatimTextOutput(outputId = "c3_out") ), tags$div( optionalSelectInput( inputId = "c4", label = "Default", choices = LETTERS[1:5], selected = "A" ), verbatimTextOutput(outputId = "c4_out") ), tags$div( optionalSelectInput( inputId = "c5", label = "Named vector", choices = c(`A - value A` = "A", `B - value B` = "B", `C - value C` = "C"), selected = "A" ), verbatimTextOutput(outputId = "c5_out") ), tags$div( selectInput( inputId = "c6_choices", label = "Update choices", choices = letters, multiple = TRUE ), optionalSelectInput( inputId = "c6", label = "Updated choices", choices = NULL, multiple = TRUE, fixed_on_single = TRUE ), verbatimTextOutput(outputId = "c6_out") ) ) server <- function(input, output, session) { observeEvent(input$c6_choices, ignoreNULL = FALSE, { updateOptionalSelectInput( session = session, inputId = "c6", choices = input$c6_choices, selected = input$c6_choices ) }) output$c1_out <- renderPrint(input$c1) output$c2_out <- renderPrint(input$c2) output$c3_out <- renderPrint(input$c3) output$c4_out <- renderPrint(input$c4) output$c5_out <- renderPrint(input$c5) output$c6_out <- renderPrint(input$c6) } if (interactive()) { shinyApp(ui, server) }
NA
then the slider widget will be hidden
Hidden input widgets are useful to have the input[[inputId]]
variable
on available in the server function but no corresponding visual clutter from
input widgets that provide only a single choice.
optionalSliderInput(inputId, label, min, max, value, label_help = NULL, ...)
optionalSliderInput(inputId, label, min, max, value, label_help = NULL, ...)
inputId |
The |
label |
Display label for the control, or |
min , max
|
The minimum and maximum values (inclusive) that can be selected. |
value |
The initial value of the slider, either a number, a date
(class Date), or a date-time (class POSIXt). A length one vector will
create a regular slider; a length two vector will create a double-ended
range slider. Must lie between |
label_help |
( |
... |
optional arguments to |
(shiny.tag
) HTML tag with sliderInput
widget.
optionalSliderInput("a", "b", 0, 1, 0.2)
optionalSliderInput("a", "b", 0, 1, 0.2)
teal
modules we parameterize an optionalSliderInput
with one argument
value_min_max
The optionalSliderInput()
function needs three arguments to determine
whether to hide the sliderInput
widget or not. For teal
modules we specify an
optional slider input with one argument here called value_min_max
.
optionalSliderInputValMinMax( inputId, label, value_min_max, label_help = NULL, ... )
optionalSliderInputValMinMax( inputId, label, value_min_max, label_help = NULL, ... )
inputId |
The |
label |
Display label for the control, or |
value_min_max |
( |
label_help |
( |
... |
optional arguments to |
(shiny.tag
) HTML tag with range sliderInput
widget.
optionalSliderInputValMinMax("a", "b", 1) optionalSliderInputValMinMax("a", "b", c(3, 1, 5))
optionalSliderInputValMinMax("a", "b", 1) optionalSliderInputValMinMax("a", "b", c(3, 1, 5))
Designed to group panel_item
elements. Used to handle shiny
inputs in the encoding panel.
panel_group(..., id = NULL)
panel_group(..., id = NULL)
... |
( |
id |
optional, ( |
(shiny.tag
)
library(shiny) panel_group( panel_item( title = "Display", collapsed = FALSE, checkboxGroupInput( "check", "Tables display", choices = LETTERS[1:3], selected = LETTERS[1] ), radioButtons( "radio", label = "Plot type", choices = letters[1:2], selected = letters[1] ) ), panel_item( title = "Pre-processing", radioButtons( "filtering", "What to filter", choices = LETTERS[1:4], selected = LETTERS[1] ), radioButtons( "na_action", "NA action", choices = letters[1:3], selected = letters[1] ) ) )
library(shiny) panel_group( panel_item( title = "Display", collapsed = FALSE, checkboxGroupInput( "check", "Tables display", choices = LETTERS[1:3], selected = LETTERS[1] ), radioButtons( "radio", label = "Plot type", choices = letters[1:2], selected = letters[1] ) ), panel_item( title = "Pre-processing", radioButtons( "filtering", "What to filter", choices = LETTERS[1:4], selected = LETTERS[1] ), radioButtons( "na_action", "NA action", choices = letters[1:3], selected = letters[1] ) ) )
Designed to be grouped using panel_group
element. Used to handle shiny
inputs in the encoding panel.
panel_item(title, ..., collapsed = TRUE, input_id = NULL)
panel_item(title, ..., collapsed = TRUE, input_id = NULL)
title |
( |
... |
content of panel |
collapsed |
( |
input_id |
( |
(shiny.tag
)
library(shiny) panel_item( title = "Display", collapsed = FALSE, checkboxGroupInput( "check", "Tables display", choices = LETTERS[1:3], selected = LETTERS[1] ), radioButtons( "radio", label = "Plot type", choices = letters[1:2], selected = letters[1] ) )
library(shiny) panel_item( title = "Display", collapsed = FALSE, checkboxGroupInput( "check", "Tables display", choices = LETTERS[1:3], selected = LETTERS[1] ), radioButtons( "radio", label = "Plot type", choices = letters[1:2], selected = letters[1] ) )
basic_table_args
object into the basic_table
expression
A function to parse expression from the basic_table_args
object.
parse_basic_table_args(basic_table_args = teal.widgets::basic_table_args())
parse_basic_table_args(basic_table_args = teal.widgets::basic_table_args())
basic_table_args |
( |
(language
) the rtables::basic_table()
filled with additional arguments.
parse_basic_table_args( resolve_basic_table_args( user_table = basic_table_args(title = "TITLE"), user_default = basic_table_args(title = "DEFAULT_TITLE", subtitles = "SUBTITLE") ) )
parse_basic_table_args( resolve_basic_table_args( user_table = basic_table_args(title = "TITLE"), user_default = basic_table_args(title = "DEFAULT_TITLE", subtitles = "SUBTITLE") ) )
ggplot2_args
object into the ggplot2
expression
A function to parse expression from the ggplot2_args
object.
parse_ggplot2_args( ggplot2_args = teal.widgets::ggplot2_args(), ggtheme = c("default", "gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void", "test") )
parse_ggplot2_args( ggplot2_args = teal.widgets::ggplot2_args(), ggtheme = c("default", "gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void", "test") )
ggplot2_args |
( |
ggtheme |
( |
(list
) of up to three elements of class languange
: "labs"
, "ggtheme"
and "theme"
.
parse_ggplot2_args( resolve_ggplot2_args(ggplot2_args( labs = list(title = "TITLE"), theme = list(title = ggplot2::element_text(size = 20)) )) ) parse_ggplot2_args( resolve_ggplot2_args( ggplot2_args( labs = list(title = "TITLE"), theme = list(title = ggplot2::element_text(size = 20)) ) ), ggtheme = "gray" )
parse_ggplot2_args( resolve_ggplot2_args(ggplot2_args( labs = list(title = "TITLE"), theme = list(title = ggplot2::element_text(size = 20)) )) ) parse_ggplot2_args( resolve_ggplot2_args( ggplot2_args( labs = list(title = "TITLE"), theme = list(title = ggplot2::element_text(size = 20)) ) ), ggtheme = "gray" )
Universal module for plots with settings for height, width, and download.
plot_with_settings_ui(id) plot_with_settings_srv( id, plot_r, height = c(600, 200, 2000), width = NULL, show_hide_signal = reactive(TRUE), brushing = FALSE, clicking = FALSE, dblclicking = FALSE, hovering = FALSE, graph_align = "left" )
plot_with_settings_ui(id) plot_with_settings_srv( id, plot_r, height = c(600, 200, 2000), width = NULL, show_hide_signal = reactive(TRUE), brushing = FALSE, clicking = FALSE, dblclicking = FALSE, hovering = FALSE, graph_align = "left" )
id |
( |
plot_r |
( |
height |
( |
width |
( |
show_hide_signal |
optional, ( |
brushing |
( |
clicking |
( |
dblclicking |
( |
hovering |
( |
graph_align |
( |
By default the plot is rendered with 72 dpi
. In order to change this, to for example 96 set
options(teal.plot_dpi = 96)
. The minimum allowed dpi
value is 24
and it must be a whole number.
If an invalid value is set then the default value is used and a warning is outputted to the console.
A shiny
module.
# Example using a reactive as input to plot_r library(shiny) library(ggplot2) ui <- fluidPage( plot_with_settings_ui( id = "plot_with_settings" ) ) server <- function(input, output, session) { plot_r <- reactive({ ggplot(faithful, aes(x = .data$waiting, y = .data$eruptions)) + geom_point() }) plot_with_settings_srv( id = "plot_with_settings", plot_r = plot_r, height = c(400, 100, 1200), width = c(500, 250, 750) ) } if (interactive()) { shinyApp(ui, server) } # Example using a function as input to plot_r library(lattice) ui <- fluidPage( radioButtons("download_option", "Select the Option", list("ggplot", "trellis", "grob", "base")), plot_with_settings_ui( id = "plot_with_settings" ), sliderInput("nums", "Value", 1, 10, 1) ) server <- function(input, output, session) { plot_r <- function() { numbers <- seq_len(input$nums) if (input$download_option == "ggplot") { ggplot(data.frame(n = numbers), aes(.data$n)) + geom_bar() } else if (input$download_option == "trellis") { densityplot(numbers) } else if (input$download_option == "grob") { tr_plot <- densityplot(numbers) ggplotGrob( ggplot(data.frame(n = numbers), aes(.data$n)) + geom_bar() ) } else if (input$download_option == "base") { plot(numbers) } } plot_with_settings_srv( id = "plot_with_settings", plot_r = plot_r, height = c(400, 100, 1200), width = c(500, 250, 750) ) } if (interactive()) { shinyApp(ui, server) } # Example with brushing/hovering/clicking/double-clicking ui <- fluidPage( plot_with_settings_ui( id = "plot_with_settings" ), fluidRow( column(4, tags$h3("Brush"), verbatimTextOutput("brushing_data")), column(4, tags$h3("Click"), verbatimTextOutput("clicking_data")), column(4, tags$h3("DblClick"), verbatimTextOutput("dblclicking_data")), column(4, tags$h3("Hover"), verbatimTextOutput("hovering_data")) ) ) server <- function(input, output, session) { plot_r <- reactive({ ggplot(faithful, aes(x = .data$waiting, y = .data$eruptions)) + geom_point() }) plot_data <- plot_with_settings_srv( id = "plot_with_settings", plot_r = plot_r, height = c(400, 100, 1200), brushing = TRUE, clicking = TRUE, dblclicking = TRUE, hovering = TRUE ) output$brushing_data <- renderPrint(plot_data$brush()) output$clicking_data <- renderPrint(plot_data$click()) output$dblclicking_data <- renderPrint(plot_data$dblclick()) output$hovering_data <- renderPrint(plot_data$hover()) } if (interactive()) { shinyApp(ui, server) } # Example which allows module to be hidden/shown library("shinyjs") ui <- fluidPage( useShinyjs(), actionButton("button", "Show/Hide"), plot_with_settings_ui( id = "plot_with_settings" ) ) server <- function(input, output, session) { plot_r <- plot_r <- reactive( ggplot(faithful, aes(x = .data$waiting, y = .data$eruptions)) + geom_point() ) show_hide_signal_rv <- reactiveVal(TRUE) observeEvent(input$button, show_hide_signal_rv(!show_hide_signal_rv())) plot_with_settings_srv( id = "plot_with_settings", plot_r = plot_r, height = c(400, 100, 1200), width = c(500, 250, 750), show_hide_signal = reactive(show_hide_signal_rv()) ) } if (interactive()) { shinyApp(ui, server) }
# Example using a reactive as input to plot_r library(shiny) library(ggplot2) ui <- fluidPage( plot_with_settings_ui( id = "plot_with_settings" ) ) server <- function(input, output, session) { plot_r <- reactive({ ggplot(faithful, aes(x = .data$waiting, y = .data$eruptions)) + geom_point() }) plot_with_settings_srv( id = "plot_with_settings", plot_r = plot_r, height = c(400, 100, 1200), width = c(500, 250, 750) ) } if (interactive()) { shinyApp(ui, server) } # Example using a function as input to plot_r library(lattice) ui <- fluidPage( radioButtons("download_option", "Select the Option", list("ggplot", "trellis", "grob", "base")), plot_with_settings_ui( id = "plot_with_settings" ), sliderInput("nums", "Value", 1, 10, 1) ) server <- function(input, output, session) { plot_r <- function() { numbers <- seq_len(input$nums) if (input$download_option == "ggplot") { ggplot(data.frame(n = numbers), aes(.data$n)) + geom_bar() } else if (input$download_option == "trellis") { densityplot(numbers) } else if (input$download_option == "grob") { tr_plot <- densityplot(numbers) ggplotGrob( ggplot(data.frame(n = numbers), aes(.data$n)) + geom_bar() ) } else if (input$download_option == "base") { plot(numbers) } } plot_with_settings_srv( id = "plot_with_settings", plot_r = plot_r, height = c(400, 100, 1200), width = c(500, 250, 750) ) } if (interactive()) { shinyApp(ui, server) } # Example with brushing/hovering/clicking/double-clicking ui <- fluidPage( plot_with_settings_ui( id = "plot_with_settings" ), fluidRow( column(4, tags$h3("Brush"), verbatimTextOutput("brushing_data")), column(4, tags$h3("Click"), verbatimTextOutput("clicking_data")), column(4, tags$h3("DblClick"), verbatimTextOutput("dblclicking_data")), column(4, tags$h3("Hover"), verbatimTextOutput("hovering_data")) ) ) server <- function(input, output, session) { plot_r <- reactive({ ggplot(faithful, aes(x = .data$waiting, y = .data$eruptions)) + geom_point() }) plot_data <- plot_with_settings_srv( id = "plot_with_settings", plot_r = plot_r, height = c(400, 100, 1200), brushing = TRUE, clicking = TRUE, dblclicking = TRUE, hovering = TRUE ) output$brushing_data <- renderPrint(plot_data$brush()) output$clicking_data <- renderPrint(plot_data$click()) output$dblclicking_data <- renderPrint(plot_data$dblclick()) output$hovering_data <- renderPrint(plot_data$hover()) } if (interactive()) { shinyApp(ui, server) } # Example which allows module to be hidden/shown library("shinyjs") ui <- fluidPage( useShinyjs(), actionButton("button", "Show/Hide"), plot_with_settings_ui( id = "plot_with_settings" ) ) server <- function(input, output, session) { plot_r <- plot_r <- reactive( ggplot(faithful, aes(x = .data$waiting, y = .data$eruptions)) + geom_point() ) show_hide_signal_rv <- reactiveVal(TRUE) observeEvent(input$button, show_hide_signal_rv(!show_hide_signal_rv())) plot_with_settings_srv( id = "plot_with_settings", plot_r = plot_r, height = c(400, 100, 1200), width = c(500, 250, 750), show_hide_signal = reactive(show_hide_signal_rv()) ) } if (interactive()) { shinyApp(ui, server) }
basic_table_args
objects
Resolving and reducing multiple basic_table_args
objects.
This function is intended to utilize user provided settings, defaults provided by the module creator and
also teal
option. See Details
, below, to understand the logic.
resolve_basic_table_args( user_table = basic_table_args(), user_default = basic_table_args(), module_table = basic_table_args(), app_default = getOption("teal.basic_table_args", basic_table_args()) )
resolve_basic_table_args( user_table = basic_table_args(), user_default = basic_table_args(), module_table = basic_table_args(), app_default = getOption("teal.basic_table_args", basic_table_args()) )
user_table |
( |
user_default |
( |
module_table |
( |
app_default |
( |
The function picks the first non NULL
value for each argument, checking in the following order:
basic_table_args
argument provided by the end user.
Per table (user_table
) and then default (user_default
) setup.
app_default
global R variable, teal.basic_table_args
.
module_table
which is a module creator setup.
basic_table_args
object.
parse_basic_table_args()
to parse resolved list into list of calls.
resolve_basic_table_args( user_table = basic_table_args(title = "TITLE"), user_default = basic_table_args(title = "DEFAULT_TITLE", subtitles = "SUBTITLE") )
resolve_basic_table_args( user_table = basic_table_args(title = "TITLE"), user_default = basic_table_args(title = "DEFAULT_TITLE", subtitles = "SUBTITLE") )
ggplot2_args
objects
Resolving and reducing multiple ggplot2_args
objects.
This function is intended to utilize user provided settings, defaults provided by the module creator and
also teal
option. See Details
, below, to understand the logic.
resolve_ggplot2_args( user_plot = ggplot2_args(), user_default = ggplot2_args(), module_plot = ggplot2_args(), app_default = getOption("teal.ggplot2_args", ggplot2_args()) )
resolve_ggplot2_args( user_plot = ggplot2_args(), user_default = ggplot2_args(), module_plot = ggplot2_args(), app_default = getOption("teal.ggplot2_args", ggplot2_args()) )
user_plot |
( |
user_default |
( |
module_plot |
( |
app_default |
( |
The function picks the first non NULL
value for each argument, checking in the following order:
ggplot2_args
argument provided by the end user.
Per plot (user_plot
) and then default (user_default
) setup.
app_default
global R variable, teal.ggplot2_args
.
module_plot
which is a module creator setup.
ggplot2_args
object.
parse_ggplot2_args()
to parse resolved list into list of calls.
resolve_ggplot2_args( user_plot = ggplot2_args( labs = list(title = "TITLE"), theme = list(title = ggplot2::element_text(size = 20)) ), user_default = ggplot2_args( labs = list(x = "XLAB") ) )
resolve_ggplot2_args( user_plot = ggplot2_args( labs = list(title = "TITLE"), theme = list(title = ggplot2::element_text(size = 20)) ), user_default = ggplot2_args( labs = list(x = "XLAB") ) )
Create a standard UI layout with output on the right and an encoding panel on
the left. This is the layout used by the teal
modules.
standard_layout( output, encoding = NULL, forms = NULL, pre_output = NULL, post_output = NULL )
standard_layout( output, encoding = NULL, forms = NULL, pre_output = NULL, post_output = NULL )
output |
( |
encoding |
( |
forms |
( |
pre_output |
( |
post_output |
( |
an object of class shiny.tag
with the UI code.
library(shiny) standard_layout( output = white_small_well(tags$h3("Tests")), encoding = tags$div( tags$label("Encodings", class = "text-primary"), panel_item( "Tests", optionalSelectInput( "tests", "Tests:", choices = c( "Shapiro-Wilk", "Kolmogorov-Smirnov (one-sample)" ), selected = "Shapiro-Wilk" ) ) ), forms = tagList( verbatim_popup_ui("warning", "Show Warnings"), verbatim_popup_ui("rcode", "Show R code") ) )
library(shiny) standard_layout( output = white_small_well(tags$h3("Tests")), encoding = tags$div( tags$label("Encodings", class = "text-primary"), panel_item( "Tests", optionalSelectInput( "tests", "Tests:", choices = c( "Shapiro-Wilk", "Kolmogorov-Smirnov (one-sample)" ), selected = "Shapiro-Wilk" ) ) ), forms = tagList( verbatim_popup_ui("warning", "Show Warnings"), verbatim_popup_ui("rcode", "Show R code") ) )
table_with_settings
module
Module designed to create a shiny
table output based on rtable
object (ElementaryTable
or TableTree
) input.
table_with_settings_ui(id, ...) table_with_settings_srv(id, table_r, show_hide_signal = reactive(TRUE))
table_with_settings_ui(id, ...) table_with_settings_srv(id, table_r, show_hide_signal = reactive(TRUE))
id |
An ID string that corresponds with the ID used to call the module's UI function. |
... |
( |
table_r |
( |
show_hide_signal |
( |
A shiny
module.
library(shiny) library(rtables) library(magrittr) ui <- fluidPage( table_with_settings_ui( id = "table_with_settings" ) ) server <- function(input, output, session) { table_r <- reactive({ l <- basic_table() %>% split_cols_by("ARM") %>% analyze(c("SEX", "AGE")) tbl <- build_table(l, DM) tbl }) table_with_settings_srv(id = "table_with_settings", table_r = table_r) } if (interactive()) { shinyApp(ui, server) }
library(shiny) library(rtables) library(magrittr) ui <- fluidPage( table_with_settings_ui( id = "table_with_settings" ) ) server <- function(input, output, session) { table_r <- reactive({ l <- basic_table() %>% split_cols_by("ARM") %>% analyze(c("SEX", "AGE")) tbl <- build_table(l, DM) tbl }) table_with_settings_srv(id = "table_with_settings", table_r = table_r) } if (interactive()) { shinyApp(ui, server) }
shiny
module that pops up verbatim text.This module consists of a button that once clicked pops up a modal window with verbatim-styled text.
verbatim_popup_ui(id, button_label, type = c("button", "link"), ...) verbatim_popup_srv( id, verbatim_content, title, style = FALSE, disabled = shiny::reactiveVal(FALSE) )
verbatim_popup_ui(id, button_label, type = c("button", "link"), ...) verbatim_popup_srv( id, verbatim_content, title, style = FALSE, disabled = shiny::reactiveVal(FALSE) )
id |
( |
button_label |
( |
type |
( |
... |
additional arguments to |
verbatim_content |
( |
title |
( |
style |
( |
disabled |
( |
the UI function returns a shiny.tag.list
object
library(shiny) ui <- fluidPage(verbatim_popup_ui("my_id", button_label = "Open popup")) srv <- function(input, output) { verbatim_popup_srv( "my_id", "if (TRUE) { print('Popups are the best') }", title = "My custom title", style = TRUE ) } if (interactive()) shinyApp(ui, srv)
library(shiny) ui <- fluidPage(verbatim_popup_ui("my_id", button_label = "Open popup")) srv <- function(input, output) { verbatim_popup_srv( "my_id", "if (TRUE) { print('Popups are the best') }", title = "My custom title", style = TRUE ) } if (interactive()) shinyApp(ui, srv)
Adds Small Well class and overflow-x property to HTML output element.
white_small_well(...)
white_small_well(...)
... |
other arguments to pass to tag object's div attributes. |
white_small_well
is intended to be used with shiny::uiOutput()
.
The overflow-x property is set to auto so that a scroll bar is added
when the content overflows at the left and right edges of the output window.
For example, this is useful for displaying wide tables.
An HTML output element with class Small Well and overflow-x property
white_small_well(shiny::htmlOutput("summary"))
white_small_well(shiny::htmlOutput("summary"))