Exercise 3

Create your custom module!

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

Reference:

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
    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()
    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.