I have a Shiny app with the following structure:
shinyUI(dashboardPage(title="Map",
dashboardHeader(title = tags$img(src="logo.png")),
dashboardSidebar(sidebarMenu(id = "totalTab",
menuItem("Users", tabName = "dashboard", icon = icon("user-circle")),
menuItem("Map", tabName = "cities", icon = icon("map-o")),
menuItem("Med", tabName = "med", icon = icon("building-o"), selected = TRUE),
menuItem("Data", tabName = "opdata", icon = icon("database"))
),
dashboardBody(tabItems(
tabItem(tabName = "dashboard", uiOutput("bodyuser")),
tabItem(tabName = "med", uiOutput("bodyoutput")),
tabItem(tabName = "cities", uiOutput("citiesout")),
tabItem(tabName = "opdata", uiOutput("dataout"))
))
))
The first I see when I open the app is tab item "med". Inside "med" I have a tabset called "TabMap". I want to update "TabMap" using URL like this:
observe({
query <- parseQueryString(session$clientData$url_search)
if (!is.null(query[['panelname']])) {
rv$rvpanel <- query[['panelname']]
updateTabsetPanel(session, "TabMap", selected = rv$rvpanel)
}
})
Or this:
observe({
query <- parseQueryString(session$clientData$url_search)
if (!is.null(query[['panelname']])) {
updateTabsetPanel(session, "TabMap", selected = query[['panelname']])
}
})
But neither works. How can I do that?
PD: rv$rvpanel is a reactive value...
Tabset:
output$bodyoutput <- renderUI({
box(title = "Map", width ="100%", status = "info", solidHeader = TRUE,
uiOutput("tabmap"))
})
output$tabmap <- renderUI({
tabsetPanel(id = "TabMap",
tabPanel(width = "100%", title = "Add", value="panel5", uiOutput("formdead")),
tabPanel(width = "100%", title = "Ours", value="panel1", uiOutput("mapdeadout")),
tabPanel(width = "100%", title = "Month", value="panel4", uiOutput("mapmonthout")),
tabPanel(width = "100%", title = "Map", value = "panel2", uiOutput("maplifeout")),
tabPanel(width = "100%", title = "History", value="panel3", uiOutput("formhist"))
)
})
You just missed one thing, to check if "TabMap" is already rendered and available in the input before your observe code gets executed.
This codes below seem to work
observe({
if(any(names(input) == "TabMap")){
query <- parseQueryString(session$clientData$url_search)
if (!is.null(query[['panelname']])) {
rv$rvpanel <- query[['panelname']]
updateTabsetPanel(session, "TabMap", selected = rv$rvpanel)
}
}
})
observe({
if(any(names(input) == "TabMap")){
query <- parseQueryString(session$clientData$url_search)
if (!is.null(query[['panelname']])) {
updateTabsetPanel(session, "TabMap", selected = query[['panelname']])
}
}
})
Hope this helps!
Related
I tried to make dynamic Tab using argonDash package. However, I met some trouble with my code.
I guess argonDash seems to get different behavior than native shiny because argonDash uses Bootstrap 4 (instead of 3).
My code is composed of two key features:
The first widget uiOutput(outputId = "new_argonSidebarItem") works well.
The second widget uiOutput(outputId = "new_argonTabItem") doesn't work properly. I expect that the argonBadge() toggle with the second tab.
library(shiny)
library(argonDash)
library(argonR)
ui <- argonDashPage(
sidebar = argonDashSidebar(
id = "sidebar01",
vertical = FALSE,
size = "md",
background = "white",
argonSidebarMenu(
style = "display:-webkit-inline-box;",
argonSidebarItem(
tabName = "Tab1",
icon = NULL,
"Dashboard"
),
# New Tab
uiOutput(outputId = "new_argonSidebarItem")
)
),
body = argonDashBody(
argonTabItems(
argonTabItem(
tabName = "Tab1",
actionButton("add_more", "Add a new btn")
),
# Body
uiOutput(outputId = "new_argonTabItem")
)
)
)
server <- function(input, output, session) {
observeEvent(input$add_more, {
tabId <- sample.int(n = 1000000, size = 1)
tabName <- paste0("Tab_", tabId)
insertUI(
selector = "#tab-Tab1",
where = "afterEnd",
ui = argonSidebarItem(
tabName = tabName,
tabName
)
)
output$new_argonTabItem <- renderUI({
argonTabItem(
tabName = tabName,
argonBadge(
text = tabName,
src = "#",
pill = FALSE,
status = "success"
)
)
})
})
}
shinyApp(ui, server)
Thank you for your time!
To update your badge you need to track which tab is selected. This is done accordingly to this solution : https://github.com/RinteRface/argonDash/issues/7
But your badge can not be modified, so I replaced it with a button from {shinyWidgets}.
I hope this is what you ask for, I'm not really sure to understand what you want to happen.
library(shiny)
library(argonDash)
library(argonR)
library(shinyWidgets)
ui <- argonDashPage(
sidebar = argonDashSidebar(
id = "sidebar01",
vertical = FALSE,
size = "md",
background = "white",
argonSidebarMenu(
style = "display:-webkit-inline-box;",
argonSidebarItem(
tabName = "Tab1",
icon = NULL,
"Dashboard"
),
# New Tab
uiOutput(outputId = "new_argonSidebarItem")
)
),
body = argonDashBody(
argonTabItems(
argonTabItem(
tabName = "Tab1",
actionButton("add_more", "Add a new btn")
),
# Body
uiOutput(outputId = "new_argonTabItem")
),
tags$script( "$(document).on('click', function(event) {
Shiny.onInputChange('activeTab', $('.active').data().value);});")
)
)
server <- function(input, output, session) {
x <- reactiveValues(tabs = NULL)
observeEvent(input$add_more, {
tabId <- sample.int(n = 1000000, size = 1)
tabName <- paste0("Tab_", tabId)
insertUI(
selector = "#tab-Tab1",
where = "afterEnd",
ui = argonSidebarItem(
tabName = tabName,
tabName
)
)
output$new_argonTabItem <- renderUI({
argonTabItem(
tabName = tabName,
actionBttn(
inputId = paste0(input$activeTab,"_b"),
label = tabName,
style = "float",
color = "success"
)#,
# argonBadge(
# text = tabName,
# src = "#",
# pill = FALSE,
# status = "success"
# )
)
})
})
observeEvent(input$activeTab, {
updateActionButton(session,
paste0(input$activeTab,"_b"),
input$activeTab)
})
}
shinyApp(ui, server)
I want to trigger some action on clicking the menuItem. I use observe here: when I click 'Drivers' item I want some text to be returned in the console. Unfortunately, when I run the app the error comes up: Error in if: argument is of length 0. My menuItem exists, id is also ok so don't know why this error shows up.
Here is reproducible code (observe is on the bottom of my code):
library(shiny)
library(bs4Dash)
library(leaflet)
bodyTag <- dashboardBody(
tags$head(
tags$style(
"#map {
height: calc(100vh - 57px) !important;
}"
)
),
tabItems(
tabItem(
tabName = "live",
box(
title = "LIVE",
id = "panel",
height = 450,
collapsible = TRUE
)
),
tabItem(
tabName = "drivers",
box(
title = "Drivers",
id = "panel",
height = 450,
collapsible = TRUE
)
),
tabItem(
tabName = "customers",
box(
title = "Customers",
id = "panel",
height = 450,
collapsible = TRUE
)
)
),
leafletOutput("map")
)
ui <- dashboardPage(
dark = TRUE,
header = dashboardHeader(
title = h5("DEMO app")
),
sidebar = dashboardSidebar(
fixed = TRUE,
collapsed = TRUE,
expandOnHover = FALSE,
status = "purple",
customArea = fluidRow(
actionButton(
inputId = "myAppButton",
label = NULL,
icon = icon("users"),
width = NULL,
status = "primary",
style = "margin: auto",
dashboardBadge(1, color = "danger")
)
),
sidebarMenu(
id = "sidebarID",
menuItem("Live", tabName = "live", icon = icon("circle")),
menuItem("Drivers", tabName = "drivers", icon = icon("user-friends")),
menuItem("Customers", tabName = "customers", icon = icon("building"))
)
),
body = bodyTag
)
server <- function(input, output) {
observeEvent(input$sidebarID, {
updateBox("panel", action = "toggle")
})
output$map <- renderLeaflet({
leaflet() %>%
setView(lng = -73.98928, lat = 40.75042, zoom = 6) %>%
addProviderTiles("CartoDB.Positron")
})
# the problem is here
observe({
if(input$tabs == "drivers") {
print("Drivers")
#print(input$tabs)
} else {
print("other tabs")
}
})
}
shinyApp(ui = ui, server = server)
I'm pretty sure that input$tabs is how I should get to the given menuItem but maybe I'm wrong.
You're wrong. Many other posted solutions to this problem use tabs as the id of the sidebar menu, but you don't:
sidebarMenu(
id = "sidebarID",
menuItem("Live", tabName = "live", icon = icon("circle")),
menuItem("Drivers", tabName = "drivers", icon = icon("user-friends")),
menuItem("Customers", tabName = "customers", icon = icon("building"))
)
So you need
observe({
if(input$sidebarID == "drivers") {
print("Drivers")
#print(input$tabs)
} else {
print("other tabs")
}
})
It's a simple typo.
I am unable to create a conditional sidebar menu via renderMenu because the if statement fails. "Warning: Error in if: argument is of length zero".
I found conditional RenderUI R shiny and Conditional panel in Shiny dashboard but neither are what I am looking for. A conditional panel might work in this instance but in the long run I will need to be able to do this server side.
if (interactive()) {
library(ggplot2)
library(shiny)
library(shinydashboard)
library(shinipsum)
ui <- dashboardPage(
header = dashboardHeader(),
dashboardSidebar(
sidebarMenuOutput("plotDataVHA"),
sidebarMenuOutput("tabSelector")
),
dashboardBody(tabItems(
tabItem(tabName = "facilities",
fluidRow(box(
uiOutput("selectedFacilityTime")
))),
tabItem(tabName = "service",
fluidRow(box(
uiOutput("selectedFacilityYyCases")
)))
))
)
server <- function(input, output) {
output$renderedSelectedFacilityTime <- renderPlot({
random_ggplot(type = "line")
})
output$selectedFacilityTime <- renderUI({
plotOutput("renderedSelectedFacilityTime")
})
output$renderedFacilityYyCases <- renderPlot({
random_ggplot(type = "bar")
})
output$selectedFacilityYyCases <- renderUI({
plotOutput("renderedFacilityYyCases")
})
output$tabSelector <- renderMenu({
sidebarMenu(id = "test",
menuItem(
text = "Chart data",
menuSubItem(
text = "Facilities",
tabName = "facilities",
selected = TRUE
),
menuSubItem(
text = "Service & Specialty",
tabName = "service",
icon = NULL
)
))
})
output$plotDataVHA <- renderMenu({
if (input$test == "facilities") {
sidebarMenu(
menuItem(
text = "VHA data",
menuSubItem(
text = "None",
selected = TRUE,
icon = NULL
),
menuSubItem(text = "Mean", icon = NULL)
)
)
}
})
}
shinyApp(ui, server)
}
When working properly the menu "VHA data" should only be visible when the submenu "facilities" is selected.
Interesting question. The reason you were getting the argument is of length zero error is because you are rendering both menus on the server side through renderMenu(). So when the app starts, input$test doesn't have a value assigned to it. You can avoid this by using req() which will evaluate the test input$test == "facilities" only after input$test has been initiated.
Now for the menu to only appear when another submenu is selected, you want to create the menu independently of renderMenu(). It is better to evaluate the condition in a normal reactive() and then pass this reactive function as input to renderMenu(). Finally, to remove the menu when input$test == "facilities" is FALSE, you can render an empty html container.
Here is the updated code:
library(ggplot2)
library(shiny)
library(shinydashboard)
library(shinipsum)
ui <- dashboardPage(
header = dashboardHeader(),
dashboardSidebar(
sidebarMenuOutput("plotDataVHA"),
sidebarMenuOutput("tabSelector")
),
dashboardBody(tabItems(
tabItem(tabName = "facilities",
fluidRow(box(
uiOutput("selectedFacilityTime")
))),
tabItem(tabName = "service",
fluidRow(box(
uiOutput("selectedFacilityYyCases")
)))
))
)
server <- function(input, session, output) {
output$renderedSelectedFacilityTime <- renderPlot({
random_ggplot(type = "line")
})
output$selectedFacilityTime <- renderUI({
plotOutput("renderedSelectedFacilityTime")
})
output$renderedFacilityYyCases <- renderPlot({
random_ggplot(type = "bar")
})
output$selectedFacilityYyCases <- renderUI({
plotOutput("renderedFacilityYyCases")
})
output$tabSelector <- renderMenu({
sidebarMenu(id = "test",
menuItem(
text = "Chart data",
menuSubItem(
text = "Facilities",
tabName = "facilities",
selected = TRUE
),
menuSubItem(
text = "Service & Specialty",
tabName = "service",
selected = FALSE,
icon = NULL
)
))
})
make_menu <- reactive({
cat("Current submenu selected: ", input$test, "\n\n")
if (req(input$test) == "facilities") {
sidebarMenu(
menuItem(
text = "VHA data",
menuSubItem(
text = "None",
selected = TRUE,
icon = NULL
),
menuSubItem(text = "Mean", icon = NULL)
)
)
} else {
# return an empty HTML container
div()
}
})
output$plotDataVHA <- renderMenu({
make_menu()
})
}
shinyApp(ui, server)
I am fairly new to Shiny, shinydashboard and DT. I am trying to build a simple application where I load data from .csv file, generated like this:
x <- data.table(VAR1 = rnorm(n = 20, mean = 10, sd = 2), VAR2 = rnorm(n = 20, mean = 100, sd = 20), VAR3 = 1:20, VAR4 = 21:40)
write.csv(x = x, file = "/tmp/test_data.csv")
I have built the application where I have a dashboard with two menu items (Data and My Items), the second one has three subitems. The first menu item (Data) has "Browse" button is loading the data and show it in a DT table. The subitems in the second menu item (My Items) should show output only when the data is loaded. Each of them should show a heading and a DT table with two of the variables in the loaded data set. However, when the data is loaded, all the outputs are shown in the first tab and the tabs for the subitems of the second menu item remain empty.
When there is no reactive input (like in this simple example) everything works fine, but with reactive output things seem different. Apparently, there are still things that I fail to understand. Can someone help?
Here is the application:
library(shiny)
library(shinydashboard)
library(data.table)
library(DT)
ui <- dashboardPage(title = "Dashboard Title",
dashboardHeader(title = "My Dashboard"),
dashboardSidebar(
sidebarMenu(id = "menu",
menuItem(text = "Data", icon = icon("database"), tabName = "inputData",
fileInput(inputId = "file", label = "Choose CSV File",
multiple = TRUE,
accept = ".csv")),
menuItem(text = "My Items", tabName = "items", icon = icon("book"),
menuSubItem(text = "Item 1", tabName = "item01"),
menuSubItem(text = "Item 2", tabName = "item02"),
menuSubItem(text = "Item 3", tabName = "item03")
)
)
),
dashboardBody(
tabItems(
tabItem(tabName = "inputData", class = "active",
h1(textOutput("heading")),
dataTableOutput("loaded.data")),
tabItem(tabName = "items", h1(textOutput("heading0")), class = "active",
tabItem(tabName = "item01", class = "active", h1(textOutput("heading1")), dataTableOutput("table1")),
tabItem(tabName = "item02", class = "active", h1(textOutput("heading2")), dataTableOutput("table2")),
tabItem(tabName = "item03", class = "active", h1(textOutput("heading3")), dataTableOutput("table3"))
)
)
)
)
server <- function(input, output) {
# Load the data and assign it to a reactive object
df <- reactive({
inFile <- input$file
if(is.null(inFile)) {
return(NULL)
} else {
tbl <- fread(input$file$datapath, sep = ",", quote = '"', stringsAsFactors = TRUE)
return(tbl)
}
})
output$heading <- renderText({
if(is.null(df())) {
return(NULL)
} else {
return("Data loaded")
}
})
output$loaded.data <- renderDT({
if(is.null(df())) {
return(NULL)
} else {
df()
}
})
output$heading0 <- renderText({
if(is.null(df())) {
return(NULL)
} else {
return("In the sub-menus below you will find the tables")
}
})
output$heading1 <- renderText({
if(is.null(df())) {
return(NULL)
} else {
return("Heading item 1")
}
})
output$table1 <- renderDT({
if(is.null(df())) {
return(NULL)
} else {
return(df()[ , c("VAR1", "VAR2")])
}
})
output$heading2 <- renderText({
if(is.null(df())) {
return(NULL)
} else {
return("Heading item 2")
}
})
output$table2 <- renderDT({
if(is.null(df())) {
return(NULL)
} else {
return(df()[ , c("VAR2", "VAR3")])
}
})
output$heading3 <- renderText({
if(is.null(df())) {
return(NULL)
} else {
return("Heading item 3")
}
})
output$table3 <- renderDT({
if(is.null(df())) {
return(NULL)
} else {
return(df()[ , c("VAR2", "VAR3")])
}
})
}
shinyApp(ui, server)
I think you should write your dashboardBody as follows:
dashboardBody(
tabItems(
tabItem(tabName = "inputData",
h1(textOutput("heading")),
dataTableOutput("loaded.data")),
tabItem(tabName = "item01",
h1(textOutput("heading1")),
dataTableOutput("table1")),
tabItem(tabName = "item02",
h1(textOutput("heading2")),
dataTableOutput("table2")),
tabItem(tabName = "item03",
h1(textOutput("heading3")),
dataTableOutput("table3"))
)
)
EDIT
Doing so, the full table does not appear anymore. To solve this issue, my proposal is to add a new menuSubItem in dashboardSidebar for the full table as follows:
dashboardSidebar(
sidebarMenu(id = "menu",
menuItem(text = "Data", icon = icon("database"),
fileInput(inputId = "file", label = "Choose CSV File",
multiple = TRUE,
accept = ".csv"),
menuSubItem(text = "Full Table", tabName = "inputData")
),
menuItem(text = "My Items", icon = icon("book"),
menuSubItem(text = "Item 1", tabName = "item01"),
menuSubItem(text = "Item 2", tabName = "item02"),
menuSubItem(text = "Item 3", tabName = "item03")
)
)
)
Or a bit nicer (IMHO):
dashboardSidebar(
sidebarMenu(id = "menu",
menuItem(text = "Data", icon = icon("database"),
fileInput(inputId = "file", label = "Choose CSV File",
multiple = TRUE,
accept = ".csv")
),
menuItem(text = "My Items", icon = icon("book"),
menuSubItem(text = "Full Table", tabName = "inputData"),
menuSubItem(text = "Item 1", tabName = "item01"),
menuSubItem(text = "Item 2", tabName = "item02"),
menuSubItem(text = "Item 3", tabName = "item03")
)
)
)
I have an shinydashboard app, the app get an filter box and a tabset which show a datatatable depending on filter.
I have a reset button which reset the filters whith shinyjs::reset function, and I want to reset also the tableset and showing the complete table or nothing.
I want also to do it for a valuboxes.
My app is like this :
For server interface I have an basic : output$tableprint_A <- DT::renderDataRable ({})
ui :
body <- dashboardBody(
tabItems(
#### First tab item #####
tabItem(tabName = "fpc",
fluidRow(
infoBoxOutput("kpm_inf", width = 6),
infoBoxOutput(outputId = "fpc_inf", width = 6)
),
fluidRow(
box(title = "Variables filter",
shinyjs::useShinyjs(),
id = "side_panel",
br(),
background = "light-blue",
solidHeader = TRUE,
width = 2,
selectInput("aaa", "aaa", multiple = T, choices = c("All", as.character(unique(fpc$aaa))))
br(),
br(),
p(class = "text-center", div(style = "display:inline-block", actionButton("go_button", "Search",
icon = icon("arrow-circle-o-right"))),
div(style = "display:inline-block", actionButton("reset_button", "Reset",
icon = icon("repeat")))),
p(class = 'text-center', downloadButton('dl_fpc', 'Download Data'))),
tabBox(
title = tagList(),
id = "tabset1",
width = 10,
tabPanel(
"A \u2030 ",
DT::dataTableOutput("tableprint_A"),
bsModal(id = 'startupModal', title = 'Update message', trigger = '',
size = 'large',
tags$p(tags$h2("Last update of A : 01/09/2017",
br(), br(),
"Last update of B : 01/09/2017",
br(), br(),
"Last update of C : 01/09/2017",
style = "color:green", align = "center")))
),
tabPanel(
"B % Table",
DT::dataTableOutput("tableprint_B")),
type = "pills"
)
),
fluidRow(
# Dynamic valueBoxes
valueBoxOutput("info_gen", width = 6)
)
I tried this :
observeEvent(input$reset_button, {
output$tableprint_A <- NULL
})
Edit:
I want something like that, but when I action the search button I want it to appear again :
shinyjs::onclick("reset_button",
shinyjs::toggle(id = "tableprint_A", anim = TRUE))
You should try this out:
output$tableprint_A <- renderDataTable({
if(input$reset_button == 1) {
NULL
}else{
datatable(...)
}
})
if the button is clicked then nothing will be displayed, else the datatable is shown.
[EDIT]
library(shiny)
library(DT)
shinyApp(
ui = fluidPage(selectInput("select", "select", choices = unique(iris$Species), multiple = T),
actionButton("go_button", "Search",
icon = icon("arrow-circle-o-right")),
actionButton("reset_button", "Reset",
icon = icon("repeat")),
DT::dataTableOutput('tbl')),
server = function(input, output) {
values <- reactiveValues(matrix = NULL)
observe({
if (input$go_button == 0)
return()
values$matrix <- iris[iris$Species %in% input$select, ]
})
observe({
if (input$reset_button == 0)
return()
values$matrix <- NULL
})
output$tbl = DT::renderDataTable({
datatable(values$matrix, options = list(lengthChange = FALSE))}
)
}
)