Shiny Modules Test

01-app-plain.R

library(shiny)
library(tidyverse)
library(glue)
library(DT)

df <- mtcars %>% 
  rownames_to_column("car") %>% 
  select(car, everything())


################################
### VERSION 1 - No Modules
ui <- fluidPage(
  sliderInput("filter_cyl", "Cylinders", min = min(df$cyl), max = max(df$cyl), value = range(df$cyl)),
  actionButton("exclude", "Exclude Selected"),
  actionButton("reset", "Reset"),
  dataTableOutput("table")
)

server <- function(input, output, session) {
  
  df_all <- reactiveVal()
  df_selection <- reactiveVal() # without excluded cars
  df_final <- reactiveVal()     # filtered by cyl
  
  print(glue("Initial Data Loaded"))
  df_all(df)
  df_selection(df)
  df_final(df)
  
  observeEvent(input$reset, {
    print(glue("Reset Values"))
    updateSliderInput(session, "filter_cyl", value = range(df_all()$cyl))
    df_selection(df_all())
    df_final(df_all())
  })
  
  # exclude selection
  observeEvent(input$exclude, {
    rows <- input$table_rows_selected
    if (length(rows) == 0) return(NULL)
    
    d <- df_selection()
    print(glue("Updating the Dataset: removing {length(rows)} cars"))
    
    d <- d %>% slice(-rows)
    df_selection(d)
  })
  
  observeEvent(list(input$filter_cyl, input$exclude), { # filter the cyl
    d <- df_selection()
    print(glue("Updating the Dataset: Filter set to {input$filter_cyl %>% paste(collapse = ', ')}"))
    d <- d %>% filter(cyl >= min(input$filter_cyl), 
                      cyl <= max(input$filter_cyl))
    df_final(d)
  })
  
  output$table <- renderDataTable(df_final())
}

shinyApp(ui, server)

02-app-modularised.R

#######################################
### Version 2: Modules:
#' - Module 1: reset functionality
#' - Module 2: Exclude Rows
#' - Module 3: Filter cylinders

library(shiny)
library(tidyverse)
library(glue)
library(DT)

df <- mtcars %>% 
  rownames_to_column("car") %>% 
  select(car, everything())

# Reset Module
mod_reset_UI <- function(id) {
  ns <- NS(id)
  tagList(
    actionButton(ns("reset"), "Reset")
  )
}
mod_reset_server <- function(id, df_all, df_selection, df_final, slider_ui_values) {
  moduleServer(
    id,
    function(input, output, session) {
      observeEvent(input$reset, {
        print(glue("Values reset"))
        d <- df_all()
        slider_ui_values(list(range = range(d$cyl), min = min(d$cyl), max = max(d$cyl)))
        df_selection(d)
        df_final(d)
      })
    }
  )
}

# Exclude Rows Module
mod_exclude_rows_UI <- function(id) {
  ns <- NS(id)
  tagList(
    actionButton(ns("exclude"), "Exclude Selected"),
  )
}

mod_exclude_rows <- function(id, df_selection, selected_rows) {
  moduleServer(
    id,
    function(input, output, session) {
      observeEvent(input$exclude, {
        # rows <- input$table_rows_selected
        rows <- selected_rows()
        if (length(rows) == 0) return(NULL)
        
        d <- df_selection()
        print(glue("Removing {length(rows)} cars"))
        
        d <- d %>% slice(-rows)
        df_selection(d)
      })
    }
  )
}

# Filter Rows Module
mod_filter_rows_UI <- function(id) {
  ns <- NS(id)
  tagList(
    sliderInput(ns("filter_cyl"), "Cylinders", min = min(df$cyl), max = max(df$cyl), value = range(df$cyl))
  )
}

mod_filter_rows <- function(id, df_selection, df_final, slider_ui_values) {
  moduleServer(
    id,
    function(input, output, session) {
      # filter the cyl
      # observeEvent(list(input$filter_cyl, exclude_button()), {
      observe({
        d <- df_selection()
        print(glue("Filter set to {input$filter_cyl %>% paste(collapse = ' - ')}"))
        d <- d %>% filter(cyl >= min(input$filter_cyl), 
                          cyl <= max(input$filter_cyl))
        df_final(d)
      })
      
      # updates the slider values
      observe({
        v <- slider_ui_values()
        print(glue("Slider updated to range {v$min} - {v$max} | selected {paste(v$range, collapse = ' - ')}"))
        updateSliderInput(session, "filter_cyl", min = v$min, max = v$max, value = v$range)
      })
    }
  )
}

# Table Output
mod_dt_output_UI <- function(id) {
  ns <- NS(id)
  tagList(
    dataTableOutput(ns("table"))
  )
}
mod_dt_output <- function(id, df_final) {
  moduleServer(
    id,
    function(input, output, session) {
      output$table <- renderDataTable(df_final())
      return(reactive(input$table_rows_selected))
    }
  )
}


# Shiny App
ui <- fluidPage(
  mod_filter_rows_UI("filter1"),
  mod_exclude_rows_UI("exclude1"),
  mod_reset_UI("reset1"),
  mod_dt_output_UI("dt1")
)

server <- function(input, output, session) {
  df_all <- reactiveVal()
  df_selection <- reactiveVal() # without excluded cars
  df_final <- reactiveVal()     # filtered by cyl
  slider_ui_values <- reactiveVal() # the values for the 
  
  print(glue("Initial Data Loaded"))
  df_all(df)
  df_selection(df)
  df_final(df)
  
  # Call Modules
  selected_rows <- mod_dt_output("dt1", df_final)
  
  mod_exclude_rows("exclude1", df_selection, selected_rows)
  mod_reset_server("reset1", df_all, df_selection, df_final, slider_ui_values)
  mod_filter_rows("filter1", df_selection, df_final, slider_ui_values)
}

shinyApp(ui, server)

02a-test-modules.R

library(shiny)
library(tidyverse)
library(testthat)
library(DT)

df <- mtcars %>% 
  rownames_to_column("car") %>% 
  select(car, everything())

df_selection <- reactiveVal(df)
df_final <- reactiveVal(df)
slider_ui_values <- reactiveVal(list(min = 4, max = 8, range = c(4, 8)))

testServer(mod_filter_rows, 
           args = list(df_selection = df_selection, 
                       df_final = df_final,
                       slider_ui_values = slider_ui_values), 
           {
  expect_null(input$filter_cyl)
  
  print(glue("df_final ({nrow(df_final())}) & df_selection ({nrow(df_final())})"))
  expect_equal(nrow(df_selection()), nrow(df))
  expect_equal(nrow(df_final()), nrow(df))
  
  # Give filter_cyl a value
  session$setInputs(filter_cyl = c(6, 7))
  
  # changing the filter_cyl, should trigger the server_function, thus reducint the rows of df_final
  expect_equal(nrow(df_final()), nrow(df %>% filter(cyl <= 7, cyl >= 6)))
  expect_true(df_final()$cyl %>% max() <= 7)
  expect_true(df_final()$cyl %>% min() >= 6)
})