i want to render the elements of each list to a valuebox.
i am able to show the element of single list like below example (run the code for ex) but not nested list.
what i want is to have valuebox which consist of elements of all list.
Please run the code to get the idea.Thankyou
#this should be the result:
1stvaluebox 2ndvaluebox 3rdvaluebox 4thvaluebox
A C E H
Kim John Satish Kevin
1 2 3 4
#Data and code
list_data <- list(letters = c("A","C","E","H"),names = c("Kim","John","Satish","Kevin"),numbers = 1:4)
library(shiny)
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(title = "Text Mining"),
dashboardSidebar(
sidebarMenu(
menuItem("NLP Tree", tabName = "NLP")
)
),
dashboardBody(
tabItems(
tabItem(tabName = "NLP",
fluidRow(
tabBox(width = 12,height="500",
tabPanel("Sentences",
uiOutput("nlp_entities")
)
)
)
)
)
)
)
server <- function(input, output) {
output$nlp_entities <- renderUI({
a <- lapply(list_data[[1]], function(x) {
valueBox(x,"names")
})
tagList(a)
})
}
shinyApp(ui = ui, server = server)
You can iterate from 1 to the length of sub-list and with each iteration extract wanted information.
server <- function(input, output) {
output$nlp_entities <- renderUI({
a <- list()
for(i in seq_len(lengths(list_data)[1])) {
a[[i]] <- valueBox(lapply(list_data[c(1, 3)], "[[", i),
list_data[[2]][i])
}
tagList(a)
})
}
Related
I am executing a shiny application where there is while loop inside Modal funtion. Refer below. So the expected output after clicking a button should be a pop up with 4 rows (A, B,C, D). So basically when the col_name change so as to number of rows in modal box. In this case there should be 4 rows since we have only (A, B, C, D)
library(shiny)
ui <- fluidPage(
actionButton("show","show")
)
shinyApp(ui, server = function(input, output) {
col_name <- c("A","B","C","D")
i <- 1
observeEvent(input$show,
showModal(
modalDialog(
title = "Edit",
while (i < length(col_name)) {
print(i)
fluidRow(
column(width = 4,
col_name[i]
i = i + 1
)
)
}
)))
})
Expected output after clicking a button
Here's a solution that works, if you have to do it while loop for some reason
library(shiny)
ui <- fluidPage(
actionButton("show","show")
)
server = function(input, output) {
col_name <- c("A","B","C","D")
observeEvent(input$show,{
text <- ""
i <- 1
while (i <= length(col_name)) {
print(i)
text <- paste(text,col_name[i],"<br/>")
i = i+1
}
text <- HTML(text)
showModal(modalDialog(
title = "Edit",
text
))
})
}
shinyApp(ui,server)
But, if you don't need the while loop, here's a cleaner solution.
library(shiny)
ui <- fluidPage(
actionButton("show","show")
)
server = function(input, output) {
col_name <- c("A","B","C","D")
observeEvent(input$show,{
showModal(modalDialog(
title = "Edit",
HTML(paste(col_name, collapse = "<br/>"))
))
})
}
shinyApp(ui,server)
I am building an app with three segments:
Overview
Detailed results
Help
The detailed result section should show results of many sub-items, one at the time.
I am interested to the Result section to be a single tab, because I don't want to write code each tab for each sub-item. Each sub-item has identical, in the example a histogram.
When I run the example though, I loose the ID of the subitems.
Is it possible to have a layout like this but to keep the ID's of all menuitems and menusubitems?
Happy to look at alternative approaches.
An example to illustrate the issue is below. The solution will show the table in overview, a histogram in results for any of the sub-items and the HTML output in the help section.
library(shiny)
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(
sidebarMenu(id = "SideBarMENU",
menuItem("Overview", tabName = "OVERVIEW", selected = TRUE),
menuItem("Results", startExpanded = TRUE,
menuSubItem("Sepal.Length", tabName = "RESULTS"),
menuSubItem("Sepal.Width" , tabName = "RESULTS"),
menuSubItem("Petal.Length", tabName = "RESULTS"),
menuSubItem("Petal.Width" , tabName = "RESULTS")
),
menuItem("Help", tabName = "HELP")
)
),
dashboardBody(
tabItems(
tabItem("OVERVIEW",
box("Overview box",
tableOutput("overview"))
),
tabItem("RESULTS",
box("Results box",
plotOutput("results")
)
),
tabItem("HELP",
box("HELP box",
textOutput("help"))
)
)
)
)
server <- function(input, output, session) {
data <- reactive({
print(input$SideBarMENU)
if(input$SideBarMENU %in% names(iris)){
iris[[input$SideBarMENU]]
} else {
rnorm(100, 1000, 10)
}
})
output$results <- renderPlot({
hist(data())
})
output$overview <- renderTable({
head(iris)
})
output$help <- renderText({
HTML("A wiki is a website on which users collaboratively.....")
})
}
shinyApp(ui, server)
Basically, you need two components:
Dynamic content / plots
Dynamic dashboard body
The first part is more easy:
1. Dynamic content / plots
You can create the outputs in a loop as explained in a few other SO posts:
lapply(nms, function(name){
output[[name]] <- renderUI ({
box("Results Box", plotOutput(paste0("plot_", name)))
})
output[[paste0("plot_", name)]] <- renderPlot({
hist(iris[[input$SideBarMENU]], main = "")
})
})
2. Dynamic dashboard body
This part is more complicated. You need dynamic tabitems() and they have to be mixed with static parts. In order to hand over a list of tabitem() to tabitems() you can use do.call(tabItems, ..) for converting it, see the link below. To combine them with the static elements, convert the static ones as list() elements and combine them all in a list() before calling do.call(tabItems, ..).
output$tabItms <- renderUI ({
itemsDyn <- lapply(nms, function(name){
tabItem(tabName = name, uiOutput(name))
})
items <- c(
list(
tabItem("OVERVIEW",
box("Overview box",
tableOutput("overview"))
)
),
itemsDyn,
list(
tabItem("HELP",
box("HELP box",
textOutput("help"))
)
)
)
do.call(tabItems, items)
})
Similar components can be found here: shinydashboard does not work with uiOutput
and for looping tabItems() here: How to make a function in a for loop or lapply loop in a tabItem dashboard shiny.
Note:
I modify names(iris):
nms <- gsub("[.]", "", names(iris))
names(iris) <- nms
because no dots are allowed for the tabItem names.
Reproducible example:
library(shiny)
library(shinydashboard)
nms <- gsub("[.]", "", names(iris))
names(iris) <- nms
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(
uiOutput("menu")
),
dashboardBody(
uiOutput("tabItms")
)
)
server <- function(input, output, session) {
output$tabItms <- renderUI ({
itemsDyn <- lapply(nms, function(name){
tabItem(tabName = name, uiOutput(name))
})
items <- c(
list(
tabItem("OVERVIEW",
box("Overview box",
tableOutput("overview"))
)
),
itemsDyn,
list(
tabItem("HELP",
box("HELP box",
textOutput("help"))
)
)
)
do.call(tabItems, items)
})
lapply(nms, function(name){
output[[name]] <- renderUI ({
box("Results Box", plotOutput(paste0("plot_", name)))
})
output[[paste0("plot_", name)]] <- renderPlot({
hist(iris[[input$SideBarMENU]], main = "")
})
})
output$menu <- renderUI({
sidebarMenu(id = "SideBarMENU",
menuItem("Overview", tabName = "OVERVIEW", selected = TRUE),
menuItem("Results", id = "resultChoice", startExpanded = TRUE,
lapply(nms, function(name) {
menuSubItem(name, tabName = name)
})
),
menuItem("Help", tabName = "HELP")
)
})
output$overview <- renderTable({
head(iris)
})
output$help <- renderText({
HTML("A wiki is a website on which users collaboratively.....")
})
}
shinyApp(ui, server)
I need to share more than one dataframe within an observeEvent block with other observeEvent blocks. The reason is because the data is built only after a button is pressed.
I found the following two questions very resourceful, but not quite close to the structure of my app ...
How to return a variable from a module to the server in an R Shiny app?
How to access dataframe from another observeEvent?
I tried to wrap the button observeEvent within a module, but then the app does not work. I cannot figure out how to change my code into modules to make it work.
Here is a minimal example.
library(shiny)
library(shinydashboard)
library(DT)
header1 <- dashboardHeader(
title = "My App"
)
sidebar1 <- dashboardSidebar(
sidebarMenu(id = "sbmenu",
menuItemOutput("menuitems01"),
menuItemOutput("menuitems02")
) #sidebarMenu
) #dashboardSidebar
body1 <- dashboardBody(
tabItems(
uiOutput("tabitems01")
) #tabItems
) #dashboardBody
ui <- dashboardPage(header1, sidebar1, body1)
server <- function(input, output, session) {
# render menu
output$menuitems01 <- renderMenu({
menuItem("Main", tabName = "main", icon = icon("key"))
})
# render tabitems
output$tabitems01 <- renderUI({
tabItem(tabName = "main",
h2("Main"),
actionButton(inputId = "btn1", label = "Button1")
) #tabItem
}) #renderUI
observeEvent(input$btn1, {
dfresult02 <- data.frame(c(1, 2), c(3, 4)) # e.g. read some data from db
dfresult05 <- data.frame(c(5, 6), c(7, 8)) # e.g. read some data from db
rResult02 <- reactive({dfresult02}) # NEED TO MAKE THIS DATA AVAILABLE TO OTHER MODULE(S)
rResult05 <- reactive({dfresult05}) # NEED TO MAKE THIS DATA AVAILABLE TO OTHER MODULE(S)
output$menuitems02 <- renderMenu({
menuItem("MyData", tabName = "mydata", icon = icon("th"))
}) #renderMenu
updateTabItems(session, "sbmenu", "mydata")
print("button1 pressed")
}) #observeEvent(input$btn1)
observeEvent(input$sbmenu, {
# IF I UNCOMMENT THE NEXT FOUR LINES, THE TABLES ARE DISPLAYED
#dfresult02 <- data.frame(c(1, 2), c(3, 4))
#rResult02 <- reactive({dfresult02})
#dfresult05 <- data.frame(c(1, 2), c(3, 4))
#rResult05 <- reactive({dfresult05})
if(input$sbmenu == "mydata")
{
output$tabitems01 <- renderUI({
tabItem(tabName = "mydata",
h2("My Data"),
DT::dataTableOutput('tbl02'),
DT::dataTableOutput('tbl05')
) #tabItem
}) #renderUI
output$tbl02 <- DT::renderDataTable({rResult02()}) # NEED DATA FROM OTHER MODULE HERE
output$tbl05 <- DT::renderDataTable({rResult05()}) # NEED DATA FROM OTHER MODULE HERE
} #if(input$sbmenu == "mydata")
if(input$sbmenu == "main")
{
output$tabitems01 <- renderUI({
tabItem(tabName = "main",
h2("Main"),
actionButton(inputId = "btn1", label = "Button1")
) #tabItem
}) #renderUI
} #if(input$sbmenu == "main")
}) #observeEvent(input$sbmenu)
} #server
shinyApp(ui = ui, server = server)
Using the very useful comment above, I ended up with this code, that works perfectly! Thank you so much!!! (note the use of reactiveValues)
library(shiny)
library(shinydashboard)
library(DT)
header1 <- dashboardHeader(
title = "My App"
)
sidebar1 <- dashboardSidebar(
sidebarMenu(id = "sbmenu",
menuItemOutput("menuitems01"),
menuItemOutput("menuitems02")
) #sidebarMenu
) #dashboardSidebar
body1 <- dashboardBody(
tabItems(
uiOutput("tabitems01")
) #tabItems
) #dashboardBody
ui <- dashboardPage(header1, sidebar1, body1)
server <- function(input, output, session) {
# DECLARE REACTIVEVALUES FUNCTION HERE
rResult <- reactiveValues(df02 = 0, df05 = 0)
# render menu
output$menuitems01 <- renderMenu({
menuItem("Main", tabName = "main", icon = icon("key"))
})
# render tabitems
output$tabitems01 <- renderUI({
tabItem(tabName = "main",
h2("Main"),
actionButton(inputId = "btn1", label = "Button1")
) #tabItem
}) #renderUI
observeEvent(input$btn1, {
dfresult02 <- data.frame(c(1, 2), c(3, 4)) # e.g. read some data from db
dfresult05 <- data.frame(c(5, 6), c(7, 8)) # e.g. read some data from db
rResult$df02 <- dfresult02 # MAKE THIS DATA AVAILABLE TO OTHER MODULE(S)
rResult$df05 <- dfresult05 # MAKE THIS DATA AVAILABLE TO OTHER MODULE(S)
output$menuitems02 <- renderMenu({
menuItem("MyData", tabName = "mydata", icon = icon("th"))
}) #renderMenu
updateTabItems(session, "sbmenu", "mydata")
print("button1 pressed")
}) #observeEvent(input$btn1)
observeEvent(input$sbmenu, {
if(input$sbmenu == "mydata")
{
output$tabitems01 <- renderUI({
tabItem(tabName = "mydata",
h2("My Data"),
DT::dataTableOutput('tbl02'),
DT::dataTableOutput('tbl05')
) #tabItem
}) #renderUI
output$tbl02 <- DT::renderDataTable(rResult$df02) # GET DATA FROM OTHER MODULE(S) HERE
output$tbl05 <- DT::renderDataTable(rResult$df05) # GET DATA FROM OTHER MODULE(S) HERE
} #if(input$sbmenu == "mydata")
if(input$sbmenu == "main")
{
output$tabitems01 <- renderUI({
tabItem(tabName = "main",
h2("Main"),
actionButton(inputId = "btn1", label = "Button1")
) #tabItem
}) #renderUI
} #if(input$sbmenu == "main")
}) #observeEvent(input$sbmenu)
} #server
shinyApp(ui = ui, server = server)
I am using Shiny and I am trying to make a set of tabPanels appear dynamically based on a set of parameters. In the code below, I would like to make the first tabPanel appear only when showTab1 <- T and so on.
I tried with simple if statements and conditionalPanels but it fails. Below there is an example of code:
rm(list = ls())
library(shiny)
library(shinydashboard)
showTab1 <- T
showTab2 <- F
showTab3 <- T
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(
),
dashboardBody(
uiOutput("tabs")
)
)
server <- function(input, output) {
output$tabs <- renderUI({
tabBox(width = 1000,height = 500,
if (showTab1 == T) { tabPanel("tab1") },
if (showTab2 == T) { tabPanel("tab2") },
if (showTab3 == T) { tabPanel("tab3") }
)
})
}
shinyApp(ui, server)
Thanks for your help.
Cheers,
Kostas
You can dynamically create them:
rm(list = ls())
library(shiny)
library(shinydashboard)
showTab1 <- T
showTab2 <- F
showTab3 <- T
ShowTotal <- which(c(showTab1,showTab2,showTab3))
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(),
dashboardBody(uiOutput("ui"))
)
server <- function(input, output) {
output$ui <- renderUI({
myTabs = lapply(paste('tab', ShowTotal), tabPanel)
do.call(tabsetPanel, myTabs)
})
}
shinyApp(ui, server)
Thanks for your answer earlier. Following your suggestion I think the following example can work for my case. The only issue I have is that in the end I cannot adjust the width and height of the tabBox.
library(shiny)
library(shinydashboard)
showTab1 <- T
showTab2 <- F
showTab3 <- T
ShowTotal <- which(c(showTab1,showTab2,showTab3))
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(),
dashboardBody(uiOutput("ui"))
)
server <- function(input, output) {
output$ui <- renderUI({
tabs <- list()
k <- 0
if (showTab1 == T){
k <- k+1
tabs[[k]] <- tabPanel("Tab1", p("A phrase"), br(""), p("I can place a chart here"))
}
if (showTab2 == T){
k <- k+1
tabs[[k]] <- tabPanel("Tab2", p("B phrase"), br(""), p("I can place a chart here"))
}
if (showTab3 == T){
k <- k+1
tabs[[k]] <- tabPanel("Tab3", p("C phrase"), br(""), p("I can place a chart here"))
}
do.call(tabBox, tabs)
})
}
shinyApp(ui, server)
Thanks,
Kostas
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)))
}