How do I structure the layout of my shiny dashboard? - r

I am creating a simple shiny app, and would love to structure my app in a certain way. See screenshot below -
Some things to highlight -
The solid line below the value boxes
In 3 sections with the sales map, sales trend plot and bar plot, is it possible to have a title for those sections, along with an info action button which I'll use to provide more info about the chart?
I am able to create the sidebar and value boxes with the code below, however I have trouble understanding how to use columns and/or boxes "below" the value boxes. See code below -
library(shiny)
library(shinydashboard)
# UI ----
ui <- navbarPage(
useShinydashboard(),
title = "My App",
tabPanel(
"Tab1", icon = icon("home"),
fluidPage(
sidebarLayout(
sidebarPanel(
width = 2,
dateRangeInput(inputId = "date_range",
label = h4("Date Range"),
start = as.Date("2018-01-01"),
end = as.Date("2020-12-31"),
min = as.Date("2018-01-01"),
max = as.Date("2020-12-31"),
startview = "year"
)
),
mainPanel(
# Value Box 1
valueBoxOutput(outputId = "box_1", width = 3),
# Value Box 2
valueBoxOutput(outputId = "box_2", width = 3),
# Value Box 3
valueBoxOutput(outputId = "box_3", width = 3),
# Value Box 4
valueBoxOutput(outputId = "box_4", width = 3),
br(),
hr()
)
)
)
)
)
# Server ----
server <- function(input, output) {
# Box 1
output$box_1 <- shinydashboard::renderValueBox({
valueBox(5, "box1", color = "green"
)
})
# Box 2
output$box_2 <- renderValueBox({
valueBox(10, "box2", color = "blue"
)
})
# Box 3
output$box_3 <- renderValueBox({
valueBox(15, "box1", color = "purple"
)
})
# Box 4
output$box_4 <- renderValueBox({
valueBox(20, "box1", color = "orange"
)
})
}
# Run the application
shinyApp(ui = ui, server = server)

Here is a possibility:
library(shiny)
library(shinydashboard)
library(shinyBS) # for popovers
# UI ----
ui <- navbarPage(
#useShinydashboard(),
title = "My App",
tabPanel(
"Tab1", icon = icon("home"),
fluidPage(
sidebarLayout(
sidebarPanel(
width = 2,
dateRangeInput(inputId = "date_range",
label = h4("Date Range"),
start = as.Date("2018-01-01"),
end = as.Date("2020-12-31"),
min = as.Date("2018-01-01"),
max = as.Date("2020-12-31"),
startview = "year"
)
),
mainPanel(
fluidRow(
# Value Box 1
valueBoxOutput(outputId = "box_1", width = 3),
# Value Box 2
valueBoxOutput(outputId = "box_2", width = 3),
# Value Box 3
valueBoxOutput(outputId = "box_3", width = 3),
# Value Box 4
valueBoxOutput(outputId = "box_4", width = 3),
),
tags$hr(),
br(),
fluidRow(
column(
width = 6,
tags$fieldset(
tags$legend("Plot 1", tags$span(id = "info1", icon("info-circle"))),
plotOutput("plot1", height = "600px")
)
),
bsPopover(
"info1",
title = "This is plot 1",
content = "This plot is nice",
placement = "left"
),
column(
width = 6,
tags$fieldset(
tags$legend("Plot 2"),
plotOutput("plot2", height = "300px")
),
tags$fieldset(
tags$legend("Plot 3", heigh = "300px"),
plotOutput("plot3")
)
),
)
)
)
)
)
)
# Server ----
server <- function(input, output) {
# Box 1
output$box_1 <- shinydashboard::renderValueBox({
valueBox(5, "box1", color = "green")
})
# Box 2
output$box_2 <- renderValueBox({
valueBox(10, "box2", color = "blue")
})
# Box 3
output$box_3 <- renderValueBox({
valueBox(15, "box1", color = "purple")
})
# Box 4
output$box_4 <- renderValueBox({
valueBox(20, "box1", color = "orange")
})
####
output$plot1 <- renderPlot({
plot(rnorm(10), rnorm(10))
})
output$plot2 <- renderPlot({
plot(rnorm(10), rnorm(10))
})
output$plot3 <- renderPlot({
plot(rnorm(10), rnorm(10))
})
}
# Run the application
shinyApp(ui = ui, server = server)

Related

R Shiny navbarPage; values not loading from server

Help! For the life of me, I can't get values to populate from the server to the infoBox in the UI.
I've tried to define the infoboxes from the server section, but the infoboxes will only appear if I construct them in the UI (as shown below).
The goal is to populate the boxes with filtered data based on user inputs, but I've abandoned this at this stage because I can't even pass a value from the server to the UI infobox here:
infoBox("Participants Trained",
value = renderText("AYval"), # tried every combo here
width = 12,color = "blue", # tried width = NULL
icon = icon("fa-solid fa-people-group"), fill = F)
A value shows when I hardcode a value in "value = ", but none of the render options, renderText, verbatimText, output$AYval, valueTextbox, listen(),react() will get a value that is hard-coded in the server side to show up in this infobox.
To get the dashboard to display boxes, I'm using header = tagList(useShinydashboard()). My guess is this useShinydashboard() is the culprit.
I thought this comment might be relevant:
Your code using lapply and the navbarPage doesn't generate the UI in
the proper namespace, since when using the navbarPage construct your
modules are "one level deeper".
The script:
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
library(shinyWidgets)
#library(shinyjs)
side_width <- 5
#completing the ui part with dashboardPage
ui <- navbarPage(fluid = TRUE,
theme = shinythemes::shinytheme("flatly"),
collapsible = TRUE,
header = tagList(
useShinydashboard()
),
tabPanel("START"),
tabPanel("Home Dashboard",
value = "Tab1",
# useShinyjs(),
fluidRow(
column(4,
# Selection Input ---------------------------------------------------------
selectInput(inputId = "AY","Academic Year",
multiple = T,
choices = unique(INDGEN$AcademicYear),
selected = unique(INDGEN$AcademicYear)
)),
column(4,
selectInput(inputId = "State","Select State",
choices = c("State","States"))),
column(4,
selectInput(inputId = "Program","Select Program",
choices = c("Program","Programs")))
),
fluidRow(column(12,
box(width = 4,
infoBox("Who?",
width = 12,color = "blue",
fill = F)
),
box(width = 4,
infoBox("Where?", width = 12,color = "blue",
fill = F)
),
box(width = 4,
infoBox("What?", width = 12,color = "blue",
fill = F))
)),
# UI Box R1 ---------------------------------------------------------------
fluidRow(column(12,
box(width = 4,
# uiOutput(infoBoxOutput("BOX1",width = NULL)),
infoBox("Participants Trained", value =
renderText("AYval"),
width = 12,color = "blue",
icon = icon("fa-solid fa-people-group"), fill = F)
),box(width = 4,
infoBox("Training Sites", nrow(data), width = 12,color = "blue",
icon = icon("fa-solid fa-school"), fill = F)
),box(width = 4,
infoBox("Training Programs Offered", nrow(data), width = 12,color = "blue",
icon = icon("fa-solid fa-book-open-reader"), fill = F))
)),
server <- function(input, output,session) {
output$AYval <- renderText({
textInput(13)
})
output$BOX1 <- renderInfoBox({
infoBox(title = "Participants Trained",
value = 13,
width = NULL,color = "blue",
icon = icon("fa-solid fa-people-group"), fill = T)
})
}#Server End
shinyApp(ui = ui,server = server,options = list(height = 1440))
Notice the "participant trained" box is empty. That's because that value isn't hard-coded. The rest are.
Here's a small reproducible example of how to change the value contents dynamically:
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
library(shinyWidgets)
data(iris)
ui <- navbarPage(
fluid = TRUE,
theme = shinythemes::shinytheme("flatly"),
collapsible = TRUE,
header = tagList(
useShinydashboard()
),
tabPanel("START"),
tabPanel(
title = "Home Dashboard",
value = "Tab1",
selectInput("column",
label = "Select a column",
choices = c("Sepal.Length", "Sepal.Width", "Petal.Length", "Petal.Width")
),
box(
width = 4,
infoBoxOutput("test")
)
)
)
server <- function(input, output, session) {
iris_sum <- reactive({
sum(iris[input$column])
})
output$test <- shinydashboard::renderInfoBox({
infoBox(
title = "Where?",
value = iris_sum(),
width = 12,
color = "blue",
fill = F
)
})
}
shinyApp(ui, server)

shiny fix position of collapsible panel

I'm trying to make this shiny app have a collapsible panel fixed at the top. But, whenever I make the position fixed, the collapse functionality doesn't work.
What do I have to do to fix this collapsible panel on top?
library(shiny)
library(shinyWidgets)
library(shinyBS)
library(DT)
ui <- fluidPage(
fluidRow(
column(4),
column(4,
div(
bsCollapse(id = "cntrlC1", open = "Panel 2",
bsCollapsePanel("Control Panel",
htmlOutput("dateSelector", inline = TRUE),
style = "info"
)
)
)
)
),
fluidRow(
DTOutput('sampleTbl')
)
)
server <- function(input, output, session){
output$dateSelector <- renderUI({
airDatepickerInput(
"dateSelector",
label = "Select Start & End Dates",
value = c("2020-01-01", "2020-01-10"),
multiple = 2
)
})
output$sampleTbl <- DT::renderDT(server = TRUE, {
data <- data.frame(A = rep(1, 100), B = rep(2, 100), C = rep(3, 100))
m <- datatable(
data,
options = list(pageLength = 100)
)
m
})
}
shinyApp(ui, server)
Perhaps you are looking for this
ui <- fluidPage(
fluidRow(
column(4),
column(4,
div(
bsCollapse(id = "cntrlC1", open = "Panel 2",
bsCollapsePanel("Control Panel",
htmlOutput("dateSelector", inline = TRUE),
style = "info"
)
), style="position:fixed;"
)
)
),
fluidRow(
column(width=2, textInput("searchField1", "Search")),
column(width=2, uiOutput("saveText1"), actionButton("saveBtn1", "Save"))
),
fluidRow(
DTOutput('sampleTbl')
)
)
server <- function(input, output, session){
output$dateSelector <- renderUI({
airDatepickerInput(
"dateSelector",
label = "Select Start & End Dates",
value = c("2020-01-01", "2020-01-10"),
multiple = 2
)
})
output$sampleTbl <- DT::renderDT(server = TRUE, {
data <- data.frame(A = rep(1, 100), B = rep(2, 100), C = rep(3, 100))
m <- datatable(
data,
options = list(pageLength = 100)
)
m
})
}
shinyApp(ui, server)

How to get the correct InputID while using InsertUI in Shiny

I have a question about InsertUI and the respective InputID of the elements.
In the example below, the inputID of selectizeInput "Number_Product1_1" shows the output for the 1. Division in the boxOutput "InputID".
If this InputID is used as input for the boxOutput "Total", no output is displayed.
If more Divisions are added, the quantity of Product1 (in the example below '50') of the 1. division is the output in the boxOutput "Total" of the following divisions. But why is this output not shown for the 1. division?
I am confused. Can someone explain to me why this shift occurs?
Thanks for your inputs!
library(shiny)
library(shinydashboard)
# Define UI
ui <- fluidPage(
titlePanel("Identify Total amount/Divison"),
sidebarLayout(
sidebarPanel(
width = 12,
# Buttons to add/remove a question
actionButton("add", "Add Divison"),
actionButton("remove", "Remove Divison"),
div(id = "questions",
style = "border: 1px solid silver;")
),
mainPanel(
)))
# Define server logic
server <- function(input, output) {
values <- reactiveValues(num_questions = 0)
# Add a division
observeEvent(input$add, ignoreNULL = FALSE, {
values$num_questions <- values$num_questions + 1
num <- values$num_questions
ui = tags$div(
insertUI(
selector = "#questions", where = "beforeEnd",
splitLayout(
cellWidths = c("20%","20%", "20%", "20%", "20%"),
cellArgs = list(style = "padding: 3px"),
id = paste0("question", num),
textAreaInput(inputId = paste0("Division_", num),
label = paste0(num, ". Division:"),
placeholder = "Placeholder"),
selectizeInput(inputId =paste0("Number_Product1_", num),
label = paste0("Product1"), isolate(seq(from = 50, to = 100000, by = 50)), multiple=FALSE),
selectizeInput(inputId =paste0("Number_Product2_", num),
label = paste0("Product2"), isolate(seq(from = 0, to = 100000, by = 50)), multiple=FALSE),
box(
title = "Total", width = 12, background = "black",
input$Number_Product1_1), #### Input from selectizeInput "Product 1"
box(
title = "inputID", width = 12, background = "black",
paste0("Number_Product1_", num)) #### inputID's of the selectizeinput "Product 1"
)))
})
# Remove a division
observeEvent(input$remove, {
num <- values$num_questions
# Don't let the user remove the very first Row
if (num == 1) {
return()
}
removeUI(selector = paste0("#question", num))
values$num_questions <- values$num_questions - 1
})
}
# Run the application
shinyApp(ui = ui, server = server)
I might have to come up with a better explanation, Meanwhile that error is fixed.
My understanding is that within insertUI you are trying to access an id whose value would be created only after insertUI hence I tried to render it separately and assigned the output of it to the box value.
library(shiny)
library(shinydashboard)
# Define UI
ui <- fluidPage(
titlePanel("Identify Total amount/Divison"),
sidebarLayout(
sidebarPanel(
width = 12,
# Buttons to add/remove a question
actionButton("add", "Add Divison"),
actionButton("remove", "Remove Divison"),
div(id = "questions",
style = "border: 1px solid silver;")
),
mainPanel(
)))
# Define server logic
server <- function(input, output) {
values <- reactiveValues(num_questions = 0)
# Add a division
observeEvent(input$add, ignoreNULL = FALSE, ignoreInit = TRUE,{
values$num_questions <- values$num_questions + 1
num <- values$num_questions
#ui = tags$div(
# observe({
insertUI( immediate = TRUE,
selector = "#questions", where = "beforeEnd",
splitLayout(
cellWidths = c("20%","20%", "20%", "20%", "20%"),
cellArgs = list(style = "padding: 3px"),
id = paste0("question", num),
textAreaInput(inputId = paste0("Division_", num),
label = paste0(num, ". Division:"),
placeholder = "Placeholder"),
selectizeInput(inputId =paste0("Number_Product1_", num),
label = paste0("Product1"), isolate(seq(from = 50, to = 100000, by = 50)), multiple=FALSE,
selected = 50),
selectizeInput(inputId =paste0("Number_Product2_", num),
label = paste0("Product2"), isolate(seq(from = 0, to = 100000, by = 50)), multiple=FALSE),
box(
title = "Total", width = 12, background = "black",
print( input$Number_Product1_1),
textOutput("total")
), #### Input from selectizeInput "Product 1"
box(
title = "inputID", width = 12, background = "black",
paste0("Number_Product1_", num)) #### inputID's of the selectizeinput "Product 1"
))
#)
# })
})
#observe({
# require(input$Number_Product1_1)
output$total <- renderText({
input[["Number_Product1_1"]]
})
# })
# Remove a division
observeEvent(input$remove, {
num <- values$num_questions
# Don't let the user remove the very first Row
if (num == 1) {
return()
}
removeUI(selector = paste0("#question", num))
values$num_questions <- values$num_questions - 1
})
}
# Run the application
shinyApp(ui = ui, server = server)
Image:

Specifying different number of output plots/tables (Shiny app)

I want to give the user option to select which plots/tables he/she wants to see at the end of an analysis.
All the plots are produced from one dataset and include time series plots, boxplots, histograms etc.
The questions I stumbled upon are
Do I use one or multiple plotOutput("Plot",....) element? So far I have been arranging plots in one figure so one plotOutput was sufficient
Do I use the predefined height, as in plotOutput("Plot",height = "1800px")?
If the number of figures varies this creates empty space, I would like to avoid it.
How to add Tables with results?
Any comments would be very appreciated, Mac
You can wrap you plots in conditionalPanel's to deselect them.
For this you will need 1. multiple plotOutput's.
2. When everything is wrapped in a fluidRow there won't be any empty space.
3. See the following example and: http://shiny.rstudio.com/reference/shiny/0.14/tableOutput.html
library(shiny)
library(shinydashboard)
library(shinyWidgets)
ui <- dashboardPage(
dashboardHeader(title = "Plot selection"),
dashboardSidebar(
materialSwitch(inputId="switch1", label = "Show plot 1", value = TRUE, status = "primary"),
materialSwitch(inputId="switch2", label = "Show plot 2", value = TRUE, status = "primary"),
materialSwitch(inputId="switch3", label = "Show plot 3", value = TRUE, status = "primary"),
materialSwitch(inputId="switch4", label = "Show plot 4", value = TRUE, status = "primary")
),
dashboardBody(
# Boxes need to be put in a row (or column)
fluidRow(
conditionalPanel(condition = "input.switch1", box(plotOutput("plot1", height = 250))),
conditionalPanel(condition = "input.switch2", box(plotOutput("plot2", height = 250))),
conditionalPanel(condition = "input.switch3", box(plotOutput("plot3", height = 250))),
conditionalPanel(condition = "input.switch4", box(plotOutput("plot4", height = 250))),
column(12,
dataTableOutput('table')
)
)
)
)
server <- function(input, output) {
df <- data.frame(col1 = rnorm(500), col2 = rnorm(500), col3 = rnorm(500), col4 = rnorm(500))
output$plot1 <- renderPlot({
plot(df$col1, col="red", main="Plot 1")
})
output$plot2 <- renderPlot({
plot(df$col2, col="green", main="Plot 2")
})
output$plot3 <- renderPlot({
plot(df$col3, col="blue", main="Plot 3")
})
output$plot4 <- renderPlot({
plot(df$col4, col="black", main="Plot 4")
})
output$table <- renderDataTable(df)
}
shinyApp(ui, server)
Edit ----------------------------------------
Here is a pure shiny version:
library(shiny)
ui <- fluidPage(
titlePanel("Plot selection"),
sidebarLayout(
sidebarPanel(width = 2,
checkboxInput(inputId="switch1", label = "Show plot 1", value = TRUE),
checkboxInput(inputId="switch2", label = "Show plot 2", value = TRUE),
checkboxInput(inputId="switch3", label = "Show plot 3", value = TRUE),
checkboxInput(inputId="switch4", label = "Show plot 4", value = TRUE)
),
mainPanel(
fluidRow(
conditionalPanel(condition = "input.switch1", plotOutput("plot1", height = 250)),
conditionalPanel(condition = "input.switch2", plotOutput("plot2", height = 250)),
conditionalPanel(condition = "input.switch3", plotOutput("plot3", height = 250)),
conditionalPanel(condition = "input.switch4", plotOutput("plot4", height = 250)),
column(12,
dataTableOutput('table')
)
)
)
)
)
server <- function(input, output) {
df <- data.frame(col1 = rnorm(500), col2 = rnorm(500), col3 = rnorm(500), col4 = rnorm(500))
output$plot1 <- renderPlot({
plot(df$col1, col="red", main="Plot 1")
})
output$plot2 <- renderPlot({
plot(df$col2, col="green", main="Plot 2")
})
output$plot3 <- renderPlot({
plot(df$col3, col="blue", main="Plot 3")
})
output$plot4 <- renderPlot({
plot(df$col4, col="black", main="Plot 4")
})
output$table <- renderDataTable(df)
}
# shinyApp(ui, server)
shinyApp(ui = ui, server = server)
For further information see:
https://rstudio.github.io/shinydashboard/get_started.html
https://dreamrs.github.io/shinyWidgets/reference/materialSwitch.html

rCharts in shiny : width with 2 charts

I have an app with two Highcharts plot, when I start the app the width of the two plots are correct, but everytime I change the mean input, the width of the first plot is set to the width of the second, like this :
When I start the app :
When I change the input :
My code to produce the app :
library(rCharts)
library(shiny)
runApp(list(
ui = fluidPage(
title = "App title",
titlePanel(strong("App title", style="color: steelblue")),
sidebarLayout(
sidebarPanel(width = 2,
br()),
mainPanel(width = 10,
tabsetPanel(
tabPanel("Tab 1",
selectInput(inputId = "input_mean", label = "Mean : ", choices = c(20:30)),
fluidRow(
column(8,
showOutput(outputId = "chart1", lib = "highcharts")
, br(), br(), br(), br(), br(), br(), br(), br(), br(), br(), br()),
column(4,
showOutput(outputId = "chart2", lib = "highcharts"))
)
)
)
)
)
),
server = function(input, output) {
my_data <- reactive({
rnorm(n = 30, mean = as.numeric(input$input_mean))
})
output$chart1 <- renderChart2({
my_data = my_data()
h2 <- Highcharts$new()
h2$chart(type="line")
h2$series(data=my_data, name = "One", marker = list(symbol = 'circle'), color = "lightblue")
h2$set(width = 800, height = 400)
return(h2)
})
output$chart2 <- renderChart2({
my_data = my_data()
my_mean = as.numeric(input$input_mean)
part = data.frame(V1 = c("Sup", "Inf"), V2 = c(sum(my_data>my_mean), sum(my_data<my_mean)))
p = hPlot(x = "V1", y = "V2", data = part, type = "pie")
p$tooltip(pointFormat = "{series.name}: <b>{point.percentage:.1f}%</b>")
p$params$width <- 200
p$params$height <- 200
return(p)
})
}
))
I use rCharts_0.4.5 and shiny_0.9.1.
Thanks !
Replace these lines:
h2$chart(type="line")
h2$set(width = 800, height = 400)
as follows:
h2$chart(type="line", width = 800, height = 400)
This should help.

Resources