How to add the same inputs into two tabItems in shinydashboard? - r

I am using shinydashboard to create the interface of my shiny App. However I want one input which appear in the two tabMenu. In the example below, I want to textInput i_test appears in menu menu1 and menu2.
How should I implement it? Thanks for any suggestions.
library(shiny)
library(shinydashboard)
# Side bar boardy
sidebar <- dashboardSidebar(
sidebarMenu(
id = 'menu_tabs'
, menuItem('menu1', tabName = 'menu1')
, menuItem('menu2', tabName = 'menu2')
, menuItem('menu3', tabName = 'menu3')
)
)
# Body board
body <- dashboardBody(
tabItems(
tabItem(
tabName = 'menu1',
textInput('i_test', 'Test')
),
tabItem(
tabName = 'menu2'
)
)
)
# Shiny UI
ui <- dashboardPage(
title = 'test',
dashboardHeader(),
sidebar,
body
)
server <- function(input, output, session) {
}
shinyApp(ui, server)

It seems that shiny always renders two distinct elements, even if you try to build the same element a second time.
Thats why i could only come up with a solution that only makes it look like the two text iputs are the same.
Check the Code:
library(shiny)
library(shinydashboard)
# Side bar boardy
sidebar <- dashboardSidebar(
sidebarMenu(
id = 'menu_tabs'
, menuItem('menu1', tabName = 'menu1')
, menuItem('menu2', tabName = 'menu2')
, menuItem('menu3', tabName = 'menu3')
)
)
# Body board
body <- dashboardBody(
tabItems(
tabItem(
tabName = 'menu1',
textInput('i_test_1', 'Test')
),
tabItem(
tabName = 'menu2',
textInput('i_test_2', 'Test')
),
tabItem(
tabName = 'menu3'
)
)
)
# Shiny UI
ui <- dashboardPage(
title = 'test',
dashboardHeader(),
sidebar,
body
)
server <- function(input, output, session) {
observe({
text1 <- input$i_test_1
updateTextInput(session, 'i_test_2', value = text1)
})
observe({
text2 <- input$i_test_2
updateTextInput(session, 'i_test_1', value = text2)
})
}
shinyApp(ui, server)

Related

R Shiny dashboard loading tabs only once

I started building my first shiny app but am now struggling with a strange behaviour. First, when I initially load the app, no tab is selected by default. Second, when clicking on any menu on the sidebar it shows the body only on the first time. When I go from "Overview" to "Pivot-Tabelle" and back, the body is blank. What am I missing? Below is the code I used.
library(shiny)
library(shinydashboard)
df<-data.frame(a=c(1,2,3,4),
b=c("A","B","C","D"))
###################Beginn der App################
ui <- dashboardPage(
# Application title
dashboardHeader(),
##----DashboardSidebar----
dashboardSidebar(
menuItem("Overview", tabName = "overview",selected=TRUE),
menuItem("Pivot-Tabelle", tabName = "pivot"),
menuItem("Test", tabName = "farmer")
),
##----DashboardBody----
dashboardBody(
tabItems(
##----TabItem: Overview----
tabItem(tabName="overview",
fluidRow(
valueBoxOutput("A"),
valueBoxOutput("B")
)
),
###----TabItem:Pivot----
tabItem(tabName = "pivot",
##Pivot
column(6,offset=4,titlePanel("Daten-Explorer")),
column(12,
mainPanel(
rpivotTableOutput("pivot")
)
)
),
##----TabItem:Test----
tabItem(tabName = "Test",
h2("In Progress"))
)
)
)
server <- function(input, output) {
##----server:overview----
output$A<-renderValueBox({
valueBox(
paste0(25, "%"), "Landwirte in der Datenbank", icon = icon("Person"),
color = "purple"
)
})
output$B<-renderValueBox({
valueBox(
paste0(55, "%"), "Landwirte in der Datenbank", icon = icon("Person"),
color = "purple"
)
})
##----server:pivot----
output$pivot <- renderRpivotTable({
rpivotTable(data = df)
})
}
# Run the application
shinyApp(ui = ui, server = server)
This seems to work. You need to have sidebarMenu for your menuItems. Also, you need to change tabName to farmer so it matches your menuItem. And I don't think you need mainPanel in there (you can use mainPanel with sidebarPanel as part of a sidebarLayout if you wanted that layout - see layout options). See if this works for you.
library(shiny)
library(shinydashboard)
library(rpivotTable)
df<-data.frame(a=c(1,2,3,4),
b=c("A","B","C","D"))
###################Beginn der App################
ui <- dashboardPage(
# Application title
dashboardHeader(),
##----DashboardSidebar----
dashboardSidebar(
sidebarMenu(
menuItem("Overview", tabName = "overview",selected=TRUE),
menuItem("Pivot-Tabelle", tabName = "pivot"),
menuItem("Test", tabName = "farmer")
)
),
##----DashboardBody----
dashboardBody(
tabItems(
##----TabItem: Overview----
tabItem(tabName="overview",
fluidRow(
valueBoxOutput("A"),
valueBoxOutput("B")
)
),
###----TabItem:Pivot----
tabItem(tabName = "pivot",
##Pivot
column(6,offset=4,titlePanel("Daten-Explorer")),
column(12,
#mainPanel(
rpivotTableOutput("pivot")
#)
)
),
##----TabItem:Test----
tabItem(tabName = "farmer",
h2("In Progress"))
)
)
)
server <- function(input, output) {
##----server:overview----
output$A<-renderValueBox({
valueBox(
paste0(25, "%"), "Landwirte in der Datenbank", icon = icon("Person"),
color = "purple"
)
})
output$B<-renderValueBox({
valueBox(
paste0(55, "%"), "Landwirte in der Datenbank", icon = icon("Person"),
color = "purple"
)
})
##----server:pivot----
output$pivot <- renderRpivotTable({
rpivotTable(data = df)
})
}
# Run the application
shinyApp(ui = ui, server = server)

Shiny Dashboard: Render multiple menu items and output dynamic content to each

I need to render various menu sub-items based on some reactive data values. For each sub-item, I also need to associate linked output. I tried to link with tabName, but not sure what went wrong.
Below is an example. The desired output will be one box for each menu item/sub-item.
## This code snippet doesn't do what I need ----
shinyApp(
ui = dashboardPage(
dashboardHeader(),
dashboardSidebar(
sidebarMenu(
menuItemOutput("dynamic_menu"),
menuItem("Menu2", tabName = "menu2")
)
),
dashboardBody(
tabItems(
uiOutput("menu1_content"),
tabItem(tabName = "menu2", box("I am menu2"))
)
),
title = "Example"
),
server = function(input, output) {
output$dynamic_menu <- renderMenu({
submenu_list <- lapply(letters[1:5], function(x) {
menuSubItem(x, tabName = paste0("menu1-", x))
})
menuItem(
text = "Menu1",
startExpanded = TRUE,
do.call(tagList, submenu_list)
)
})
output$menu1_content <- renderUI({
content_list <- lapply(letters[1:5], function(x) {
tabItem(
tabName = paste0("menu1-", x),
box(x)
)
})
do.call(tagList, content_list)
})
}
)
## This code snippet does what I need ----
shinyApp(
ui = dashboardPage(
dashboardHeader(),
dashboardSidebar(
sidebarMenu(
menuItem(
"Menu1", startExpanded = TRUE,
menuSubItem("a", tabName = "menu1-a"),
menuSubItem("b", tabName = "menu1-b"),
menuSubItem("c", tabName = "menu1-c"),
menuSubItem("d", tabName = "menu1-d"),
menuSubItem("e", tabName = "menu1-e")
),
menuItem("Menu2", tabName = "menu2")
)
),
dashboardBody(
tabItems(
tabItem(tabName = "menu1-a", box("a")),
tabItem(tabName = "menu1-b", box("b")),
tabItem(tabName = "menu1-c", box("c")),
tabItem(tabName = "menu1-d", box("d")),
tabItem(tabName = "menu1-e", box("e")),
tabItem(tabName = "menu2", box("I am menu2"))
),
title = "Example"
)
),
server = function(input, output) {}
)
Answering my own question, but feel free to jump in if you have something more elegant.
I think my initial understanding of shiny dashboard is wrong, causing the app structure to be invalid.
The trick here is to add id to the sidebarMenu, so that page focus could be tracked and parsed later. Then each of the render function will listen on the input and render associated content.
shinyApp(
ui = dashboardPage(
dashboardHeader(),
dashboardSidebar(
sidebarMenu(
id = "sidebar_menu",
menuItemOutput("dynamic_menu"),
menuItem("Menu2", tabName = "menu2")
)
),
dashboardBody(
uiOutput("menu1_content"),
uiOutput("menu2_content")
),
title = "Example"
),
server = function(input, output, session) {
output$dynamic_menu <- renderMenu({
menu_list <- lapply(letters[1:5], function(x) {
menuSubItem(x, tabName = paste0("menu1-", x))
})
menuItem(
text = "Menu1",
startExpanded = TRUE,
do.call(tagList, menu_list)
)
})
output$menu1_content <- renderUI({
sidebar_menu <- tstrsplit(input$sidebar_menu, "-")
if (sidebar_menu[[1]] == "menu1") box(sidebar_menu[[2]])
})
output$menu2_content <- renderUI({
sidebar_menu <- tstrsplit(input$sidebar_menu, "-")
if (sidebar_menu[[1]] == "menu2") box("I am menu2")
})
}
)

Embed weather iframe into Shiny Dashboard

I am trying to embed the weather forecast from forecast.io in a Shiny dashboard. I originally had trouble with the ampersand but saw a post that provided an example of how to format HTML code with special characters. However, when I run the app I see a simple "Not Found", even though I know that the link works and is being formatted correctly. I'm not sure what I'm missing.
library(shiny)
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(title = "Dashboard"),
dashboardSidebar(
sidebarMenu(
menuItem("Dashboard", tabName = "dashboard", icon = icon("dashboard"))
)
),
dashboardBody(
tabItems(
# First tab content
tabItem(tabName = "dashboard",
fluidRow(
column(12,
mainPanel(htmlOutput("frame")
)
)
)
)
)
)
)
server <- shinyServer(function(input, output) {
output$frame <- renderUI({
tags$iframe(id = 'app', src = url("https://forecast.io/embed/#lat=42.3583&lon=-71.0603&name=Downtown Boston"), width = '100%')
})
})
shinyApp(ui,server)
Screen capture of error in Shiny Dashboard
Update with inserted dashboard
I transfered url from server to ui:
library(shiny)
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(title = "Dashboard"),
dashboardSidebar(
sidebarMenu(
menuItem("Dashboard",
tabName = "dashboard",
icon = icon("dashboard")
)
)
),
dashboardBody(
tabItems(
tabItem(
tabName = "dashboard",
fluidRow(
tags$iframe(
seamless = "seamless",
src = "https://forecast.io/embed/#lat=42.3583&lon=-71.0603&name=Downtown Boston",
height = 800, width = 1400
)
)
)
)
)
)
server <- function(input, output) {}
shinyApp(ui, server)

SideBar Not rendering anything on Dashboard Body: R Shiny Dashboard

I am creating a shiny Dashboard which has two tabs in the side bar. Tab1 is for importing a csv and Tab2 is for showing the plots for the selected variable.
Tab2 has 1 select input option for selecting the variable for plot
Problem: After clicking on sidebar tabs, my dashboard body doesn't change. It is always showing me Tab1 Content i.e csv import results.
So despite of clicking on Tab2 in sidebar, nothing happens
Following is my script
library(shinydashboard)
library(shiny)
library(DT)
#UI
sidebar=dashboardSidebar(width=200,
sidebarMenu( id="sidebar",
menuItem("Data UpLoad", tabName = "dashboard", icon = icon("table"),
fileInput('file1','Choose CSV File',
accept=c('text/csv','text/comma-separated-values,text/plain', '.csv'))),
menuItem("Uni Variate", tabName = "Uni", icon = icon("line-chart"),
fluidRow(
selectInput("options",label=h5("Select Column"),"")))))
body= dashboardBody(
tabItems(
tabItem(tabName="dashboard",class='active',
fluidRow(
box(
title="Data",solidHeader = TRUE, collapsible = TRUE,
div(style='overflow-x: scroll',tableOutput("table1"))))),
tabItem(tabName = "Uni",
fluidRow(box(title="Plot",solidHeader = TRUE,plotOutput("plot1"))),
h2("tab content"))))
dashboardPage(
dashboardHeader(title= "test"),sidebar,body)
#Server
server <- function(input, output,session) {
data_set <- reactive({
req(input$file1)
inFile <- input$file1
data_set1<-read.csv(inFile$datapath)
list(data=data_set1)
})
# updating select input of second tab in shiny side bar
observe({
updateSelectInput(
session,
"options",
choices = names(data_set()$data))})
# tab1
output$table1= renderTable({
de=as.data.frame(data_set()$data[1:7,])})
#tab2
output$plot1 <- renderPlot({ggplot(data_set$data,aes(y=input$options,x=Prediction))+geom_histogram(binwidth=0.50, fill="blue") })
}
Every help is important!
It seems that the problem is related to putting widgets on the sidebar, it takes them as sub-menus. Below are a couple of possible solution to have widgets on the sidebar depending if you want to hide them when are inactive.
Option 1- widgets always visible
library(shinydashboard)
library(shiny)
sidebar <- dashboardSidebar(width=200,
sidebarMenu( id="sidebar",
menuItem("Data UpLoad", icon = icon("table"), tabName = "dashboard"),
div(
fileInput('file1','Choose CSV File',
accept=c('text/csv','text/comma-separated-values,text/plain', '.csv'))
),
menuItem("Uni Variate", icon = icon("line-chart"), tabName = "Uni"),
div(
selectInput("options",label=h5("Select Column"),"")
)
)
)
body <- dashboardBody(
tabItems(
tabItem(tabName="dashboard", class='active',
box( title="Data",solidHeader = TRUE, collapsible = TRUE,
div(style='overflow-x: scroll', p("table1"))
)
),
tabItem(tabName = "Uni",
box(title="Plot", solidHeader = TRUE, p("plot1"))
)
)
)
server <- function(input, output,session) {}
shinyApp(dashboardPage(dashboardHeader(title= "test"), sidebar, body), server = server)
Option 2- widgets only visible when tab is active
Please note that to show the correct tab on the body, the users must click on the sub-item.
library(shinydashboard)
library(shiny)
sidebar <- dashboardSidebar(width=200,
sidebarMenu( id="sidebar",
menuItem("data", icon = icon("table"), tabName = "dashboard",
menuSubItem(tabName = "dashboard",
fileInput('file1','Choose CSV File',
accept=c('text/csv','text/comma-separated-values,text/plain', '.csv'))
)),
menuItem("Uni Variate", icon = icon("line-chart"), tabName = "Uni",
menuSubItem( tabName = "Uni",
selectInput("options",label=h5("Select Column"),"")
))
)
)
body <- dashboardBody(
tabItems(
tabItem(tabName="dashboard", class='active',
box( title="Data",solidHeader = TRUE, collapsible = TRUE,
div(style='overflow-x: scroll', p("table1"))
)
),
tabItem(tabName = "Uni",
box(title="Plot", solidHeader = TRUE, p("plot1"))
)
)
)
server <- function(input, output,session) {}
shinyApp(dashboardPage(dashboardHeader(title= "test"), sidebar, body), server = server)

Shiny ConditionalPanel for Sidebar

I am trying to use update my Shiny Dashboard Sidebar based on the tab selected in the Main body. So when tab "Overall" is selected then this should display the menu items in Conditional Panel 1 (TA.Name1,TA.Name2), and when tab "Other" is selected then the sidebar displays the menu items for conditional panel 2. Data is bellow:
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(
conditionalPanel(condition="input.conditionedPanels==1", sidebarMenu(width=150,
menuItem("TA.Name1", tabName = "TA1")),
menuItem("TA.Name2", tabName = "TA2"))),
conditionalPanel(condition="input.conditionedPanels==2",sidebarMenu(width=150,
menuItem("EA.Name1", tabName = "EA1")),
menuItem("EA.Name2", tabName = "EA2"))),
dashboardBody(
tabsetPanel(
tabPanel("Overall",value=1,fluidRow(
column(3,selectInput("PACO", h5("PACO"), levels(OA$PACO)))),
tabItems(
tabItem(tabName = "TA1","TA1"),fluidRow(
box(title="TA.Name1,dygraphOutput("TA1.data")),
box(title="TA.Name2,dygraphOutput("TA2.data")))),
tabItem(tabName = "TA2","TA2")
)),
tabPanel("Other",value=2,fluidRow(
column(3,selectInput("CV", h5("CV"), levels(OA$CV)))),
tabItems(
tabItem(tabName = "EA1","EA1"),fluidRow(
box(title="EA.Name1,dygraphOutput("EA1.data")),
box(title="EA.Name2,dygraphOutput("EA2.data")))),
tabItem(tabName = "EA2","EA2")
))))
Your Example Code is not good, i think You should have a look at this feed:
http://stackoverflow.com/questions/5963269/how-to-make-a-great-r-reproducible-example
I had to simplify Your code to actually find solution...
Have a look at it:
library(shiny)
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(
sidebarMenu(id="tabs",
sidebarMenuOutput("menu"))),
dashboardBody(
tabsetPanel(id="tabs2",
tabPanel("Overall",value=1),
tabPanel("Other",value=2))))
server <- function(input, output, session) {
output$menu <- renderMenu({
if (input$tabs2 == 1 ) {
sidebarMenu(
menuItem("TA.Name1", tabName = "TA1"),
menuItem("TA.Name2", tabName = "TA2"))}
else{
sidebarMenu(
menuItem("EA.Name1", tabName = "EA1"),
menuItem("EA.Name2", tabName = "EA2"))
}
})
}
shinyApp(ui = ui, server = server)
It should do what You want -- > reactive sidebarMenu

Resources