How to get a click event on a graph in module shiny - r

I'm new to shiny.
When I try to handle a click or brush event without using modules, everything works ok.
What should I do to make the events work inside the module?
There is simple code
#MODULE
plUI <- function(id) {
tagList(
selectInput(NS(id, "var"), "Variable", choices = names(mtcars)),
numericInput(NS(id, "bins"), "bins", value = 10, min = 1),
plotOutput(NS(id, "hist"), click = "plot_click"),
verbatimTextOutput("info")
)
}
plServer <- function(id) {
moduleServer(id, function(input, output, session) {
data <- reactive(mtcars[[input$var]])
output$hist <- renderPlot({
plot(data(), breaks = input$bins, main = input$var)
}, res = 96)
output$info <- renderPrint({
req(input$plot_click)
x <- round(input$plot_click$x, 2)
y <- round(input$plot_click$y, 2)
cat("[", x, ", ", y, "]", sep = "")
})
})
}
#------------------------------UI-------------------------------------
ui <- fluidPage(
ui <- fluidPage(
plUI("p1"),
)
)
#------------------------------SERVER-------------------------------------
server <- function(input, output, session) {
plServer("p1")
}
shinyApp(ui, server)

Instead of NS(id, "var") for each id, you can do ns <- NS(id) and then use ns("var") and so on.
plot_click is also an id so wrap it in ns as well.
You had forgotten NS in verbatimTextOutput("info").
The main ui had two fluidPage that probably was by mistake so removed it.
library(shiny)
plUI <- function(id) {
ns <- NS(id)
tagList(
selectInput(ns("var"), "Variable", choices = names(mtcars)),
numericInput(ns("bins"), "bins", value = 10, min = 1),
plotOutput(ns("hist"), click = ns("plot_click")),
verbatimTextOutput(ns("info"))
)
}
plServer <- function(id) {
moduleServer(id, function(input, output, session) {
ns <- session$ns
data <- reactive(mtcars[[input$var]])
output$hist <- renderPlot({
plot(data(), breaks = input$bins, main = input$var)
}, res = 96)
output$info <- renderPrint({
req(input$plot_click)
x <- round(input$plot_click$x, 2)
y <- round(input$plot_click$y, 2)
cat("[", x, ", ", y, "]", sep = "")
})
})
}
#------------------------------UI-------------------------------------
ui <- fluidPage(
plUI("p1")
)
#------------------------------SERVER-------------------------------------
server <- function(input, output, session) {
plServer("p1")
}
shinyApp(ui, server)

Related

General input for different modules in shiny

I have a ui and a server module in shiny just like in an example in 'Mastering Shiny' by Hadley Wickham:
histogramUI <-
function(id){
tagList(
selectInput(NS(id, "var"), "Variable", choices = names(mtcars)),
numericInput(NS(id, "bins"), "bins", value = 10, min = 1),
plotOutput(NS(id, "hist"))
)
}
histogramServer <-
function(id){
moduleServer(id, function(input, output, session){
data <- reactive(mtcars[[input$var]])
output$hist <- renderPlot({
hist(data(), breaks = input$bins, main = input$var)
}, res = 96)
})
}
Now I want to create the app with two inputs and outputs named by "hist1" and "hist2".
That works fine with the following code:
histogrammApp <-
function(){
ui <- fluidPage(
histogramUI("hist1"),
histogramUI("hist2")
)
server <- function(input, output, session){
histogramServer("hist1")
histogramServer("hist2")
}
shinyApp(ui, server)
}
Each plot has its own input parameters.
Let's say I want to have a general input bins instead so that both plots will have the same amount of breaks in a numericInput. How could I achieve this?
My first attempt was to remove the line numericInput(NS(id, "bins"), "bins", value = 10, min = 1), and place the line tagList(numericInput("bins", "bins", value = 10, min = 1)), before the line histogramUI("hist1"), but this did not work. I get the following error: Invalid breakpoints produced by 'breaks(x)': NULL. input$bins is NULL, I guess. I think because it is in a different namespace? How could I come up with the problem?
You should consider passing the input$bins as a reactive to histogramServer("hist1",reactive(input$bins)). Try this
histogramUI <- function(id){
tagList(
selectInput(NS(id, "var"), "Variable", choices = names(mtcars)),
#numericInput(NS(id, "bins"), "bins", value = 10, min = 1),
plotOutput(NS(id, "hist"))
)
}
histogramServer <- function(id,bins){
moduleServer(id, function(input, output, session){
data <- reactive(mtcars[[input$var]])
output$hist <- renderPlot({
hist(data(), breaks = bins(), main = input$var)
}, res = 96)
})
}
#histogrammApp <- function(){
ui <- fluidPage(
numericInput("bins", "Bins", value = 10, min = 1),
histogramUI("hist1"),
histogramUI("hist2")
)
server <- function(input, output, session){
histogramServer("hist1",reactive(input$bins))
histogramServer("hist2",reactive(input$bins))
}
shinyApp(ui, server)
# }
#
# histogrammApp()

How to save and restore bookmark state using rds file instead of copying and pasting url?

I'm trying to run a shiny app locally on my desktop and I'm looking for a way to download and upload the bookmark state as an rds file instead of copying and pasting a url. I've tried workarounds but they are not as helpful as using shiny's bookmark functions and features. Here is an example app which has the bookmark function. I'm trying to convert this into an app that can download and upload rds file to save and restore the state. Any help will be greatly appreciated.
library(shiny)
library(janitor)
histogramUI <- function(id,var,bins) {
tagList(
fluidRow(column( 4, selectInput(NS(id, "var"), "Variable", choices = names(mtcars),selected=var),
numericInput(NS(id, "bins"), "bins", value = bins, min = 1)),
column(8, plotOutput(NS(id, "hist"))))
)
}
histogramServer <- function(id) {
moduleServer(id, function(input, output, session) {
data <- reactive(mtcars[[input$var]])
output$hist <- renderPlot({
hist(data(), breaks = input$bins, main = input$var)
}, res = 96)
})
}
tableUI <- function(id,var,bins) {
tagList(
fluidRow(column( 4, selectInput(NS(id, "var"), "Variable", choices = names(mtcars),selected=var),
column(8, tableOutput(NS(id, "tab")))))
)
}
tableServer <- function(id) {
moduleServer(id, function(input, output, session) {
data <- reactive(mtcars[[input$var]])
output$tab <- renderTable({
tabyl(data(), main = input$var)
})
})
}
boxUI <- function(id,var) {
tagList(
fluidRow(column( 4, selectInput(NS(id, "var2"), "Variable", choices = names(mtcars),selected=var),
column(8, plotOutput(NS(id, "box"))))
))
}
boxServer <- function(id) {
moduleServer(id, function(input, output, session) {
data <- reactive(mtcars[[input$var2]])
output$box <- renderPlot({
boxplot(data(), main = input$var2)
})
})
}
ui <- function(request){
fluidPage(
bookmarkButton(),
actionButton("add", "Add Histogram"),
actionButton("add2", "Add Boxplot"),
actionButton("add3", "Add Table"),
div(id = "add_here")
)
}
server <- function(input, output, session) {
setBookmarkExclude(c('add','add2','add3'))
add_id <- reactiveVal(0)
add2_id <- reactiveVal(0)
add3_id <- reactiveVal(0)
observeEvent(input$add, {
bins <- 10
histogramServer(paste0("hist_", input$add+add_id()))
insertUI(selector = "#add_here", ui = histogramUI(paste0("hist_", input$add+add_id()),input$var,bins))#}
})
observeEvent(input$add2, {
boxServer(paste0("box_", input$add2+add2_id())) #changed add_id() to add2_id()
insertUI(selector = "#add_here", ui = boxUI(paste0("box_", input$add2+add2_id()), input$var2))
})
observeEvent(input$add3, {
tableServer(paste0("tab_", input$add3+add3_id()))
insertUI(selector = "#add_here", ui = tableUI(paste0("tab_", input$add3+add3_id()), input$var))
})
onBookmark(function(state) {
state$values$modules <- state$exclude
state$values$add <- state$input$add + add_id()
state$values$add2 <- state$input$add2 + add2_id()
state$values$add3 <- state$input$add3 + add3_id()
})
onRestore(function(state){
add_id(state$values$add)
add2_id(state$values$add2)
add3_id(state$values$add3)
modules <- state$values$modules
if (length(modules)>1) {
for (i in 1:(length(modules))) {
if (substr(modules[i],1,4)=='hist') {
histogramServer(modules[i])
insertUI(selector = "#add_here", ui = histogramUI(modules[i],paste0(modules[i],"-var"),paste0(modules[i],"-bin")))
}
if (substr(modules[i],1,3)=='box') {
boxServer(modules[i])
insertUI(selector = "#add_here", ui = boxUI(modules[i],paste0(modules[i],"-var")))
}
if (substr(modules[i],1,3)=='tab') {
tableServer(modules[i])
insertUI(selector = "#add_here", ui = tableUI(modules[i],paste0(modules[i],"-var")))
}
}
}
})
}
shinyApp(ui, server, enableBookmarking = "server")
This question is also posted here

How to bookmark and restore dynamically added modules?

I am trying to save and restore an app that uses modules which render UI outputs dynamically.
I hoped the bookmarking function would work with the app and I added the bookmarkButton and enabled bookmarking using enableBookmarking = "server". I've also made the ui a function. I learned that bookmarking works with modules, but I'm unable to find a way to get it working with dynamically created UI inputs and outputs. Only the last input and output are restored. The others are not restored.
Example app:
library(shiny)
histogramUI <- function(id) {
tagList(
fluidRow(column( 4, selectInput(NS(id, "var"), "Variable", choices = names(mtcars)),
numericInput(NS(id, "bins"), "bins", value = 10, min = 1)),
column(8, plotOutput(NS(id, "hist"))))
)
}
histogramServer <- function(id) {
moduleServer(id, function(input, output, session) {
data <- reactive(mtcars[[input$var]])
output$hist <- renderPlot({
hist(data(), breaks = input$bins, main = input$var)
}, res = 96)
})
}
ui <- function(request){
fluidPage(
bookmarkButton(),
actionButton("add", "Add"),
div(id = "add_here")
)
}
server <- function(input, output, session) {
observeEvent(input$add, {
histogramServer(paste0("hist_", input$add))
insertUI(selector = "#add_here", ui = histogramUI(paste0("hist_", input$add)))
})
}
shinyApp(ui, server, enableBookmarking = "server")
Only the last input and plot output are restored:
One would expect all module instances to be restored, but as you pointed out, only the last one is restored due to addbutton restoration.
As a workaround, you could store the module instances list stored in state$exclude with onBookmark and re-create the instances of the module with onRestore.
histogramUI was modified in order to accept var,bins as new parameters for creation of the modules.
Another important point is to use setBookmarkExclude so that the add button doesn't create the last module at restoration. As the button isn't anymore bookmarked, it's value should be also be saved with onBookmark.
Try:
library(shiny)
histogramUI <- function(id,var,bins) {
tagList(
fluidRow(column( 4, selectInput(NS(id, "var"), "Variable", choices = names(mtcars),selected=var),
numericInput(NS(id, "bins"), "bins", value = bins, min = 1)),
column(8, plotOutput(NS(id, "hist"))))
)
}
histogramServer <- function(id) {
moduleServer(id, function(input, output, session) {
data <- reactive(mtcars[[input$var]])
output$hist <- renderPlot({
hist(data(), breaks = input$bins, main = input$var)
}, res = 96)
})
}
ui <- function(request){
fluidPage(
bookmarkButton(),
actionButton("add", "Add Histogram"),
div(id = "add_here")
)
}
server <- function(input, output, session) {
add_id <- reactiveVal(0) # To save 'add' button state
setBookmarkExclude('add') # Don't add new module at restoration
observeEvent(input$add, {
histogramServer(paste0("hist_", input$add+add_id()))
insertUI(selector = "#add_here", ui = histogramUI(paste0("hist_", input$add+add_id()),'mpg',10))
})
onBookmark(function(state) {
modules <- state$exclude
state$values$modules <- modules[grepl("hist",modules)] # only 'hist' (without 'add')
state$values$add <- state$input$add + add_id() # add button state
})
onRestore(function(state){
# Restore 'add' last state
add_id(state$values$add)
# Restore 'hist' modules
modules <- state$values$modules
if (length(modules)>0) {
for (i in 1:(length(modules))) {
histogramServer(modules[i])
insertUI(selector = "#add_here", ui = histogramUI(modules[i],paste0(modules[i],"-var"),paste0(modules[i],"-bin")))
}
}
})
}
shinyApp(ui, server, enableBookmarking = "server")
Another way to do it:
library(shiny); library(purrr)
histogramUI <- function(id) {
ns <- NS(id)
tagList(
fluidRow(column( 4, selectInput(ns("var"), "Variable", choices = names(mtcars)),
numericInput(ns("bins"), "bins", value = 10, min = 1)),
column(8, plotOutput(ns("hist"))))
)
}
histogramServer <- function(id) {
moduleServer(id, function(input, output, session) {
vals <- reactiveValuesToList(input)
data <- reactive(mtcars[[input$var]])
output$hist <- renderPlot({
hist(data(), breaks = input$bins, main = input$var)
}, res = 96)
#to avoid inputs resetting after adding another.
if(length(vals) != 0) {
updateSelectInput(session, 'var', "Variable", choices = names(mtcars), selected = vals$var)
updateNumericInput(session, 'bins', "bins", value = input$bins, min = 1,)
}
})
}
ui <- function(request){
fluidPage(
bookmarkButton(),
actionButton("add", "Add"),
uiOutput('histogram_module')
)
}
server <- function(input, output, session) {
observeEvent(input$add, {
#the server module
map(1:input$add, ~histogramServer(paste0("hist_", .x)))
#the ui module
output$histogram_module <- renderUI({ map(1:input$add, ~histogramUI(id = paste0("hist_", .x))) })
})
}
shinyApp(ui, server, enableBookmarking = "server")

How to generate multiple plots using modules?

I'm trying to create multiple plots using modules, each plot with it's own input. But when I tried to run the app, only the inputs are added each time I add using insertUI and the plot output is blank.
I've tried connecting the ui and the server modules with the same id ("hist1") but it doesn't seem to connect each individual module.
histogramUI <- function(id) {
tagList(
selectInput(NS(id, "var"), "Variable", choices = names(mtcars)),
numericInput(NS(id, "bins"), "bins", value = 10, min = 1),
plotOutput(NS(id, "hist"))
)
}
histogramServer <- function(id) {
moduleServer(id, function(input, output, session) {
data <- reactive(mtcars[[input$var]])
output$hist <- renderPlot({
hist(data(), breaks = input$bins, main = input$var)
}, res = 96)
})
}
ui <- fluidPage(
actionButton("add", "Add"),
div(id = "add_here")
)
server <- function(input, output, session) {
histogramServer("hist1")
observeEvent(input$add, {
insertUI(selector = "#add_here", ui = histogramUI("hist1"))
})
}
shinyApp(ui,server)
Here is a solution where every time you click add you generate a new pair of histogramServer/histogramUI which have the same id (but a different one than the one before, because add gets incremented):
library(shiny)
histogramUI <- function(id) {
tagList(
selectInput(NS(id, "var"), "Variable", choices = names(mtcars)),
numericInput(NS(id, "bins"), "bins", value = 10, min = 1),
plotOutput(NS(id, "hist"))
)
}
histogramServer <- function(id) {
moduleServer(id, function(input, output, session) {
data <- reactive(mtcars[[input$var]])
output$hist <- renderPlot({
hist(data(), breaks = input$bins, main = input$var)
}, res = 96)
})
}
ui <- fluidPage(
actionButton("add", "Add"),
div(id = "add_here")
)
server <- function(input, output, session) {
observeEvent(input$add, {
histogramServer(paste0("hist_", input$add))
insertUI(selector = "#add_here", ui = histogramUI(paste0("hist_", input$add)))
})
}
shinyApp(ui,server)

I cant get a shiny module to work as a server . Only works when the server is separated as a separate set of commands

I have a shiny module and I'm having a huge issue getting it to work. I'm trying to create a dashboard with multiple tabs and am exploring modules to reduce the amount of duplication.
I can get the application to work if I hardcode the server explicitly with the code but when I create modules for the server part it doesn't won't work. I would really appreciate any help as I have tried looking everywhere for a workable example, Below is a reproducible example of a proportion of the code that I would like to modulize,
datasetInput <- function(id, Taxhead = NULL) {
ns <- NS(id)
names <- colnames(mtcars)
if (!is.null(Taxhead)) {
pattern <- paste0(Taxhead)
names <-names$name[sapply(names, function(x){ grepl(pattern,x, ignore.case = TRUE)})] #### filter for a match
}
selectInput(ns("dataset"), "Pick a Report", choices = names)
}
#### Server 1
#### Collect the data set based on the selection in datasetInput
datasetServer <- function(id) {
moduleServer(id, function(input, output, session) {
#### Outputs the data set
#### reactive( read.csv(paste0("Data/",input$dataset,".csv")) )
reactive( mtcars )
})}
#### Display the variables of interest
selectVarInput <- function(id){
ns <- NS(id)
tagList(
selectInput(ns("var"), "Select grouping Variables", choices = NULL, multiple = TRUE) ,
selectInput(ns("var2"), "Select Measure Variables", choices = NULL, multiple = TRUE)
) }
##### Server 2
#### Returns the data as a reactive
selectVarServer <- function(id, data) {
find_vars <- function(data, filter) { names(data)}
moduleServer(id, function(input, output, session) {
observeEvent(data(), {
updateSelectInput(session, "var", choices = find_vars(data()))
})
observeEvent(data(), {
updateSelectInput(session, "var2", choices = find_vars(data()))
})
reactive(data() %>% group_by(across(all_of(input$var))) %>% summarise(across(all_of(input$var2),sum), n = n()))
})}
selectDataVarUI <- function(id, Taxhead =NULL) {
ns <- NS(id)
tagList(
datasetInput(ns("data"), Taxhead ),
selectVarInput(ns("var"))
)}
#### Server 3
selectDataVarServer <- function(id) {
moduleServer(id, function(input, output, session) {
data <- datasetServer("data")
var <- selectVarServer("var", data)
var })}
Date_Range_UI <- function(id) {
ns <- NS(id)
# Sidebar to demonstrate various slider options ----
tagList(
# Sidebar with a slider input
# # Select form input for checking
radioButtons(ns("Period"),
label = "Select Desired Comparison Period",
choices = c( "Daily", "Monthly","Yearly"),
selected = "Monthly")
,
# Only show this panel if Monthly or Quarterly is selected
conditionalPanel(
condition = "input.Period != 'Yearly'", ns = ns,
dateRangeInput(ns('dateRange'),
label = 'Date range input',
start = Sys.Date()-180,
end = Sys.Date() ,
min = NULL, max = Sys.Date() ,
separator = " - ", format = "MM-yyyy",
startview = 'year', language = 'en', weekstart = 0,autoclose = TRUE))
,
# Only show this panel if Custom is selected
conditionalPanel(
condition = "input.Period == 'Yearly'", ns = ns,
sliderInput(ns("yearly"), "Years", min = 2000, max = as.integer(format(Sys.Date(),"%Y")), value = c(2008,2021), round = TRUE,step = 1)),
) ### close side bar layout
### close fluid page layout
}
Date_Range_Server <- function(id ) {
moduleServer(id,
function(input, output, session) {
x <- reactive({input$Period})
return(
list(
Startdate = reactive(if(x() == "Yearly") {input$yearly[1]
}
else if(x() == "Monthly") {
as.integer(format(input$dateRange[1],"%Y%m"))
}else{
as.integer(format(input$dateRange[1],"%Y%m%d"))})
,
Enddate = reactive(if(x() == "Yearly") {input$yearly[2]
}
else if(x() == "Monthly") {
as.integer(format(input$dateRange[2],"%Y%m"))
}else{
as.integer(format(input$dateRange[2],"%Y%m%d"))})
,
Choice = reactive(input$Period )))
})}
###### this won't work!
betting_UI <- function(id) {
ns <- NS(id)
sidebarLayout(
sidebarPanel(
Date_Range_UI("data_range"),
selectDataVarUI(id = "var", Taxhead =NULL)),
mainPanel(
tableOutput(ns("table")),
verbatimTextOutput (ns("test"))
)) }
Betting_Server <- function(input, output, session) {
date_range <- Date_Range_Server("data_range")
output$test <- renderPrint( date_range$Startdate())
output$table <- renderTable(var(), width = 40)
}
ui <- fluidPage(
betting_UI("betting")
)
server <- function(input, output, session) {
Betting_Server("betting")
}
shinyApp(ui, server)**
##### this works fine I thought putting the modules into the server would work as above?????
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
Date_Range_UI("data_range"),
selectDataVarUI(id = "var", Taxhead =NULL)),
mainPanel(
tableOutput("table"),
verbatimTextOutput ("test")
)) )
#### Server
server <- function(input, output, session) {
var <- selectDataVarServer("var")
date_range <- Date_Range_Server("data_range")
output$test <- renderPrint( date_range$Startdate())
output$table <- renderTable(var(), width = 40)
}
shinyApp(ui, server)
You have to use ns() in your module UI
betting_UI <- function(id) {
ns <- NS(id)
sidebarLayout(
sidebarPanel(
Date_Range_UI(ns("data_range")),
selectDataVarUI(id = ns("var"), Taxhead = NULL)
),
mainPanel(tableOutput(ns("table")),
verbatimTextOutput (ns("test")))
)
}
You also have to use moduleServer() to create the module server
Betting_Server <- function(id) {
moduleServer(id,
function(input, output, session) {
var <- selectDataVarServer("var")
date_range <- Date_Range_Server("data_range")
output$test <- renderPrint(date_range$Startdate())
output$table <- renderTable(var(), width = 40)
})
}

Resources