Shiny modules: how to access selected_rows with DT::datatables? - r

When using shiny modules and DT::datatable I would like to access the selected_rows server-side.
If my DT:datatable ID is my_DT_table then I would expect that the object input$my_DT_table_selected_rows contains the index of the selected row.
This works perfectly well in shiny applications without modules.
However, if I use modules then this approach no longer works and the input object input$my_DT_table_selected_rows no longer contains the index of the selected row.

When working with DT:datatable function we can use built-in functionality to learn about selected rows in the UI.
The object: input$my_DT_table_rows_selected contains the index of the selected row where my_DT_table is the ID of the DT::datatable.
However, when working with modules, the name of the table is now different. It has a prefix which is equal to the ID used to call the module's UI function.
So if that ID is my_ID then the table name will become: my_ID-table_name (note the hyphen after the ID).
This can be easily verified using the developer tools in your browser (e.g. inspector in FireFox).
And the associated input object name then becomes (and we need back ticks to prevent R from interpreting the hyphen as a minus sign):
input$`my_ID-table_name_rows_selected`
Here is a very basic example with some additional learning regarding how to pass a reactive object to a module. The reactive object contains the index of the selected line. I need to pass it without parenthesis. Inside of the module_server function I refer to the reactive object with parenthesis.
UI module in ui_module.R
module_ui <- function(id) {
ns <- NS(id) # create namespace
tagList(
fluidRow(column(6, DT::dataTableOutput(ns("dt_table")))),
fluidRow(column(4, verbatimTextOutput(ns("render_selected_line"))))
)
}
Server module in server_module.R
table_server <- function(input, output, session, data) {
output$dt_table <- DT::renderDataTable(
DT::datatable(
data = data,
selection = "single"
)
)
}
selected_line_server <- function(input, output, session, data) {
output$render_selected_line <- renderText({
paste0("My selection was: ", data()) # refer to the reactive object with parenthesis
})
}
Shiny application
library(shiny)
library(dplyr)
library(DT)
source("./modules/ui_module.R")
source("./modules/server_module.R")
ui <- fluidPage(
module_ui("my_ID")
)
server = function(input, output, session) {
data <- mtcars
callModule(table_server, id = "my_ID", data = data) # data is not reactive
callModule(selected_line_server, id = "my_ID", data = selectedLine) # refer to the reactive object selectedLine without parenthesis
selectedLine <- reactive({
req(input$`my_ID-dt_table_rows_selected`)
if (is.null(input$`my_ID-dt_table_rows_selected`)) {
return(NULL)
} else {
rows_selected <- as.numeric(input$`my_ID-dt_table_rows_selected`) # we need to prefix dt_table_rows_selected with the ID of the UI function "my_ID" and a hyphen
}
})
}
shinyApp(ui = ui, server = server)

Related

Shiny automatically visit each screen and evaluate its reactive values

I have a shiny app that has multiple tabs/screens (tabItems to be precise).
Each screen has a couple of charts that are constructed using reactive() data objects. As the data objects can take some time to construct, I have cached them using memoise (where the cache is saved to disk, note the memoisation is not shown as it is beside the question). Once the app is run the cache will fill automatically but I want to prefill the cache for the default values to have a better user experience for the first usage (there is some potential filtering going so therefore some waiting times will occur later on anyways on but that is beside the question I think).
That is, ideally I would like to have an option that automatically visits each screen and thereby evaluating each reactive value (and thus filling the cache). In the example app below the memoisation/caching is mocked by printing to the console.
MWE
A simple app with two screens would look like the example below.
Now I want to be able to visit tab 1 and tab 2 automatically from a separate R script to force the evaluation of the reactive values (eg in this case this would print the "Evaluating Reactive Element in Server id ui1" + ui2)
library(shiny)
# 1) Create a module that will be used multiple times
mod_ui <- function(id) {
ns <- NS(id)
tagList(
h1(paste("Tab with id", id)),
plotOutput(ns("plot"))
)
}
mod_server <- function(id) {
moduleServer(
id,
function(input, output, session) {
data <- reactive({
print(paste("Evaluating Reactive Element in Server id", id))
data.frame(x = 1:10, y = cumsum(rnorm(10)))
})
output$plot <- renderPlot(plot(data()$x, data()$y))
}
)
}
# 2) create the main app functionality
main_ui <- navbarPage(
"Example App",
tabPanel("Tab 1", mod_ui("ui1")),
tabPanel("Tab 2", mod_ui("ui2"))
)
main_server <- function(input, output, session) {
mod_server("ui1")
mod_server("ui2")
}
shinyApp(main_ui, main_server)
which (with the terminal output at the bottom) would look like this
Attemps
One possible solution is to use testServer to test the screens, but this requires that the script needs to be updated once a new reactive value is created or its name changes.
Eg with the app above, I could use the following
# repeat for each module-server
testServer(mod_server, args = list(id = "ui1"), {
a <- output$plot
# list other reactive values/plots here...
})
#> [1] "Evaluating Reactive Element in Server id ui1"
testServer(mod_server, args = list(id = "ui2"), {
a <- output$plot
# list other reactive values/plots here...
})
#> [1] "Evaluating Reactive Element in Server id ui2"
Ideally I would like something like the following
start_app_and_evaluate_all_reactive_values(main_server)
#> [1] "Evaluating Reactive Element in Server id ui1"
#> [1] "Evaluating Reactive Element in Server id ui2"
One partial solution that I am using so far is to define a list of all ids I want to visit and then evaluate the values with the (undocumented) shiny:::flushReact() like so:
ids <- c("ui1", "ui2")
for (id in ids) {
testServer(mod_server, args = list(id = id), {
shiny:::flushReact()
})
}
#> [1] "Evaluating Reactive Element in Server id ui1"
#> [1] "Evaluating Reactive Element in Server id ui2"

How to automatically collapse code in RShiny app server (reactives, renders, etc)

I am working with a very large RShiny app and want to take advantage of code folding to organize the server.R file in this application. However, when I use the code-fold hotkey, it does not fold the various elements defined in the server (the reactive, render, etc. elements).
I'd like to be able to take this
# observe some things
observe({
query <- parseQueryString(session$clientData$url_search)
if (!is.null(query[['tab']])) {
updateTabItems(session, "sidebarMenu", selected = query[['tab']])
}
if (!is.null(query[['player']])) {
updateSelectInput(session, "profile", selected = query[['player']])
}
})
# Lots of "reactive" data fetching functions
league_stats <- reactive({
get1 <- fetch('yada')
return(get1)
})
# another reactive
shooting <- reactive({
get1$SHORT_MR_MADE<-sum(get1$short_mr_fgm,na.rm=T)
...
...
)}
and collapse it into this (or something like this) by just hitting the code-collapse hotkey.
# observe some things
observe({--})
# Lots of "reactive" data fetching functions
league_stats <- reactive({--})
# another reactive
shooting <- reactive({--})
Is this possible to do with R / RStudio? I would like to avoid using the 4 # signs #### above the function to code fold, as this will hide the shooting <- reactive({--}) strings as well, however I'd like to still have show (and just hide the code inside).
I will oftentimes wrap code in functions since functions collapse, however I cannot wrap RShiny reactive elements in functions (or, i'm not sure how), as it seems like this breaks the app.
Shiny reactives behave as other functions, but you need to take care about passing to them the input, session or other reactives (as function, not as value) they need.
As an illustration :
library(shiny)
generateUI <- function() {fluidPage(
actionButton("do", "Click Me"),
textOutput('counter')
)}
ui <- generateUI()
myobserver <- function(input,counter) {
observeEvent(input$do, {
cat('Clicked \n')
counter(counter()+1)
})
}
myformater <- function(counter) {
renderText(paste('count is',counter()))
}
server <- function(input, output, session) {
counter <- reactiveVal(0)
myobserver(input,counter)
output$counter <- myformater(counter)
}
shinyApp(ui, server)
Collapsed code :
Another way to do this without creating them as functions is to put an identifier above each code chunk:
library(shiny)
# Generate UI ----
generateUI <- function() {fluidPage(
actionButton("do", "Click Me"),
textOutput('counter')
)}
ui <- generateUI()
# Observer ----
myobserver <- function(input,counter) {
observeEvent(input$do, {
cat('Clicked \n')
counter(counter()+1)
})
}
# Formatter ----
myformater <- function(counter) {
renderText(paste('count is',counter()))
}
# Server ----
server <- function(input, output, session) {
counter <- reactiveVal(0)
myobserver(input,counter)
output$counter <- myformater(counter)
}
shinyApp(ui, server)
You will then be able to collapse code segments in between the two identifiers to view as shown below:

Use functions or loops to create shiny UI elements

I am creating a shiny app and realized I am repeating a particular UI element so I am wondering if there is a way to wrap this in a function and supply parameters to make it work in different cases. In my server file, I have
output$loss <- renderUI({
req(input$got)
if(input$got %in% Years) return(numericInput('got_snow', label = 'John Snow', value = NA))
if(!input$got %in% Years) return(fluidRow(column(3)))
})
and in the ui file, I have:
splitLayout(
cellWidths = c("30%","70%"),
selectInput('got', label = 'Select age', choices = c('',Years) , selected = NULL),
uiOutput("loss")
)
Since I find myself using these several times and only changing a few things in both the UI and server files, I wanted to wrap these in a function and use them as and when I please. I tried this for the server file
ui_renderer <- function(in_put, label, id){
renderUI({
req(input[[in_put]])
if(input[[in_put]] %in% Years) return(numericInput(id, label = label, value = NA))
if(!input[[in_put]] %in% Years) return(fluidRow(column(3)))
})
}
output$p_li <- ui_renderer(input='li', "Enter age", id="c_li")
and in my ui file, I put
uiOutput('c_li')
but it's not working. Any help is greatly appreciated.
I was unable to test your code since there was no minimal working example. I don't know if this is a typo in your example, but your are trying to render c_li, but your output is called p_li. Not sure how wrapping a render object in a standard function works, but I have done something similar using reactive values instead.
This is a minimal example using some of your terminology. It is not a working example, but an outline of the idea to my proposed solution.
# Set up the UI ----
ui <- fluidPage(
uiOutput("loss")
)
# Set up the server side ----
server <- function(input, output, session) {
# Let us define reactive values for the function inputs
func <- reactiveValues(
value <- "got",
label <- "select age",
id <- "xyz"
)
# Set up an observer for when any of the reactive values change
observeEvent({
func$value
func$label
func$id
}, {
# Render a new UI any time a reactive value changes
output[["loss"]] <- renderUI(
if (input[[func$value]] %in% years) {
numericInput(func$id, label = func$label, value = NA)
} else {
fluidRow(
column(3)
)
}
)
})
}
# Combine into an app ----
shinyApp(ui = ui, server = server)
The general idea is to define a set of reactive values and set up an observer that will render the UI every time one or more of the reactive values change. You can assign a new value to any of the reactive values using direct assignment, e.g. current$value <- "object_two". Making that change will update the UI using Shiny's reactive pattern, which means you only need to change one value to update the UI.

R Shiny: Switching datasets based on user input

I am working on a shiny app where users can upload their own data and get some plots and statistics back. However, I also want to include an example dataset that gets used instead if the user presses a specific button. Importantly, the plots should be reactive so that users get updated plots whenever they click on the "use example data instead" button or upload a new file. I tried to recreate my current approach of overwriting the data object as best as I could here, but simply defining the data object twice doesn't overwrite the data in the way I hoped it would. Any suggestions are appreciated.
library(shiny)
# UI
ui <- fluidPage(
# Application title
titlePanel("Reproducible Example"),
# Sidebar with a slider input for number of bins
sidebarLayout(
sidebarPanel(
fileInput("Upload", "Upload your own Data"),
actionButton("Example", "Use Example Data instead")
),
# Show a plot of the generated distribution
mainPanel(
plotOutput("hist")
)
)
)
# Server Logic
server <- function(input, output) {
data <- eventReactive(input$Upload,{input$Upload})
data <- eventReactive(input$Example, {faithful$eruptions})
output$hist <- renderPlot({hist(data())})
}
# Run the application
shinyApp(ui = ui, server = server)
You can use a reactiveVal like this:
server <- function(input, output) {
my_data <- reactiveVal()
observeEvent(input$Upload, {
tmp <- read.csv(input$Upload$datapath)
## do whatever is needed to parse the data
my_data(tmp)
})
observeEvent(input$Example, {
my_data(faithful)
})
output$hist <- renderPlot({
dat <- as.data.frame(req(my_data()))
dat <- dat[, sapply(dat, is.numeric), drop = FALSE]
validate(need(NCOL(dat) > 1, "No numeric columns found in provided data"))
hist(dat[,1])
})
}
Depending on upload or button click, you store your data in my_data which is a reactive value. Whenever this value changes, the renderPlot function fires and uses the correct data.
You can use a reactive value to access whether the user has chosen to use an example dataset or use their own dataset. The user can choose to switch between the active dataset using an input from your UI.
Here's the official explanation on reactive values from RStudio: link
This would go in your ui.R:
radioButtons("sample_or_real",
label = h4("User data or sample data?"),
choices = list(
"Sample Data" = "sample",
"Upload from user data" = "user",
),
selected = "user"
)
This would go in your server.R:
data_active <- reactive({
# if user switches to internal data, switch in-app data
observeEvent(input$sample_or_real_button, {
if(input$sample_or_real == "sample"){
data_internal <- sample_data_object
} else {
data_internal <- uploaded_data_object
}
})
Note, that when using a reactive value in your server.R file, it must have parentheses () at the end of the object name. So, you call the data_internal object as data_internal().

Passing reactive values to functions and accessing reactive attributes

I want to take a reactive source through more than one reactive conductor before sending it to a reactive endpoint.
Generalized example:
x <- reactive({ function(input$var) })
y <-reactive({ function(x) })
output$display<-renderText({ y()$attr })
Below is a specific Example.
Thanks in advance
# Install packages if needed
packageNeeds <- c('shiny', 'httr', 'dataRetrieval')
packageNeeds <- packageNeeds[!packageNeeds %in% rownames(installed.packages())]
if(length(packageNeeds)>0){
install.packages(packageNeeds, repos='http://cran.cnr.Berkeley.edu')
}
library(shiny)
library(httr)
library(dataRetrieval)
shinyApp(
ui = fluidPage(
fluidRow(
wellPanel(
selectInput("site", label = p("Pick a site"), choices = list('01594440', 'sysys')),
selectInput("start", label = p("pick a date"), choices = list('1985-01-01', "xyz")))),
fluidRow(wellPanel(verbatimTextOutput("URL"))),
fluidRow(wellPanel(verbatimTextOutput("REC")))),
server = function(input, output, session){
url<-reactive({
# Here the user inputs are used to constuct a url -
# but really this could be any function that I'd like to take the output of
# and pass it on to other functions and/or subeset
# before sending to a reactive output
constructWQPURL(paste("USGS",input$site,sep="-"),
c('01075','00029','00453'),
input$start, endDate = "")
})
# This is the function I've passed the reactive value to
# it returns an object with a headers attributes that has the
# 'total-result-count' attribute I want
header_call = reactive({HEAD(url)})
output$URL<-renderText({
# The url displays fine
url()
})
output$REC<-renderText({
# The record count from the header pull does not display
# the value is the number of records stored as a string
header_call()$headers$'total-result-count'
})
}
)
One issue might be that you are missing parenthesis after url when you define header_call. url is a closure, url() returns the URL string.
Also renderText is reactive, so you can just call HEAD(url()) from there:
This works for me (I removed header_call = reactive({HEAD(url)})) :
output$REC<-renderText({
# The record count from the header pull does not display
# the value is the number of records stored as a string
#header_call()
HEAD(url())$headers$'total-result-count'
})

Resources