Shiny reactive input add and delete - r

I'm trying to write a shiny app where I produce a list and add and delete some elements.
I have a module to add somethind to my list.
find_inputUI <- function(id){
ns <- NS(id)
tagList(
sliderInput(ns("first"), "Choose a number:", min=0, max=100, 30),
radioButtons(ns("second"), "Choose a colour:", choices=c("red", "green", "black")),
actionButton(ns("press"), "Add to queue"))
}
find_input <- function(input, output, session){
queue <- list()
observeEvent(input$press, {
queue_append <- list(input$first, input$second)
queue <<- append(queue, queue_append )})
queue_ret <- eventReactive(input$press,{return(list(queue=queue, add=input$press))})
}
Then I call it twice and connect the 2 different inputs. Now I want to choose the elements to delete but this doesn't work.
source('/cloud/project/Queue/find_input.R')
library(shiny)
ui <- fluidPage(
tagList(tabsetPanel(
tabPanel("INPUT 1",
find_inputUI("input1"),
verbatimTextOutput("test")),
tabPanel("INPUT 2",
find_inputUI("input2")
)
),
actionButton("combine", "Show combined input"),
verbatimTextOutput("combination"),
uiOutput("del")
)
)
# Define server logic required to draw a histogram
server <- function(input, output, session) {
input_manual1 <- callModule(find_input,"input1")
input_manual2 <- callModule(find_input, "input2")
output$test <- renderPrint({input_manual1()$queue})
appended <- eventReactive(input$combine, {
return(append(input_manual1()$queue, input_manual2()$queue))
})
output$combination <- renderPrint({appended()})
output$del <- renderUI({
input$combine
tagList(checkboxGroupInput("delete", "Choose do delete", seq(1:length(appended()))),
actionButton("dodelete", "Delete selected"))
})
observeEvent(input$dodelete,{
appended <<- appended()[-input$delete]
})
}
# Run the application
shinyApp(ui = ui, server = server)
Maybe anybody can tell me what's wrong so far?
Thanks in advance!

Below is an app which seems to work but I'm not sure to understand what your app is intended to do.
In general, prefer reactive values (reactiveVal) instaed of using the non-local assignment <<-.
The code appended <<- appended()[-input$delete] is not correct. It does not replace the output of appended() by its originalvalue minus the input$delete index.
library(shiny)
find_inputUI <- function(id){
ns <- NS(id)
tagList(
sliderInput(ns("first"), "Choose a number:", min=0, max=100, 30),
radioButtons(ns("second"), "Choose a colour:", choices=c("red", "green", "black")),
actionButton(ns("press"), "Add to queue"))
}
find_input <- function(input, output, session){
queue <- reactiveVal(list())
observeEvent(input$press, {
queue_append <- list(input$first, input$second)
queue(append(queue(), queue_append))
})
queue_ret <- eventReactive(input$press, {
list(queue=queue(), add=input$press)
})
}
ui <- fluidPage(
tagList(tabsetPanel(
tabPanel("INPUT 1",
find_inputUI("input1"),
verbatimTextOutput("test")),
tabPanel("INPUT 2",
find_inputUI("input2")
)
),
actionButton("combine", "Show combined input"),
verbatimTextOutput("combination"),
uiOutput("del")
)
)
server <- function(input, output, session) {
input_manual1 <- callModule(find_input,"input1")
input_manual2 <- callModule(find_input, "input2")
output$test <- renderPrint({input_manual1()$queue})
appended <- reactiveVal(list())
observeEvent(input$combine, {
appended(append(input_manual1()$queue, input_manual2()$queue))
})
output$combination <- renderPrint({appended()})
output$del <- renderUI({
input$combine
tagList(checkboxGroupInput("delete", "Choose do delete", seq_along(appended())),
actionButton("dodelete", "Delete selected"))
})
observeEvent(input$dodelete,{
appended(appended()[-as.integer(input$delete)])
})
}
# Run the application
shinyApp(ui = ui, server = server)

Related

Dyamic input in Shiny modules

I struggle with making a dynamic selectInput() when working with Shiny modules.
I have the following app (without modules):
library(shiny)
ui <- fluidPage(
numericInput("n", "n", 10),
uiOutput("select"),
uiOutput("res")
)
server <- function(input, output, session) {
output$select <- renderUI(
selectInput("sample_size", "Sample size", choices = 1:input$n)
)
output$res <- renderUI(
renderPrint(rnorm(input$sample_size))
)
}
shinyApp(ui, server)
I am not sure how to properly use namespaces when modularizing this app. My current attempt looks like this:
library(shiny)
sampleUI <- function(id){
ns <- NS(id)
fluidPage(
numericInput("n", "n", 10),
uiOutput(ns("select")),
uiOutput("res")
)
}
sampleServer <- function(input, output, session) {
output$select <- renderUI(
selectInput("sample-size", "Sample size", choices = 1:input$n)
)
output$res <- renderUI(
renderPrint(rnorm(input$sample_size))
)
}
ui <- fluidPage(
sampleUI("mod1")
)
server <- function(input, output, session) {
callModule(sampleServer, "mod1")
}
shinyApp(ui, server)
When making new IDs in the server module, always use session$ns around the ID. This is the case here for your selectInput. Also fixed a typo, and an ns() in the UI function:
library(shiny)
sampleUI <- function(id){
ns <- NS(id)
fluidPage(
numericInput(ns("n"), "n", 10),
uiOutput(ns("select")),
uiOutput("res")
)
}
sampleServer <- function(input, output, session) {
output$select <- renderUI(
selectInput(session$ns("sample_size"), "Sample size", choices = 1:input$n)
)
output$res <- renderUI(
renderPrint(rnorm(input$sample_size))
)
}
ui <- fluidPage(
sampleUI("mod1")
)
server <- function(input, output, session) {
callModule(sampleServer, "mod1")
}
shinyApp(ui, server)

Unable to access the value of radioButton when created inside a shiny server module

My shinyapp is build using modules, the radioBox component inputId = modelling_type is created in the server, using a renderUI function and stored under outputId = modelling_type_ui
As I'm using modules, I have name spaced my IDs in the mod_ui, and then in order to (attempt!) to use the same name space function in the mod_server I have called it via ns <- parentsession$ns. This doesn't throw an error. But I would now expect to access the value of the RadioBox via input$modelling_type
This isn't working! So I must be calling the value incorrectly.
Here is the code:
library(shiny)
library(shinyalert)
library(shinydashboard)
library(shinyjs)
library(tidyverse)
# modules ------------------------------------------
mod_ui <- function(id){
ns <- NS(id)
fluidPage(
uiOutput(outputId = ns("modelling_type_ui")),
textOutput(outputId = ns("capture"))
)
}
mod_server <- function(id, parentsession){
moduleServer(id,
function(input, output, server){
ns <- parentsession$ns
output$modelling_type_ui = renderUI({
print(input$modelling_type) # this should not be null
radioButtons(
inputId = ns("modelling_type"),
label = "Choose a modelling technique",
choices = c("OLS",
"Bayesian"),
selected = "OLS")
})
output$capture = renderText({ paste0("modelling type selected:", input$modelling_type) })
})
}
# call app ---------------------------------------
# run app
ui <- function(){ mod_ui("mt") }
server <- function(input, output, session){ mod_server("mt", session) }
shinyApp(ui = ui, server = server)
Any help appreciated. Usually I would just call radioButtons in the UI, and use updateradioButtons function in the server, but I'm dealing with a legacy app which uses the below method repeatedly.
To expand on my comment above, here is a MWE that I believe does what you want.
I'm not sure why you're using uiOutput and renderUI. I assume it's needed in your actual use case, but it's not needed here. Also, there's no need to muck about with parentsession and the like.
One reason why your debug print prints NULL is that you haven't defined the radio group at the time you try to print its value.
library(shiny)
library(tidyverse)
mod_ui <- function(id){
ns <- NS(id)
fluidPage(
uiOutput(outputId = ns("modelling_type_ui")),
textOutput(outputId = ns("capture"))
)
}
mod_server <- function(id) {
moduleServer(
id,
function(input, output, session){
ns <- session$ns
output$modelling_type_ui = renderUI({
radioButtons(
inputId = ns("modelling_type"),
label = "Choose a modelling technique",
choices = c("OLS","Bayesian"),
selected = "OLS"
)
})
output$capture <- renderText({
paste0("modelling type selected: ", input$modelling_type)
})
rv <- reactive({
input$modelling_type
})
return(rv)
}
)
}
ui <- function() {
fluidPage(
mod_ui("mt"),
textOutput("returnValue")
)
}
server <- function(input, output, session) {
modValue <- mod_server("mt")
output$returnValue <- renderText({
paste0("The value returned by the module is ", modValue())
})
}
shinyApp(ui = ui, server = server)

Get R object in Shiny

Is it possible to get some R object used in Shiny?
For example, in the following code, I want to get text string inputted by users.
However, the .Last.value dose not the desired text string.
ref
How to store the returned value from a Shiny module in reactiveValues?
Ex code
returnUI = function(id) {
ns <- NS(id)
tagList(
textInput(ns("txt"), "Write something")
)
}
returnServer = function(input, output, session) {
myreturn <- reactiveValues()
observe({ myreturn$txt <- input$txt })
return(myreturn)
}
library(shiny)
source("modules/module_1.R")
ui <- fluidPage(
returnUI("returntxt"),
textOutput("mytxt")
)
server <- function(input, output, session) {
myvals <- reactiveValues(
txt = NULL
)
mytxt <- callModule(returnServer, "returntxt")
observe({
myvals$txt <- mytxt$txt
print(myvals$txt)
})
output$mytxt <- renderText({ myvals$txt })
}
shinyApp(ui, server)
.Last.value
Yes, you can push variables to the global environment (your usual workspace) from a Shiny app running in your console:
library(shiny)
ui <- fluidPage(
# Sidebar with a slider input for number of bins
sidebarLayout(
sidebarPanel(
sliderInput("bins",
"Number of bins:",
min = 1,
max = 50,
value = 30)
),
mainPanel(NULL)
)
)
server <- function(input, output) {
observe({
my_global_env <- globalenv()
my_global_env$x <- input$bins
})
}
shinyApp(ui = ui, server = server)

Dataset returned by module is not reactive

Here's an example:
library(shiny)
mod_ui <- function(id){
ns <- NS(id)
tabPanel(
"tab 2",
actionButton(ns("change_dataset"), "change dataset")
)
}
mod_server <- function(input, output, session){
data <- reactive({ mtcars })
observeEvent(input$change_dataset, {
data <- reactive({ iris })
# Comment the line above and uncomment the
# one below to check that this button works:
# print("button works")
})
return(
list(
data_1 = data
)
)
}
ui <- navbarPage(
title = "",
id = "a_navbar",
tabPanel(
"tab 1",
dataTableOutput("data_test")
),
mod_ui("tab_2")
)
server <- function(input, output, session) {
mod_return <- callModule(mod_server, "tab_2")
output$data_test <- renderDataTable({
mod_return$data_1()
})
}
shinyApp(ui, server)
Basically, this app displays the mtcars dataset in tab 1, and it should display the iris dataset if the user clicks on the button "change dataset" in tab 2. But clicking on this button does not update the table. Why is this the case? How can I fix it?
You should avoid nesting reactives in observers.
You can use eventReactive instead. Please check the following:
library(shiny)
library(DT)
mod_ui <- function(id) {
ns <- NS(id)
tabPanel("tab 2",
actionButton(ns("change_dataset"), "change dataset"))
}
mod_server <- function(input, output, session) {
data <- eventReactive(input$change_dataset, {
if (input$change_dataset %% 2) {
iris
} else {
mtcars
}
}, ignoreNULL = FALSE)
return(list(data_1 = data))
}
ui <- navbarPage(
title = "",
id = "a_navbar",
tabPanel("tab 1",
DT::dataTableOutput("data_test")),
mod_ui("tab_2")
)
server <- function(input, output, session) {
mod_return <- callModule(mod_server, "tab_2")
output$data_test <- DT::renderDataTable({
mod_return$data_1()
})
}
shinyApp(ui, server)
Another approach would be to set a reactiveVal in the observeEvent.

Shiny/shinydashboard: Dynamic Number of Output Elements/valueBoxes

I'm currently trying to set up a UI that is creating valueBoxes dynamically.
I' picked up the code shown here which does exactly what I want, but using plots.
Actually the following works, but the boxes aren't rendered as expected:
library(shiny)
library(shinydashboard)
ui <- pageWithSidebar(
headerPanel("Dynamic number of valueBoxes"),
sidebarPanel(
selectInput(inputId = "choosevar",
label = "Choose Cut Variable:",
choices = c("Nr. of Gears"="gear", "Nr. of Carburators"="carb"))
),
mainPanel(
# This is the dynamic UI for the plots
uiOutput("plots")
)
)
server <- function(input, output) {
#dynamically create the right number of htmlOutput
# renderUI
output$plots <- renderUI({
plot_output_list <- lapply(unique(mtcars[,input$choosevar]), function(i) {
plotname <- paste0("plot", i)
# valueBoxOutput(plotname)
htmlOutput(plotname)
})
tagList(plot_output_list)
})
# Call renderPlot for each one. Plots are only actually generated when they
# are visible on the web page.
for (i in 1:max(unique(mtcars[,"gear"]),unique(mtcars[,"carb"]))) {
local({
my_i <- i
plotname <- paste0("plot", my_i)
output[[plotname]] <- renderUI({
valueBox(
input$choosevar,
my_i,
icon = icon("credit-card")
)
})
})
}
}
# Run the application
shinyApp(ui = ui, server = server)
Thanks for any hints!
You are mixing shinydashboard elements with normal shiny-uis. You have to create a dashboard-ui, as the valueboxes are for dashboards.
The following should work:
library(shiny)
library(shinydashboard)
ui = dashboardPage(
dashboardHeader(title = "Dynamic number of valueBoxes"),
dashboardSidebar(
selectInput(inputId = "choosevar",
label = "Choose Cut Variable:",
choices = c("Nr. of Gears"="gear", "Nr. of Carburators"="carb"))
),
dashboardBody(
uiOutput("plots")
)
)
server <- function(input, output) {
#dynamically create the right number of htmlOutput
# renderUI
output$plots <- renderUI({
plot_output_list <- lapply(unique(mtcars[,input$choosevar]), function(i) {
plotname <- paste0("plot", i)
valueBoxOutput(plotname)
# htmlOutput(plotname)
})
tagList(plot_output_list)
})
# Call renderPlot for each one. Plots are only actually generated when they
# are visible on the web page.
for (i in 1:max(unique(mtcars[,"gear"]),unique(mtcars[,"carb"]))) {
local({
my_i <- i
plotname <- paste0("plot", my_i)
output[[plotname]] <- renderUI({
valueBox(
input$choosevar,
my_i,
icon = icon("credit-card")
)
})
})
}
}
# Run the application
shinyApp(ui = ui, server = server)

Resources