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)
Related
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)
I need some help I want to show my reactive tabPanel in a popup with the shinyBS package.
Everything seems to work well except the creation of popup.
I am inspired by :
1) R Shiny - add tabPanel to tabsetPanel dynamically (with the use of renderUI)
2)Show dataTableOutput in modal in shiny app
My code :
library(shiny)
library(DT) # need datatables package
library(shinyBS)
ui <- shinyUI(fluidPage(
titlePanel("Example"),
sidebarLayout(
sidebarPanel(
selectInput("decision", label = "Choose your specie",
choices = iris$Species,
selected = "mtcars", multiple = TRUE)
),
mainPanel(
uiOutput('mytabs')
)
)
))
server <- shinyServer(function(input, output, session) {
output$mytabs <- renderUI({
nTabs = length(input$decision)
# create tabPanel with datatable in it
myTabs = lapply(seq_len(nTabs), function(i) {
tabPanel(paste0("dataset_", input$decision[i]),
tableOutput(paste0("datatable_",i))
)
})
do.call(tabsetPanel, myTabs)
})
# create datatables in popup ?
bsModal(
id = "modalExample",
"yb",
observe(
lapply(seq_len(length(input$decision)), function(i) {
output[[paste0("datatable_",i)]] <- renderTable({
as.data.frame(iris[iris$Species == input$decision[i], ])
})
})
)
)
})
shinyApp(ui, server)
Thanks in advance for any help !
bsModal is an UI element, so you need to put it into you UI. Within this modal you want to show the tabPanels (rendered via uiOutput), so all you need to do is to place your bsModal into the UI, and within this bsModal you have your uiOutput. All what is left is to add an actionButton which shows the modal.
library(shiny)
library(shinyBS)
ui <- shinyUI(fluidPage(
titlePanel("Example"),
sidebarLayout(
sidebarPanel(
selectInput("decision", label = "Choose your species",
choices = unique(iris$Species),
selected = unique(iris$Species), multiple = TRUE),
actionButton("show", "Show")
),
mainPanel(
bsModal("modalExample",
"myTitle",
"show",
uiOutput('mytabs')
)
)
)
))
server <- shinyServer(function(input, output, session) {
output$mytabs <- renderUI({
nTabs <- length(input$decision)
# create tabPanel with datatable in it
myTabs <- lapply(seq_len(nTabs), function(i) {
tabPanel(paste0("dataset_", input$decision[i]),
tableOutput(paste0("datatable_",i))
)
})
do.call(tabsetPanel, myTabs)
})
# create datatables in popup ?
observe(
lapply(seq_len(length(input$decision)), function(i) {
output[[paste0("datatable_",i)]] <- renderTable({
as.data.frame(iris[iris$Species == input$decision[i], ])
})
})
)
})
shinyApp(ui, server)
It's not clear to me what you want to do (maybe #thothal has the right answer). What about this app ?
library(shiny)
library(DT) # need datatables package
library(shinyBS)
ui <- shinyUI(fluidPage(
titlePanel("Example"),
sidebarLayout(
sidebarPanel(
selectInput("decision", label = "Choose your specie",
choices = iris$Species,
selected = "mtcars", multiple = TRUE),
actionButton("trigger_modal", "View modal")
),
mainPanel(
uiOutput("modal")
# uiOutput('mytabs')
)
)
))
server <- shinyServer(function(input, output, session) {
# output$mytabs <- renderUI({
# nTabs = length(input$decision)
# # create tabPanel with datatable in it
# myTabs = lapply(seq_len(nTabs), function(i) {
# tabPanel(paste0("dataset_", input$decision[i]),
# tableOutput(paste0("datatable_",i))
# )
# })
#
# do.call(tabsetPanel, myTabs)
# })
# create datatables in popup ?
observe(
lapply(seq_len(length(input$decision)), function(i) {
output[[paste0("datatable_",i)]] <- renderTable({
as.data.frame(iris[iris$Species == input$decision[i], ])
})
})
)
output$modal <- renderUI({
bsModal(
id = "modalExample",
"yb",
trigger = "trigger_modal",
do.call(tagList, lapply(seq_along(input$decision), function(i){
tableOutput(paste0("datatable_",i))
}))
)
})
})
shinyApp(ui, server)
I'm trying to use lapply to create multiple tabs in a tabsetPanel in Shiny based on this example: http://shiny.rstudio.com/gallery/creating-a-ui-from-a-loop.html. Below is my app.R code. When I run it, it doesn't create 5 tabs, nor does it print the name of each tab. What am I doing wrong?
library(shiny)
ui <- pageWithSidebar(
headerPanel("xxx"),
sidebarPanel(),
mainPanel(
tabsetPanel(id='t',
lapply(1:5, function(i) {
tabPanel(
title=paste0('tab', i),
textOutput(paste0('a',i))
)
})
)
)
)
server <- function(input, output) {
observe({
print(input$t)
})
lapply(1:5, function(j) {
output[[paste0('a',j)]] <- renderPrint({
input$t
})
})
}
shinyApp(ui, server)
It's a bit tricky, because tabsetPanel does not accept a list of tabset as an argument. You can use do.call to "unlist" arguments:
mainPanel(
do.call(tabsetPanel, c(id='t',lapply(1:5, function(i) {
tabPanel(
title=paste0('tab', i),
textOutput(paste0('a',i))
)
})))
)
stack.app <- function(n = 5){
library(shiny)
ui <- pageWithSidebar(
headerPanel("xxx"),
sidebarPanel(
verbatimTextOutput("show_selected")
),
mainPanel(
uiOutput('my_tabs')
)
)
server <- function(input, output, session) {
output$my_tabs <- renderUI({
### Had to hicjack this from shiny to get it to work...
shiny:::buildTabset(
id = "t",
lapply(1:n, function(i){
tabPanel(title = sprintf("tt_%s",i),
HTML(sprintf("This is tab %s content", i))
)
}), paste0("nav nav-","tabs")) %>% (function(x){
tags$div(class = "tabbable", x[[1]], x[[2]])
})
})
output$show_selected <- renderPrint({
sprintf("SELECTED TAB IS : %s", input$t)
})
}
shinyApp(ui, server)
}
Which results in:
I have created a sample app below to illustrate the issue I am having. I have an application in Shiny that is using many layers of modules. I am very familiar with using modules and returning reactive values from the modules themselves. However when I need to use lapply to create multiple calls of modules (in this case slider_menu_item_shiny function to create multiple sliders), each which return the reactive value that is set by the user in sliders, I am not sure how to dynamically capture all of the output reactive variables into one reactive vector.
Right now I have 2 sliders hard coded in and this simple app works. However I want to be able to type in an arbitrary value in the first input, have the app create that amount of slider modules using the lapply statement (for the callModule(slider_menu_item_shiny) call too) and then have slider_value_vector contain a vector of that length with all of the slider values.
I feel like I am missing a fundamental trick to making this work. I would really appreciate the learning experience and all of the help.
ui.R code
library(shiny)
library(shinydashboard)
library(DT)
#### MODULE CODE ####
source("modules.R")
# define header
header <- dashboardHeader(
title = "Test"
)
# define body
body <- dashboardBody(
tabItems(
body_set_shinyUI(id = "body_test_mod", tab_name = "body_test_mod")
)
)
# define sidebar
sidebar <- dashboardSidebar(
sidebarMenu(id = "dashboard_menu",
menuItem("Test Body", tabName = "body_test_mod")
)
)
dashboardPage(skin = "blue",
header,
sidebar,
body
)
server.R code
library(shiny)
library(shinydashboard)
library(DT)
#### MODULE CODE ####
source("modules.R")
#### SERVER CODE ####
function(input, output, session) {
callModule(body_set_shiny, id = "body_test_mod")
}
modules.R code
### body_set_shiny
body_set_shinyUI <- function(id, tab_name) {
ns <- NS(id)
tabItem(tabName = tab_name,
fluidRow(
column(12,
inner_body_test_menu_shinyUI(ns("inner_body_test_mod"))
)
)
)
}
body_set_shiny <- function(input, output, session) {
callModule(inner_body_test_menu_shiny, id = "inner_body_test_mod")
}
### inner_body_test_menu_shiny
inner_body_test_menu_shinyUI <- function(id) {
ns <- NS(id)
fluidRow(
column(12,
box(title = "Test Inner Menu",
width = 12,
fluidRow(
column(12,
wellPanel(
uiOutput(ns("inner_number_menu")),
uiOutput(ns("inner_sliders_menu")),
uiOutput(ns("inner_text_output"))
)
)
)
)
)
)
}
inner_body_test_menu_shiny <- function(input, output, session) {
output$inner_number_menu <- renderUI({
ns <- session$ns
textInput(ns("inner_number_value"), label = "Enter Number of Sliders", value = "2")
})
slider_length <- reactive({
if (is.null(input$inner_number_value))
return()
as.numeric(input$inner_number_value)
})
output$inner_sliders_menu <- renderUI({
if (is.null(slider_length()))
return()
ns <- session$ns
lapply((1:slider_length()), function(m) {
slider_menu_item_shinyUI(ns(paste("slider_menu_item_", m, sep = "")))
})
})
output$inner_text_output <- renderText({
if (is.null(slider_value_vector()))
return()
paste("You have entered", slider_value_vector())
})
slider_value_vector <- reactive({
if (is.null(slider_length()))
return()
c(as.numeric(slider_v1()[[1]]),as.numeric(slider_v2()[[1]]))
})
slider_v1 <- callModule(slider_menu_item_shiny, paste("slider_menu_item_", 1, sep = ""))
slider_v2 <- callModule(slider_menu_item_shiny, paste("slider_menu_item_", 2, sep = ""))
}
slider_menu_item_shinyUI <- function(id) {
ns <- NS(id)
uiOutput(ns('sider_output_menu'))
}
slider_menu_item_shiny <- function(input, output, session, slider_value = 0, slider_name = "No Name Found") {
output$sider_output_menu <- renderUI({
ns <- session$ns
uiOutput(ns("slider_item_menu"))
})
output$slider_item_menu <- renderUI({
ns <- session$ns
sliderInput(ns("slider_item"), label = "Slider Example", min = -1, max = 1, value = 0.5, step = 0.01)
})
return(reactive(list(input$slider_item)))
}
I a newbie in shiny and I want to add input$n widgets to my webpage, where input$n is a numeric given by another widget in my page?
Is it possible? And how?
Thank you very much for your help!
You can achieve this by using Shiny Modules. In the following example, the application dynamically creates N textInput from a numericInput.
library(shiny)
# Module UI containing a widget
widgetUI <- function(id, i) {
ns <- NS(id)
tagList(
textInput(inputId = ns("text"), label = paste("widget", i))
)
}
# Module server, unused here, just prints the widgets value in console
widgetServer <- function(input, output, session) {
observeEvent(input$text,{
print(input$text)
})
}
# Main UI page
ui <- fluidPage(
numericInput(inputId = "n", label = "Number of widgets", value = 2),
uiOutput("widgets")
)
# Main server
server <- function(input, output, session) {
output$widgets <- renderUI({
req(input$n)
# call the module UI n times
tagList(
lapply(1:input$n, function(i) {
widgetUI(id = paste0("widget", i), i)
})
)
})
observe({
# call the module server n times
lapply(1:input$n, function(i) {
callModule(widgetServer, id = paste0("widget", i))
})
})
}
shinyApp(ui, server)