How to prevent plot from overspilling out of box in shiny box? - r

I stumbled upon this wierd interaction between collapsed boxes within boxes and plots:
In the the first instance of this, in the minimal working example below, on the left side, expanding the box pushes the plot over the edge of the box, while in the second instance on the right side, it does not.
Also, uncommenting the code of the action button somehow remedies this somehow.
Can someone explain to me why this is happening and how to solve the issue?
I am aware that I could just use the layout to the right, but I would really like to understand this behavior.
Thanks in advance!
library(shiny)
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(),
dashboardBody(
fluidPage(
box(width = 12,
title = "Some Title",
collapsible = TRUE,
solidHeader = TRUE,
status = "danger",
box(widht = 12,
title = "Some Sub Title",
collapsible = TRUE,
solidHeader = TRUE,
box(
width = 12,
title = "Details 1",
collapsible = TRUE,
solidHeader = TRUE,
collapsed = TRUE,
status = "info",
tableOutput("Placeholder_Table_1")
),
#actionButton(inputId = "Action_1",
# label = "Does nothing"
#),
plotOutput("Placeholder_Plot_1")
),
box(widht = 12,
title = "Sub Title 2",
collapsible = TRUE,
solidHeader = TRUE,
plotOutput("Placeholder_Plot_2"),
box(
width = 12,
title = "Details 2",
collapsible = TRUE,
solidHeader = TRUE,
collapsed = TRUE,
status = "info",
tableOutput("Placeholder_Table_2")
)
)
)
)
)
)
server <- function(input, output) {
output$Placeholder_Table_1 <- renderTable(
tibble('Variable 1' = "X",
'Variable 2' = "Y",
'Variable 3' = "Z"
)
)
output$Placeholder_Table_2 <- renderTable(
tibble('Variable 1' = "X",
'Variable 2' = "Y",
'Variable 3' = "Z"
)
)
output$Placeholder_Plot_1 <- renderPlot(
ggplot(data = mtcars) +
labs(title = "Placeholder Plot 1")
)
output$Placeholder_Plot_2 <- renderPlot(
ggplot(data = mtcars) +
labs(title = "Placeholder Plot 2")
)
}
shinyApp(ui, server)

The problem is not the plot, it comes from the box.
First thing you need to know is box is actually using .col-xxx classes from bootstrap and these classes have a CSS float: left;. It will cause itself has 0 height of the parent div. Read this: CSS: Floating divs have 0 height.
However, what you see is it takes some spaces on the UI, so what you see the height is box + plot, but in the parent div height calculation, it's just the plot.
To fix, very easy, wrap your box with fluidrow, .row has a CSS display: table which solves the problem.
fluidRow(box(
width = 12,
title = "Details 1",
collapsible = TRUE,
solidHeader = TRUE,
collapsed = TRUE,
status = "info",
tableOutput("Placeholder_Table_1")
)),

Related

shinydashboard box collapse

library(shinydashboard)
library(shiny)
library(dplyr)
trtall <- rbind(rep("A",100),rep("B",100), rep("C",100))
trt <- sample(trtall,80)
agecat.temp <- c(rep("18-40",100), rep("> 40", 100))
agecat <- sample(agecat.temp, 80)
sex <- sample(rbind(rep("M",100),rep("F",100)),80)
race <- sample(rbind(rep("Asian",50),rep("Hispanic",50),rep("Other",50)),80)
df <- data.frame(trt, agecat, sex, race)
body <- dashboardBody(
fluidRow(box(width=12,collapsed=F, collapsible = T, title="Filters", solidHeader = T,status="primary",
box(width=5, height="220px", status="primary",
fluidRow(column(6,uiOutput("uivr1")),
column(6,uiOutput("uivl1")))))))
ui <- dashboardPage(
dashboardHeader(disable = T),
dashboardSidebar(disable = T),
body, skin = "green"
)
server = function(input, output) {
reacui1 <- reactiveVal()
observeEvent(input$vr1,{
reacui1(as.list(df %>% distinct(!!input$vr1) %>% arrange(!!input$vr1)))
})
output$uivr1 <- renderUI(varSelectInput(width = "200px", "vr1",NULL,df))
output$uivl1 <- renderUI(selectInput("vl1",width="200px",multiple=T,NULL,choices=reacui1()))
}
shinyApp(ui,server)
Hi,
I am dynamically trying to create UI in shiny app. The logic works fine until I collapse the box in shiny dashboard.
I did following steps and got unexpected results.
I select 'trt' in "vr1" and choose "A" from "vl1".
I collapsed the box.
Then un-collapsed the box.
I select 'agecat' in "vr1" - now I still see various treatments (A,B,C) but not distinct age categories (18-40, >40) in "vl1"
Can you please help.
The problem comes from the fact that the shown event is not passed down to the elements which are in a box inside the collapsed box.
Compare this to this slightly changed example:
body <- dashboardBody(
fluidRow(
box(width = 12, collapsed = FALSE, collapsible = TRUE,
title = "Filters", solidHeader = TRUE, status = "primary",
# box(width=5, height="220px", status="primary",
fluidRow(column(6, uiOutput("uivr1")),
column(6, uiOutput("uivl1"))
# )
)
)
)
)
and you see that in this case the second input is properly updated.
You can also use your example, go to the JS console and type $('.box').trigger('shown') and you will see that the select input is suddenly updated.
That means the problem is, that shiny still believes that the inputs are hidden and because hidden inputs are not updated you observe this behavior.
But this tells us how we can fix it:
Workaround is to switch off the suspendWhenHidden property. Add this to your server:
session$onFlushed(function() {
outputOptions(output, "uivl1", suspendWhenHidden = FALSE)
})
This is however, just fixing the symptom and not solving the issue.
Another approach would be to make sure the shown.bs.collapse event is also triggered at the box inside the box. For this we can listen to the shown.bs.collapse event and once received, wait a bit (800ms) such that the box is fully visible and then inform all shiny-bound-output children that they should be shown:
js <- "$(() => $('body').on('shown.bs.collapse', '.box', function(evt) {
setTimeout(function(){
$(evt.target).find('.shiny-bound-output').trigger('shown.bs.collapse');
}, 800);
}))"
body <- dashboardBody(
tags$head(tags$script(HTML(js))),
fluidRow(
box(width = 12, collapsed = FALSE, collapsible = TRUE,
title = "Filters", solidHeader = TRUE, status = "primary",
box(width = 5, height = "220px", status = "primary",
fluidRow(column(6, uiOutput("uivr1")),
column(6, uiOutput("uivl1"))
)
)
)
)
)
This is, BTW, already reported as bug: https://github.com/rstudio/shinydashboard/issues/234

Issue in inserting value with rhandsontable

Thanks for taking your valuable time to pitch in into this question. :-)
I'm building a shiny app that would take user inputs through rhandsontable and save it as a .rds file for data persistence.
The code is as follows:
Global.r
library(shiny)
library(shinydashboard)
library(shinycssloaders
library(rhandsontable)
library(htmltools)
library(plotly)
library(shinyjs)
library(tidyverse)
library(DT)
# Reads the data stored already
raw_data_projects <- readRDS("Projects.rds")
# code to refresh app so as to display the newly added data
jsResetCode <- "shinyjs.reset = function() {history.go(0)}"
ui.R
dashboardPage(skin = "black",
dashboardHeader(dropdownMenuOutput("dropdownmenu"),title = "PMO Dashboard",
tags$li(div(img(src = 'TechM_logo.png',
height = "35px"),
style = "padding-top:10px; padding-bottom:10px;"),
class = "dropdown"),dropdownMenuOutput("msgOutput")) ,
dashboardSidebar(
sidebarMenu(
menuItem("Home", tabName = "home", icon = icon("home")),
menuItem("Projects", tabName = "pros", icon = icon("briefcase")),
menuItem("About Team", tabName = "teamstr", icon = icon("user-friends")),
menuItem("Training & Skills",tabName = "skills",icon = icon("book"))
)),
dashboardBody(
useShinyjs(), # Include shinyjs in the UI
extendShinyjs(text = jsResetCode),
tags$link(rel = "stylesheet", type = "text/css", href = "style_2.css"),
tabItems(
tabItem(tabName = "pros",
fluidPage(tabBox(width = "500px",
tabPanel("Metrics",
fluidRow(
valueBoxOutput("Completed", width = 3),
valueBoxOutput("WIP", width = 3),
valueBoxOutput("Delayed", width = 3),
valueBoxOutput("OnHold", width = 3)
),
fluidRow(
box(plotlyOutput("Project_category"), width = 4,solidHeader = TRUE, status = "primary", title = "Project Category", collapsible = TRUE),
box(plotlyOutput("Project_status"), width = 8,solidHeader = TRUE, status = "primary", title = "Project Status", collapsible = TRUE),
box(plotlyOutput("Complexity"), width = 4,solidHeader = TRUE, status = "primary", title = "Project Complexity", collapsible = TRUE),
box(plotlyOutput("Audits"), width = 4,solidHeader = TRUE, status = "primary", title = "Audit Status", collapsible = TRUE)
)),
tabPanel("Data",
box(withSpinner(rHandsontableOutput("Projects")), width = 12),
actionButton("saveBtnProjects", "Save Projects", icon = icon("save")),
actionButton("BtnResetProjects", "Reset Filters", icon = icon("eraser")))))
)))
server.r
shinyServer(function(input, output, session){
dt_projects <- reactive({ raw_data_projects })
vals <- reactiveValues()
output$Projects <- renderRHandsontable({
rhandsontable(dt_projects(), readOnly = FALSE, search = TRUE, selectCallback = TRUE ) %>%
hot_cols(columnSorting = TRUE, manualColumnMove = TRUE, manualColumnResize = TRUE ) %>%
hot_table(highlightRow = TRUE, highlightCol = TRUE) %>%
#hot_col("PROJECT.STATUS", renderer = text_renderer, type = "autocomplete") %>%
hot_rows(fixedRowsTop = 1)
})
# on click of button the file will be saved to the working directory
observeEvent(input$saveBtnProjects,
#write.csv(hot_to_r(input$Projects), file = "./Data/project_tracker.csv",row.names = FALSE)
saveRDS(hot_to_r(input$Projects),"Projects.rds")
)
# refresh the page
observeEvent(input$saveBtnProjects, {js$reset()})
})
So when I run the app I get the table I desire as below:
As we can see, as I was inserting values to the first column, all the other columns greyed out and I couldn't insert any values into it. Please help me with this issue.
Also please suggest if my code will display the data reactively as soon as I save the data by pressing Save Projects button.
Thanks a ton in advance!!
P.S : I have included the server code only for the table considering the length of the question leaving the code of other tabs. But still this code is reproducible.

Use string from server.R as argument in a function within ui.r

I'm using shinydashboardPlus() to include a timeline in an app I'm developing. I want each timelineItem() icon to change colour depending on whether a stage is marked as complete. When a stage is incomplete, I would like the icon to be grey. When a checkboxInput() is selected, I would like the colour to change to olive.
I have written the server-side logic such that when checkboxInput is FALSE the string 'grey' is returned but when TRUE the string 'olive' is returned. I need to pass this string to the argument color in timelineItem(). I have tried passing the string to the argument using textOutput() but this doesn't work. Any ideas how I can pass the correct colour string to color?
Here's an MRE:
library(shiny)
library(shinyWidgets)
library(shinydashboard)
library(shinydashboardPlus)
ui <- dashboardPagePlus(
header = dashboardHeaderPlus(title = "Quality & Assurance Dashboard"),
sidebar = dashboardSidebar(
),
body = dashboardBody(
fluidRow(
box(width = 9,
title = "Assurance Timeline",
status = "info",
timelineBlock(
timelineEnd(color = "danger"),
timelineLabel("Start", color = "teal"),
timelineItem(
title = "Stage 1",
icon = "gears",
color = textOutput("survey_released_colour"), # Need to paste the correct colour string here
time = "now",
footer = "",
textOutput("survey_released_colour")
)
)
),
box(width = 3,
title = "Stage Sign-Off",
status = "info",
timelineBlock(
timelineEnd(color = "danger"),
timelineLabel("Start", color = "teal"),
timelineItem(
title = "Stage 1",
icon = "gears",
color = "olive",
time = "",
footer = "",
"Check here when Stage 1 complete.",
checkboxInput(inputId = "survey_release", "Surveys Released", value = FALSE, width = NULL)
)
)
)
)
),
)
server <- function(input, output) {
output$survey_released_colour<-renderText({
if (input$survey_release == TRUE){
paste0("olive")
}
else
paste0("grey")
})
}
app<-shinyApp(ui = ui, server = server)
runApp(app, host="0.0.0.0",port=5050, launch.browser = TRUE)
from the basic rules of Shiny you can't use any server component inside ui.R. You can use an condition for changing the color in server side.
My try:
library(shinydashboardPlus)
ui <- dashboardPagePlus(
header = dashboardHeaderPlus(title = "Quality & Assurance Dashboard"),
sidebar = dashboardSidebar(
),
body = dashboardBody(
fluidRow(
box(width = 9,
title = "Assurance Timeline",
status = "info",
uiOutput("timeline")
),
box(width = 3,
title = "Stage Sign-Off",
status = "info",
checkboxInput(inputId = "survey_release", "Surveys Released", value = FALSE, width = NULL)
)
)
)
)
server <- function(input, output) {
output$timeline<-renderUI({
if (input$survey_release == TRUE)
{
timelineBlock(
timelineEnd(color = "danger"),
timelineLabel("Start", color = "teal"),
timelineItem(
title = "Stage 1",
icon = "gears",
#color = textOutput("survey_released_colour"), # Need to paste the correct colour string here
color ='red',
time = "now",
footer = ""
)
)
}
else
{
timelineBlock(
timelineEnd(color = "danger"),
timelineLabel("Start", color = "teal"),
timelineItem(
title = "Stage 1",
icon = "gears",
#color = textOutput("survey_released_colour"), # Need to paste the correct colour string here
color ="green",
time = "now",
footer = ""
)
)
}
})
}
shinyApp(ui, server)
let me know if this helps.

Create Center Navigation Bar in Shiny with Symbols

Currently, I have a shiny app built with the following UI structure.
tabsetPanel(tabPanel("Tab1"),
tabPanel("Tab2"),
tabPanel("Tab3"),
tabPanel("Tab4")
However, I would like to change the look and feel of the navigation bars. I would like to center the tabs in the middle of the page as opposed to having them left-aligned (This post is not reproducible and does not seem sustainable). Then insert a triangle in between each tab panel to show a "story line" to indicated content from tab1, 2, etc. is informing and influencing the rest of the dashboard. Then also have the tab highlighted each time the tab changes (green color below). I inserted a quick screenshot of the general UI format I am going for. I couldn't find much online of people trying to do this. Anything to put me in the right direction would be great! Much appreciated! The below is not a hard guidance or request, but just a general style.
You can mimic a layout like this using shinyWidgets::radioGroupButtons (and get reasonably close). Note that you still might need HTML/CSS customization of the buttons and arrows between them. This post might be a good resource: Create a Button with right triangle/pointer
library(shiny)
library(shinyWidgets)
ui <- fluidPage(titlePanel("Hack with shinyWidgets::radioGroupButtons"),
mainPanel(
fluidRow(
column(width = 3, "some space"),
column(
width = 9,
align = "center",
radioGroupButtons(
inputId = "item",
label = "",
status = "success",
size = "lg",
direction = "horizontal",
justified = FALSE,
width = "100%",
individual = TRUE,
checkIcon = list(
"yes" = icon("check"),
"yes" = icon("check"),
"yes" = icon("check"),
"yes" = icon("check")
),
choiceNames = as.list(names(iris)[1:4]),
choiceValues = as.list(1:4)
)
)
),
tags$hr(),
column(width = 3, "some space"),
column(
width = 9,
align = "center",
textOutput("text"),
wellPanel(dataTableOutput("out"))
)
))
server <- function(input, output) {
out_tbl <- reactive({
x <- iris[,c(5, as.numeric(input$item))]
return(x)
})
output$out <- renderDataTable({
out_tbl()
},options = list(pageLength = 5)
)
output$text <- renderText({paste("Contents for tab", input$item)})
}
shinyApp(ui, server)
A screen shot of the layout:

Align three elements on Shiny dashboard

I try to put properly three elements on my Shiny dashboard
# User interface
ui <- fluidPage(theme = shinytheme("united"),
titlePanel("Crimes in Washington, DC (2017)"),
fluidRow(column(4,
selectInput("offenceInput", "Type of Offence",
choices =
sort(unique(incidents$OFFENSE)),
selected =
sort(unique(incidents$OFFENSE)),
multiple = TRUE),
selectInput("methodInput", "Method of Offence",
choices =
sort(unique(incidents$METHOD)),
selected =
sort(unique(incidents$METHOD)),
multiple = TRUE),
selectInput("shiftInput", "Police Shift",
choices =
sort(unique(incidents$SHIFT)),
selected =
sort(unique(incidents$SHIFT)),
multiple = TRUE),
selectInput('background', 'Background',
choices = providers,
multiple = FALSE,
selected = 'Stamen.TonerLite'),
dateRangeInput('dateRange',
label = 'Date',
start = as.Date('2017-01-01') ,
end = as.Date('2017-12-31')
)
),
column(10,
dataTableOutput('my_table'),
column(12,
leafletOutput(outputId = 'map', height = 600)
)
)
))
My map goes somewhere else, I tried different options. Just need map in a proper right top corner and a table below.
Here I have put all selectInput fields in left panel, map in right panel and my_table below these two panels. Trick is that column's 1st parameter should add to 12 (i.e. 4+8 in case of top panel and 12 in case of bottom panel).
ui <- fluidPage(fluidRow(column(4,
selectInput(...),
selectInput(...),
selectInput(...),
selectInput(...),
dateRangeInput(...)),
column(8,
leafletOutput(outputId = 'map', height = 600)),
column(12,
dataTableOutput('my_table'))))
Note: I was not able to test it due to lack of reproducible example but I hope this should work in your case.
Resolved with the help of RCommunity worldwide.
# User interface
ui <- fluidPage(theme = shinytheme("united"),
titlePanel(HTML("<h1><center><font size=14> Crimes in Washington, DC (2017) </font></center></h1>")),
fluidRow(column(4, align="center",
selectInput("offenceInput", "Type of Offence",
choices = sort(unique(incidents$Offense)),
selected = sort(unique(incidents$Offense)),
multiple = TRUE),
selectInput("methodInput", "Method of Offence",
choices = sort(unique(incidents$Method)),
selected = sort(unique(incidents$Method)),
multiple = TRUE),
selectInput("shiftInput", "Police Shift",
choices = sort(unique(incidents$Shift)),
selected = sort(unique(incidents$Shift)),
multiple = TRUE),
selectInput('background', 'Background',
choices = providers,
multiple = FALSE,
selected = 'Stamen.TonerLite'),
dateRangeInput('daterangeInput',
label = 'Date',
start = as.Date('2017-01-01') , end = as.Date('2017-12-31')
),
br(),
plotOutput("bar")
),
column(8,
leafletOutput(outputId = 'map', height = 600, width = 800),
dataTableOutput('my_table')
)
))
This gives the following layout. It is messy, but the structure is what I really wanted. Will improved small tweaks.

Resources