Exercise 3

Create your custom module!

Create a custom module that does a simple histogram plot based on user selected columns.

Reference:

• teal::module()
• “Creating Custom Modules” vignette
• "qenv" article on how to interact with internal qenv object - in particular: teal.code::within() function

Code

library(teal)
library(dplyr)
library(ggplot2)

my_custom_module_ui <- function(id) {
  ns <- NS(id)
  tags$div(
    # variable selector
    selectInput(
      inputId = ns("variable"),
      label = "Select variable",
      # initialize empty - to be updated from within server
      choices = NULL
    ),
    plotOutput(ns("plot"))
  )
}

my_custom_module_srv <- function(id, data) {
  moduleServer(id, function(input, output, session) {

    # update variable selector by names of data
    updateSelectInput(
      inputId = "variable",
      choices = data()[["ADSL"]] |> select(where(is.numeric)) |> names()
    )

    # add plot call to qenv
    result <- reactive({
      req(input$variable)
      within(
        data(),
        {
          my_plot <- ggplot(ADSL, aes(x = input_var)) +
            geom_histogram()
          my_plot
        },
        input_var = as.name(input$variable)
      )
    })

    # render to output the object from qenv
    output$plot <- renderPlot({
      result()[["my_plot"]]
    })

  })
}

my_custom_module <- module(
  label = "My Custom Module",
  ui = my_custom_module_ui,
  server = my_custom_module_srv
)


data <- teal_data()
data <- within(data, {
  ADSL <- rADSL
})

app <- init(
  data = data,
  modules = list(
    my_custom_module
  )
)

if (Sys.getenv("QUARTO_ROOT") == "") {
  shinyApp(app$ui, app$server)
}

App

Exercise

Open editor in Shinylive

Let’s enhance the module:

• Let’s create a new parameter binwidth:
  • add a new widget to the UI
    • that widget should be created with shiny::sliderInput()
    • make reasonable values of min, max, step and initial value
  • read and use that widget in server
    • pass this parameter value as binwidth argument to the geom_histogram() function
  Answer

  my_custom_module_ui <- function(id) {
    ...
    tags$div(
      ...,
      sliderInput(
        inputId = ns("binwidth"),
        label = "binwidth",
        min = 1,
        max = 10,
        step = 1,
        value = 3
      ),
      ...
    )
  }

  my_custom_module_srv <- function(id, data) {
    moduleServer(id, function(input, output, session) {
  
      ...
  
      # add plot call to qenv
      result <- reactive({
        req(input$variable)
        within(
          data(),
          {
            my_plot <- ggplot(ADSL, aes(x = input_var)) +
              geom_histogram(binwidth = input_binwidth)
            my_plot
          },
          input_var = as.name(input$variable),
          input_binwidth = input$binwidth
        )
      })
  
      ...
  
    })
  }

• Let’s add more datasets
  • extend data with ADAE = teal.data::rADAE
  • add a new widget in the UI
    • that widget should be created with shiny::selectInput()
    • initialize empty and update values in the same way as for input$variable
  • read and use in the server
    • modify the variable selection - it has to be chosen from the currently selected dataset
      • convert to observeEvent() on input$dataset
      • add at the beggining: req(input$dataset) to assure non empty selection
      • modify to choices = names(data()[[input$dataset]])
    • modify the observer call
      • add req(input$dataset)
      • add req(input$variables %in% names(data()[[input$dataset]]))
    • modify ggplot call
      • convert the value to a symbol and use as a first argument of ggplot()
  Answer

  data <- within(data, {
    ADSL <- rADSL
    ADAE <- teal.data::rADAE
  })

  my_custom_module_ui <- function(id) {
    ns <- NS(id)
    tags$div(
      # dataset selector
      selectInput(
        inputId = ns("dataset"),
        label = "Select dataset",
        choices = NULL
      ),
      ...
    )
  }

  my_custom_module_srv <- function(id, data) {
    moduleServer(id, function(input, output, session) {
  
      updateSelectInput(
        inputId = "dataset",
        choices = names(data())
      )
  
      observeEvent(
        input$dataset,
        {
          req(input$dataset)
          updateSelectInput(
            inputId = "variable",
            choices = data()[[input$dataset]] |> select(where(is.numeric)) |> names()
          )
        }
      )
  
      result <- reactive({
        req(input$dataset)
        req(input$variable)
        within(
          data(),
          {
            my_plot <- ggplot(input_dataset, aes(x = input_var)) +
              geom_histogram()
            my_plot
          },
          input_dataset = as.name(input$dataset),
          input_var = as.name(input$variable)
        )
      })
  
      output$plot <- renderPlot({
        result()[["my_plot"]]
      })
  
    })
  }

Exercise (bonus)

• Convert module to a function and let label be a function parameter.