I'm trying to set up a simple Card game in Shiny and therefore want to use
callModule(...) inside of observeEvent(input$..,{}), so I can call the same module with different events occurring.
Unfortunately this does not seem to work.
I know, that if I simply use observeEvent(input$...,{}) inside my module the code does work but than I would have to define similar models for all possible Events.
playingUI <- function(id) {
ns <- NS(id)
tagList(# Create market and hand output
uiOutput(ns("market")),
uiOutput(ns("hand")),
# Actionbutton to take cards
actionButton(ns("take"),
label = "TAKE"))
}
player_server <- function(input, output, session, cards) {
# Pickerinput for Market
output$market <- renderUI(tagList(
pickerInput(
inputId = session$ns("market1"),
label = "Market",
choices = cards$market,
multiple = TRUE
),
# Pickerinput for Hand
pickerInput(
inputId = session$ns("Hand"),
label = "Hand",
choices = cards$hand,
multiple = TRUE
)
))
}
taking_server <- function(input, output, id, cards) {
cards$hand <- c(cards$hand, "new")
}
ui <- fluidPage(playingUI('game'))
server <- function(input, output, session) {
# Define playing cards
cards <- reactiveValues(
# Define market
market = c("Camel", "Gold", "Diamond"),
# Define hand
hand = c("Diamond", "Silver")
)
callModule(player_server, 'game', cards)
# Wrap the module 'taking_server' inside observe - does not work
observeEvent(input$take, {
callModule(taking_server, 'game', cards)
})
}
shinyApp(ui = ui, server = server)
Related
Goal
I have five expectations:
Solution using modules
Communication between modules
Dynamic creation of modules
local storage using shinyStore
Export result in dataframe
What has worked so far
This is a continuation of the following question.
I have a Shiny app that currently has two modules, but I have had issues with both of them communicating. The first module Selects any number of species within a Species pool (SpeciesSelect), this module is in the file R/SpeciesSelect.R within my working directory with the following code.
SpeciesSelect_UI <- function(id, SpeciesList){
ns <- NS(id)
tagList(
shiny::selectizeInput(inputId = ns("SpeciesNames"), label = "SpeciesName",
choices = SpeciesList,
multiple = T)
)
}
SpeciesSelect_Server <- function(id){
moduleServer(id, function(input, output, session) {
# return the reactive here
return(reactive({input$SpeciesNames}))
})
}
And the second module (SpeciesCount) would use those species in order to select how you sample them, and in some cases to count them when the method is equal to pinpoint. This is stored in R/SpeciesCount.R and the code is as follows:
SpeciesCount_UI <- function(id, Species){
ns <- NS(id)
tagList(
shinyMobile::f7Card(
f7Flex(
textOutput(ns("SpeciesAgain")),
uiOutput(ns("Sampling_type_ui")),
uiOutput(ns("SpeciesCount"))
)
)
)
}
SpeciesCount_Server <- function(id, Species){
moduleServer(id, function(input, output, session) {
output$SpeciesAgain <- renderText({Species})
ns <- session$ns
output$Sampling_type_ui <- renderUI({
#req(input$SpeciesName)
req(Species)
f7Select(inputId = ns("Sampling_type"),
label = "Sampling type",
choices = c("5m circle", "15m circle", "Pin-point"))
})
output$SpeciesCount <- renderUI({
if (req(input$Sampling_type) == "Pin-point") {
shinyMobile::f7Stepper(inputId = ns("Species1"), label = "Species count", min = 1, max = 1000, step = 1, value = 1)
}
})
})
}
Each of the modules is working well on its own as shown in the following example:
library(shiny)
library(shinyMobile)
library(shinyStore)
source("R/SpeciesCount.R")
source("R/SpeciesSelect.R")
SpeciesList <- c("Species1", "Species2", "Species3", "Species4", "Species5")
ui = f7Page(
title = "Show navbar",
f7SingleLayout(
navbar = f7Navbar("Hide/Show navbar"),
f7Button(inputId = "toggle", "Toggle navbar", color = "red"),
SpeciesSelect_UI(id = "SpeciesList", SpeciesList = SpeciesList),
lapply(seq_along(SpeciesList), function(i) {
SpeciesCount_UI(id = i, Species = SpeciesList[i])
})
)
)
server = function(input, output, session) {
lapply(seq_along(SpeciesList), function(i) {
SpeciesCount_Server(id = i, Species = SpeciesList[i])
})
observeEvent(input$toggle, {
updateF7Navbar()
})
}
shinyApp(ui, server)
I have 4 issues that are not working well, first, the communication between modules, and then looping through the results of the first module to get several of the second module, the localStorage issue, and finally exporting it to a dataframe
Communication between modules and dynamic UI generation
In order to isolate both issues, for the communication problem, I selected only one species and took out the lapply function to see if I can get the SpeciesCount to recognise the output of the SpeciesSelect_Server and incorporate it into the SpeciesCount module, here is the code I ended up with:
library(shiny)
library(shinyMobile)
library(shinyStore)
source("R/SpeciesCount.R")
source("R/SpeciesSelect.R")
LIST <- c("Species1", "Species2", "Species3", "Species4", "Species5")
ui = f7Page(
title = "Show navbar",
f7SingleLayout(
navbar = f7Navbar("Hide/Show navbar"),
f7Button(inputId = "toggle", "Toggle navbar", color = "red"),
SpeciesSelect_UI(id = "SpeciesList", SpeciesList = LIST),
SpeciesCount_UI(id = "SpeciesCount", Species = SpeciesSelected())
)
)
server = function(input, output, session) {
SpeciesSelected <- SpeciesSelect_Server(id = "SpeciesList")
SpeciesCount_Server(id = "SpeciesCount", Species = SpeciesSelected())
observeEvent(input$toggle, {
updateF7Navbar()
})
}
shinyApp(ui, server)
But the results of the SpeciesSelect module are not generating any UI in the SpeciesCount module
Adding the LocalStorage issue
This app is going to be used in the field, that means, that at time we might get connectivity issues, I have issues at storing the values of the Species Select Module, then for sure I will have issues with the next module this is the shiny app I am using
library(shiny)
library(shinyMobile)
library(shinyStore)
source("R/SpeciesCount.R")
source("R/SpeciesSelect.R")
SpeciesList <- c("Species1", "Species2", "Species3", "Species4", "Species5")
ui = f7Page(
title = "Show navbar",
f7SingleLayout(
navbar = f7Navbar("Hide/Show navbar"),
f7Button(inputId = "toggle", "Toggle navbar", color = "red"),
SpeciesSelect_UI(id = "SpeciesList", SpeciesList = SpeciesList),
lapply(seq_along(SpeciesList), function(i) {
SpeciesCount_UI(id = i, Species = SpeciesList[i])
})
)
)
server = function(input, output, session) {
lapply(seq_along(SpeciesList), function(i) {
SpeciesCount_Server(id = i, Species = SpeciesList[i])
})
observeEvent(input$toggle, {
updateF7Navbar()
})
}
shinyApp(ui, server)
And I modified the species select for that also
SpeciesSelect_UI <- function(id, SpeciesList){
ns <- NS(id)
tagList(
shiny::selectizeInput(inputId = ns("SpeciesNames"), label = "SpeciesName",
choices = SpeciesList,
multiple = T)
)
}
SpeciesSelect_Server <- function(id){
moduleServer(id, function(input, output, session) {
ns <- session$ns
# return the reactive here
observeEvent(input$save, {
updateStore(session, name = ns("SpeciesNames"), input$SpeciesNames)
}, ignoreInit = TRUE)
observeEvent(input$clear, {
# clear current user inputs:
updateTextInput(session, inputId = ns("SpeciesNames"), value = "")
# clear shinyStore:
updateStore(session, name = ns("SpeciesNames"), value = "")
}, ignoreInit = TRUE)
return(reactive({ns(input$SpeciesNames)}))
})
}
But nothing gets stored. Maybe creating a module for shiny store is needed?
Export as a dataframe
This one is tied two point 2:
So lets say I am in the following input set:
The idea would be to generate a reactive that has the following that frame, that I can then export as a CSV file. I think I can handle the export, but I am unsure on how to generate the data.frame from the dynamic UI:
data.frame(Species = c("Species1", "Species2", "Species3"), Method = c("Pin-point","5m circle", "15m circle"), abundance = c(5, 1, 1))
Your first module is probably already silently returning the reactive but for clarity you can make it explicit. In you first module, return a reactive:
SpeciesSelect_Server <- function(id){
moduleServer(id, function(input, output, session) {
# return the reactive here
return(reactive({input$SpeciesNames}))
})
}
Now call the module AND assign its output a name where you'd like to use it (in another module or in your app server), like this:
selected_species <- SpeciesSelect_Server(id = "SpeciesList")
Now selected_species can be called, observed, etc with:
selected_species()
Very new to Shiny here, I have a module like the one below where I just want 2 SelectizeInput menus with the same options each.
The trick is that they have to be mutually exclusive, so I understand I have to use updateSelectizeInput to update the selected options in one menu based on the selected options in the other.
This should work in such a way that if I select one option in one menu, it has to be removed from the selected options in the other menu, and vice versa.
I understand the moving pieces here, but I am not sure where to place them and how to finally accomplish this.
This is what I have so far:
mod_saving_side_ui <- function(id){
ns <- NS(id)
tagList(
shinyjs::useShinyjs(),
shinyalert::useShinyalert(),
uiOutput(outputId = ns("positive_markers")),
uiOutput(outputId = ns("negative_markers"))
)
}
mod_saving_side_server <- function(id, r){
moduleServer( id, function(input, output, session){
ns <- session$ns
output$positive_markers <- renderUI({
selectizeInput(inputId = ns("pos_markers"), label = "Positive:",
choices = LETTERS
selected = LETTERS[1],
multiple = TRUE)
})
output$negative_markers <- renderUI({
selectizeInput(inputId = ns("neg_markers"), label = "Negative:",
choices = LETTERS,
selected = LETTERS[2],
multiple = TRUE)
})
# add selected markers to the reactive values
observeEvent(input$pos_markers, {
r$pos_markers <- input$pos_markers
#selected_markers <- ALL EXCEPT pos_markers
#updateSelectizeInput(session, inputId = "neg_markers", selected = selected_markers)
})
observeEvent(input$neg_markers , {
r$neg_markers <- input$neg_markers
#selected_markers <- ALL EXCEPT neg_markers
#updateSelectizeInput(session, inputId = "pos_markers", selected = selected_markers)
})
})
}
Not sure if this is a standalone MWE... a side question would be how to make one with the above... Many thanks!
This should do what you asked.
I removed the extra calls to shinyjs and shinyalert and added call to library(shiny) to make it a MWE. I removed the argument r to the server call.
I've also moved the input to the UI, removed the uiOutput and renderUI as it wasn't needed in this case (I'm not sure if the are needed for other parts of your code). Then taking setdiff of the options gives you the new set to update the selectizeInput with.
I've also added code at the bottom to run and test the app.
library(shiny)
mod_saving_side_ui <- function(id){
ns <- NS(id)
tagList(
selectizeInput(inputId = ns("pos_markers"), label = "Positive:",
choices = LETTERS,
selected = LETTERS[1],
multiple = TRUE),
selectizeInput(inputId = ns("neg_markers"), label = "Negative:",
choices = LETTERS,
selected = LETTERS[2],
multiple = TRUE)
)
}
mod_saving_side_server <- function(id){
moduleServer(id, function(input, output, session){
ns <- session$ns
# add selected markers to the reactive values
observeEvent(input$neg_markers, {
selected_pos_markers <- input$pos_markers
selected_markers <- setdiff(selected_pos_markers, input$neg_markers)
updateSelectizeInput(session, inputId = "pos_markers", selected = selected_markers)
})
observeEvent(input$pos_markers , {
selected_neg_markers <- input$neg_markers
selected_markers <- setdiff(selected_neg_markers, input$pos_markers)
updateSelectizeInput(session, inputId = "neg_markers", selected = selected_markers)
})
})
}
demoApp <- function() {
ui <- fluidPage(
mod_saving_side_ui("demo")
)
server <- function(input, output, session) {
mod_saving_side_server("demo")
}
shinyApp(ui, server)
}
demoApp()
I have a selectizeInput with some grouped elements with multiple selection. Is there an elegant way (e.g. using the options argument) of allowing just one element per group, so that a whole group will discarded (or disabled) when an element of this specific group is selected?
So far I tried it programmatically, but than the dropdown menu of the selectizeInput will be closed when updating the selectizeInput.
Minimal example:
library(shiny)
ui <- fluidPage(
selectizeInput("selInput", "Default",
choices=list(g1 = c(A="A",B="B"),
g2 = c(C="C",D="D")),
multiple=T),
selectizeInput("oneElementPerGroup", "One element per group",
choices=list(g1 = c(A="A",B="B"),
g2 = c(C="C",D="D")),
multiple=T)
)
server <- function(session, input, output) {
#Removes the corresponding groups of selected items
observeEvent(input$oneElementPerGroup, ignoreNULL = F, {
plusChoice <- input$oneElementPerGroup
names(plusChoice) <- input$oneElementPerGroup
choices <- list(g1 = c(A="A",B="B"),
g2 = c(C="C",D="D"))
if(any(input$oneElementPerGroup %in% c("A", "B"))){
choices[["g1"]] <- NULL
}
if(any(input$oneElementPerGroup %in% c("C", "D"))){
choices[["g2"]] <- NULL
}
choices$we <- plusChoice
updateSelectizeInput(session,"oneElementPerGroup",
choices = choices,
selected=input$oneElementPerGroup)
})
}
shinyApp(ui = ui, server = server)
You can use pickerInput from {shinyWidgets}. Then we can add a little javascript to do what you want. No server code is needed, very simple. Read more about the data-max-options option: https://developer.snapappointments.com/bootstrap-select/options/.
We need to add the limit to each group, not an overall limit, so we can't add it through the options argument in pickerInput, have to do it in raw HTML or use some js code to inject like what I do.
Be sure your inputId="pick" matches the id in the script #pick. Rename pick to whatever you want.
ui <- fluidPage(
shinyWidgets::pickerInput(
inputId = "pick", label = "Selected",
choices =list(g1 = c(A="A",B="B"), g2 = c(C="C",D="D")),
multiple = TRUE
),
tags$script(
'
$(function(){
$("#pick optgroup").attr("data-max-options", "1");
})
'
)
)
server <- function(input, output, session){}
shinyApp(ui, server)
updates:
If you need to update, we need to run the script again but from server. We can send js by using {shinyjs}. Imagine an observer triggers the update event.
library(shinyjs)
ui <- fluidPage(
useShinyjs(),
shinyWidgets::pickerInput(
inputId = "pick", label = "Selected",
choices =NULL,
multiple = TRUE
)
)
server <- function(input, output, session){
observe({
shinyWidgets::updatePickerInput(session, "pick", choices = list(g1 = c(A="A",B="B"), g2 = c(C="C",D="D")))
observeEvent(once = TRUE, reactiveValuesToList(session$input), {
runjs('$("#pick optgroup").attr("data-max-options", "1");')
}, ignoreInit = TRUE)
})
}
shinyApp(ui, server)
I have been trying to reconstruct the following simplistic Shiny app using modules since I believe that will be the best way to organize this code inside a much larger application where I will use these kinds of linked-slider-numeric inputs in many places.
However, I cannot figure out how to achieve the same kind of functionality from within a module.
Here's an example app that works exactly as intended, but not using modules:
library(shiny)
# Let's build a linked Slider and Numeric Input
server <- function(input, output) {
values <- reactiveValues(numval=1)
observe({
values$numval <- input$slider
})
observe({
values$numval <- input$number
})
output$slide <- renderUI({
sliderInput(
inputId = 'slider'
,label = 'SN'
,min = 0
,max = 10
,value = values$numval
)})
output$num <- renderUI({
numericInput(
inputId = 'number'
,label = 'SN'
,value = values$numval
,min = 0
,max = 10
)
})
}
ui <- fluidPage(
uiOutput('slide'),
uiOutput('num')
)
shinyApp(ui, server)
Here's my attempt. (Note that "mortalityRate" and associated strings are just an example of the variable name(s) I'll be using later). I have tried several variations on this attempt, but inevitably I get errors, usually indicating I'm doing something that can only be done inside a reactive context:
numericSliderUI <- function(id, label = "Enter value", min = 1, max = 40, value) {
ns <- NS(id)
tagList(
sliderInput(inputId = paste0(ns(id), "Slider"), label = label, min = min, max = max, value = value),
numericInput(inputId = paste0(ns(id), "Numeric"), label = label, min = min, max = max, value = value)
)
}
numericSlider <-
function(input,
output,
session,
value,
mortalityRateSlider,
mortalityRateNumeric
) {
values <- reactiveValues(mortalityRate = value())
observe({
values[['mortalityRate']] <- mortalityRateSlider()
})
observe({
values[['mortalityRate']] <- mortalityRateNumeric()
})
return( reactive( values[['mortalityRate']] ) )
}
library(shiny)
# source("modules.R") # I keep the modules in a separate file, but they're just pasted above for convenience here on StackOverflow.
ui <- fluidPage(
uiOutput('mortalityRate')
)
server <- function(input, output) {
values <- reactiveValues(mortalityRate = 1)
mortalityRateValue <- callModule(
numericSlider,
id = 'mortalityRate',
value = values[['mortalityRate']],
mortalityRateSlider = reactive( input$mortalityRateSlider ),
mortalityRateNumeric = reactive( input$mortalityRateNumeric )
)
values[['mortalityRate']] <- reactive( mortalityRateValue() )
output$mortalityRate <- renderUI(numericSliderUI('mortalityRate', value = values[['mortalityRate']]))
}
shinyApp(ui = ui, server = server)
I know that I must be doing something wrong with the reactiveValues and the way I'm using the observe statements inside the module, but this is my best attempt at using the module structure, so any help figuring out what I'm doing wrong would be very helpful.
Here is working code. There are a variety of changes, so I'll direct you to this Github page that also sets up a structure for using renderUI with modules. In general, I think the problems in your code involved trying to define reactive values inside the callModule function, and in passing the values of the sliders and numeric box back and forth.
Other features of using modules are that in your actual UI call, you need to call the UI module, where in turn you can call uiOutput. Inside renderUI is where you can set up the inputs. Additionally, inside modules you don't need the session namespaces, but you do need to wrap those ids in session$ns() to ensure they work across modules.
UI and Server Modules:
numericSliderUI <- function(id) {
ns <- NS(id)
uiOutput(ns('mortalityRate'))
}
numericSlider <- function(input, output, session) {
values <- reactiveValues(mortalityRate = 1)
observe({
values[['mortalityRate']] <- input$Slider
})
observe({
values[['mortalityRate']] <- input$Numeric
})
output$mortalityRate <- renderUI(
tagList(
sliderInput(inputId = session$ns("Slider"), label = "Enter value:", min = 1, max = 40, value = values[['mortalityRate']]),
numericInput(inputId = session$ns("Numeric"), label = "Enter value:", min = 1, max = 40, value = values[['mortalityRate']])
)
)
return(list(value = reactive({values[['mortalityRate']]})))
}
UI and Server functions:
ui <- fluidPage(
numericSliderUI('mortalityRate')
)
server <- function(input, output, session) {
mortalityRateValue <- callModule(numericSlider, 'mortalityRate')
}
shinyApp(ui = ui, server = server)
I use reactiveValues in Shiny a lot as they are more flexible than just the input and output objects. Nested reactiveValues are tricky since any changes in any of the children also triggers the reactivity linked to the parents. To get around this, I tried to make two different reactiveValues objects ( not two objects in the same list, but two different lists altogether ) and it seems to be working. I'm not able to find any example of this and want to find out if it's suppose to work this way. Are there any issues that might arise because of this?
In this app, there are two reactive values objects - reac1 and reac2. Each of them are linked to a drop down, column1 and column2 respectively. Changing column1 or column2 updates the reactive values with the latest time, updates the plot, and prints the latest values in reac1 and reac2.
ui = fluidPage(
titlePanel("Multiple reactive values"),
sidebarLayout(
sidebarPanel(
selectInput(inputId = "column1", "Reac1", letters, selected = "a"),
selectInput(inputId = "column2", "Reac2", letters, selected = "a")
),
mainPanel(
plotOutput("plot1")
)
)
)
server = function(input, output, session) {
reac1 <- reactiveValues(asdasd = 0)
reac2 <- reactiveValues(qweqwe = 0)
# If any inputs are changed, set the redraw parameter to FALSE
observe({
input$column2
reac2$qweqwe = Sys.time()
})
observe({
input$column1
reac1$asdasd = Sys.time()
})
# Only triggered when the copies of the inputs in reac are updated
# by the code above
output$plot1 <- renderPlot({
print(paste(reac1$asdasd, 'reac1'))
print(paste(reac2$qweqwe, 'reac2'))
hist(runif(1000))
})
}
shinyApp(ui, server)
ReactiveValues are like a read/write version of input$, and you can have several 'independent' variables inside one reactiveValue list. So, you do not need two reactive values in your example. See code below.
ui = fluidPage(
titlePanel("Multiple reactive values"),
sidebarLayout(
sidebarPanel(
selectInput(inputId = "column1", "Reac1", letters, selected = "a"),
selectInput(inputId = "column2", "Reac2", letters, selected = "a")
),
mainPanel(
verbatimTextOutput("txt1"),
verbatimTextOutput("txt2")
)
)
)
server = function(input, output, session) {
reac <- reactiveValues()
#reac2 <- reactiveValues(qweqwe = 0)
# If any inputs are changed, set the redraw parameter to FALSE
observe({
reac$asdasd = input$column1
})
observe({
reac$qweqwe = input$column2
})
# Only triggered when the copies of the inputs in reac are updated
# by the code above
output$txt1 <- renderPrint({
print('output 1')
print(paste(reac$asdasd, 'reac1'))
})
output$txt2 <- renderPrint({
print('output2')
print(paste(reac$qweqwe, 'reac2'))
})
}
shinyApp(ui, server)