R Shiny dropdownButton reactive size? - css

I'm using the dropdownButton from this link that is in Shiny Widgets, with a slight mod to make the text black. drop-down checkbox input in shiny
My goal is to make the dropdownButton in my sidebar look as much like a selectInput feature as possible. I got the button to be the same size as the the selectInput, and the caret to be placed correctly, thanks to help on another post, but when I change the window size, I run into UI overlap issues.
Any suggestions? See my issue below:
Both are screenshots of the same app from the same code, just different window sizes. I'd like the dropdownButton to stay consistent in matching its size to the selectInput above. I also don't understand why my h5("Filter 2:) text splits with the larger window size, and I don't want it to do that.
library(shiny)
library(shinydashboard)
dropdownButton2 <- function(label = "", status = c("default", "primary", "success", "info", "warning", "danger"), ..., width = NULL) {
status <- match.arg(status)
# dropdown button content
html_ul <- list(
class = "dropdown-menu",
style = if (!is.null(width))
paste0("width: ", validateCssUnit(width), ";"),
lapply(X = list(...), FUN = tags$li, style = "margin-left: 10px; margin-right: 10px;color:black")
)
# dropdown button apparence
html_button <- list(
class = paste0("btn btn-", status," dropdown-toggle"),
type = "button",
`data-toggle` = "dropdown"
)
html_button <- c(html_button, list(label))
html_button <- c(html_button, list(tags$span(class = "caret")))
# final result
tags$div(
class = "dropdown",
do.call(tags$button, html_button),
do.call(tags$ul, html_ul),
tags$script(
"$('.dropdown-menu').click(function(e) {
e.stopPropagation();
});")
)
}
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(width = 325,
selectInput('month',label='Filter 1:',choices= month.name,multiple = FALSE,selected = "March"),
br(),
column(1,
h5(strong(("Filter 2:"))),
tags$style(type = 'text/css', ".btn-default{width: 100%;}"),
tags$style(type = 'text/css', ".btn .caret{position: relative;}"),
tags$style(type = 'text/css', ".caret{top: 45%; right:-35%}"),
dropdownButton2(
label = "Filter 2:", status = "default", width = 200,#circle = FALSE,
checkboxGroupInput(inputId = "check1", label = "Choose", choices = c("A","B","C"))
),
h5(strong(("Filter 3:"))),
dropdownButton2(
label = "Filter 3:", status = "default", width = 200,#circle = FALSE,
checkboxGroupInput(inputId = "check3", label = "Choose", choices = c("A","B","C"))
)
)),
dashboardBody()
)
server <- function(input, output){
}
shinyApp(ui = ui, server = server)

#SarahGC - The column you have defined in your code has width = 1 which is being used to display dropdownbuttons. By just changing that value, both your problems will get solved (text wont split on the label, and width of buttons will not be restricted). Please note width must be between 1 and 12.
column(11,
h5(strong("Filter 2:")),
tags$style(type = 'text/css', ".btn-default{width: 100%;}"),
tags$style(type = 'text/css', ".btn .caret{position: relative;}"),
tags$style(type = 'text/css', ".caret{top: 45%; right:-35%}"),
dropdownButton2(
label = "Filter 2:", status = "default",width = 100,#circle = FALSE,
checkboxGroupInput(inputId = "check1", label = "Choose", choices = c("A","B","C"))
),
h5(strong("Filter 3:")),
dropdownButton2(
label = "Filter 3:", status = "default",width = 100,#circle = FALSE,
checkboxGroupInput(inputId = "check3", label = "Choose", choices = c("A","B","C"))
)
)

Related

Reactivity and Renders doesn't work when switching to another tabPanel

I have a reproducible example below where only the first tabPanel is working, however when I switch to another panel, I don't get any renders (the toggle becomes un-interactable also). I have looked into conditionalPanel however I see them getting done without the use of mainPanel I was wondering if it possible to have tabs where each tab has its own mainPanel , so I can see a different sidebar and an output contained within different tabs. Any help is welcome!
options(scipen = 99999) #converts the sci numbers to their regular format
library(shiny)
library(shinyjs)
library(shinyWidgets)
library(shinyalert)
library(esquisse)
library(DT)
library(dplyr)
#library(devtools)
#library(remotes)
#remotes::install_github("dreamRs/esquisse")
library(hrbrthemes)
library(ggthemes)
library(ggplot2)
library(svglite)
ui <- fluidPage(
shinyjs::useShinyjs(), # enables javascript/jQuery enhanchments
# Create Right Side Text
navbarPage(
title= div(HTML("G<em>T</em>")),
#General reports
tabPanel("General Reports",
shinyWidgets::materialSwitch(inputId = "toggleSidebar", label = "Toggle Panel: ",
value = TRUE, status = "warning"),
sidebarLayout(
# radio/action buttons
sidebarPanel(
id = "Sidebar",
shinyWidgets::prettyRadioButtons(
inputId = "controller",
label = "Choose:",
choices = c("About"= 1,
"iris"= 2),
icon= icon("check"),
selected = 1,
status = "success",
animation="smooth"
),
br(),
br(),
a(actionButton(inputId = "admin_email", label = "Contact",
icon = icon("envelope", lib = "font-awesome")),
href="mailto:xyz#email.us")
),
#panel where output is shown from server
mainPanel(
id = "main_panel",
tabsetPanel(
id = "hidden_tabs",
type = "hidden",
tabPanelBody(
"panel1", "Text coming soon."
),
tabPanelBody(
"panel2",
tabsetPanel(
tabPanel("Data", DT::DTOutput('panel2_data')),
tabPanel(
"DIY Plot",
esquisse::esquisse_ui(
id = "esquisse2",
header = FALSE,
container = esquisseContainer(
width = "100%", height = "760px", fixed = FALSE
),
controls = c("labs", "parameters", "appearance", "filters", "code")
)
)
)
)
)
)
)
),
# monthly reports
tabPanel("Extra General Reports",
shinyWidgets::materialSwitch(inputId = "toggleSidebar", label = "Toggle Panel: ",
value = TRUE, status = "warning"),
sidebarLayout(
# radio/action buttons
sidebarPanel(
id = "Sidebar",
shinyWidgets::prettyRadioButtons(
inputId = "controller",
label = "Choose:",
choices = c("About"= 3,
"mtcars"= 4),
icon= icon("check"),
selected = 3,
status = "success",
animation="smooth"
),
br(),
br(),
a(actionButton(inputId = "admin_email", label = "Contact",
icon = icon("envelope", lib = "font-awesome")),
href="mailto:xyz#email.us")
),
#panel where output is shown from server
mainPanel(
id = "main_panel",
tabsetPanel(
id = "hidden_tabs",
type = "hidden",
tabPanelBody(
"panel3", "Text coming soon."
),
tabPanelBody(
"panel4",
tabsetPanel(
tabPanel("Data", DT::DTOutput('panel4_data')),
tabPanel(
"DIY Plot",
esquisse::esquisse_ui(
id = "esquisse4",
header = FALSE,
container = esquisseContainer(
width = "100%", height = "760px", fixed = FALSE
),
controls = c("labs", "parameters", "appearance", "filters", "code")
)
)
)
)
)
)
)
),
#resizes the navbar tabs/button
tags$head(tags$style(HTML('.navbar-brand {width: 270px; font-size:35px; text-align:left;
font-family: "serif";')))
)
)
server <- function(input, output, session) {
# this event hides the side panel when toggled on/off
observeEvent(input$toggleSidebar, {
shinyjs::toggle(id = "Sidebar", condition = input$toggleSidebar)
if(!isTRUE(input$toggleSidebar)) {
shinyjs::runjs("$('#main_panel').removeClass('col-sm-8').addClass('col-sm-12')")
} else {
shinyjs::runjs("$('#main_panel').removeClass('col-sm-12').addClass('col-sm-8')")
}
})
# here we put all the data
data_sets <- list(df1 = data.frame(),
df2 = iris,
df3 = data.frame(),
df4 = mtcars)
# store current dataset in reactive so we can work with plot panels
data_to_use <- reactiveValues(name = "df", data = data.frame())
# modules only need to be called it once but individually for esquisse
esquisse::esquisse_server(id = "esquisse2", data_rv = data_to_use)
esquisse::esquisse_server(id = "esquisse4", data_rv = data_to_use)
observeEvent(input$controller, {
# skip first panel since it is used to display navigation
updateTabsetPanel(session, inputId= "hidden_tabs", selected = paste0("panel", input$controller))
# enswure value is avilable throught selected tabSet
req(input$controller)
# get current data and df name
data_to_use$data <- data_sets[[as.numeric(input$controller)]]
data_to_use$name <- names(data_sets[as.numeric(input$controller)])
# update table and sum. Use server = FALSE to get full table
output[[paste0('panel', input$controller, '_data')]] <- DT::renderDT(server = FALSE, {
DT::datatable(data_to_use$data,
filter = 'top',
extensions = 'Buttons')})
})
}
#runs the app
shinyApp(ui= ui, server= server)
You have two radioButtons, one for each sidebar, but both of them have the inputId = "controller". Same with inputId = "toggleSidebar". InputIds need to be unique in shiny!
I suggest you either use a single sidebar for the entire app, or since both tabs are essentially identical you can also use modules.

R shiny: slickROutput disappears when switching tabpanel()

I am making a Shiny app with tabPanels embedded in a navbarPage.
In each tabPanel, I generate a serie of image. When switching from one panel to the other one, the image loaded in one of them disappear.
I have to "refresh" manually the page to see it again. The problem seems similar than the one posted here but I cannot really subset my tabPanels, even though I gave $id and value to them.
Here is a reproducible example:
library(shiny)
library(shinythemes)
library(slickR)
## ui ----
# Image list
imgs <- list(
stackoverflow =
"https://upload.wikimedia.org/wikipedia/fr/9/95/Stack_Overflow_website_logo.png",
stackexchange =
"https://upload.wikimedia.org/wikipedia/commons/6/6f/Stack_Exchange_Logo.png"
)
ui <- navbarPage(title = div(
HTML('<span style="font-size:180%;color:white;font-weight:bold;"> Navbarpage</span></a>'),
tags$style(style = 'position:absolute; right:42px;'),
tags$style(HTML("#panel1{font-size: 25px}")),
tags$style(HTML("#panel2{font-size: 25px}")),
tags$style(HTML("#panel_about{font-size: 25px}"))
),
theme = shinytheme("flatly"),
windowTitle = "Navbarpage",
id = "navbar",
## First tabpanel ----
tabPanel(h1(id = "panel1", "Panel 1"), value = 1, fluid = TRUE,
fluidRow(column(4,
selectInput("img_list", "Image list",
choices = imgs,
selected = imgs[1])),
column(8,
slickROutput("plot_panel1"))),
),
tabPanel(h1(id = "panel2", "Panel 2"), value = 2, fluid = TRUE,
fluidRow(column(4,
selectInput("img_list", "Image list",
choices = imgs,
selected = imgs[1])),
column(8,
slickROutput("plot_panel2"))),
)
) # closes navbarpage
## server ----
server <- function(input, output, session){
observe({
output$plot_panel1 <- renderSlickR({
slick1 <- slick_list(slick_div(
input$img_list,
css = htmltools::css(width = "100%", margin.left = "auto",
margin.right = "auto"),
type = "img", links = NULL))
slickR(slick1)
})
})
observe({
output$plot_panel2 <- renderSlickR({
slick2 <- slick_list(slick_div(
input$img_list,
css = htmltools::css(width = "100%", margin.left = "auto",
margin.right = "auto"),
type = "img", links = NULL))
slickR(slick2)
})
})
}
shinyApp(ui, server)
And what it produces:
When there are multiple slickR objects to be rendered, you need to use a unique slideId for each. Furthermore you should not wrap render* functions in observe and use the same id for two selectInputs.
Please check the following:
library(shiny)
library(shinythemes)
library(slickR)
## ui ----
# Image list
imgs <- list(
stackoverflow =
"https://upload.wikimedia.org/wikipedia/fr/9/95/Stack_Overflow_website_logo.png",
stackexchange =
"https://upload.wikimedia.org/wikipedia/commons/6/6f/Stack_Exchange_Logo.png"
)
ui <- navbarPage(title = div(
HTML('<span style="font-size:180%;color:white;font-weight:bold;"> Navbarpage</span></a>'),
tags$style(style = 'position:absolute; right:42px;'),
tags$style(HTML("#panel1{font-size: 25px}")),
tags$style(HTML("#panel2{font-size: 25px}")),
tags$style(HTML("#panel_about{font-size: 25px}"))
),
theme = shinytheme("flatly"),
windowTitle = "Navbarpage",
id = "navbar",
## First tabpanel ----
tabPanel(h1(id = "panel1", "Panel 1"), value = 1, fluid = TRUE,
fluidRow(column(4,
selectInput("img_list1", "Image list",
choices = imgs,
selected = imgs[1])),
column(8,
slickROutput("plot_panel1"))),
),
tabPanel(h1(id = "panel2", "Panel 2"), value = 2, fluid = TRUE,
fluidRow(column(4,
selectInput("img_list2", "Image list",
choices = imgs,
selected = imgs[1])),
column(8,
slickROutput("plot_panel2"))),
)
) # closes navbarpage
## server ----
server <- function(input, output, session){
output$plot_panel1 <- renderSlickR({
slick1 <- slick_list(slick_div(
input$img_list1,
css = htmltools::css(width = "100%", margin.left = "auto",
margin.right = "auto"),
type = "img", links = NULL))
slickR(slick1, slideId = "slide1")
})
output$plot_panel2 <- renderSlickR({
slick2 <- slick_list(slick_div(
input$img_list2,
css = htmltools::css(width = "100%", margin.left = "auto",
margin.right = "auto"),
type = "img", links = NULL))
slickR(slick2, slideId = "slide2")
})
}
shinyApp(ui, server)

How to apply css style to actionBttn from shinywigets in shiny

I have an example shiny app as below. In order to the actionButton with selectInput, I need to add style='margin-top:25px'. Shinywidgets package has actionBttn widgets with some built-in style. For example, I like the one with style='gradient'. But I wonder how I can use css style to add margin on the top to align the actionBttn with other element?
library(shiny)
library(shinydashboard)
library(shinyWidgets)
ui <- dashboardPage(
dashboardHeader(title = "example"),
dashboardSidebar(),
dashboardBody(
box(width=12,
column(width = 3, dateRangeInput("dateRange", "Date Range",
start = "2017-01-01",
end = Sys.Date(),
min = "2001-01-01",
max = Sys.Date(),
format = "mm/dd/yy",
separator = " - ") ),
column(width=3, selectizeInput(inputId = 'var',
label='Select variable',
choices = c('cut', 'color'),
multiple=FALSE,
options = list(
maxItems = 1,
placeholder = '',
onInitialize = I("function() { this.setValue(''); }"))) ),
column(width=1, offset =2, actionButton('Apply', 'Apply', style='margin-top:25px') ),
column(width=3, actionBttn(
inputId = 'clear',
label = "Clear",
style = "gradient",
color = "danger" ) )
)
)
)
server <- function(input, output, session) {
}
shinyApp(ui, server)
Hard to say with out your .css but You can find a sample in here
To add a style to an existing element created by a package, sometimes you have to wrap that element. Here's three approaches:
Wrap the element itself in a div with the style you want. May not work for all CSS elements.
Write your own custom function using the source from your desired element. Here I used the source from https://github.com/dreamRs/shinyWidgets/blob/ac8134e944f91fdcc4490ace6d839c46e7df02ff/R/actionBttn.R#L63
Add in some external CSS that targets only that element. This is my least favored approach because it moves the logic away from where it's actually being applied, and you have to keep track of it for each element you want to modify.
library(shiny)
library(shinyWidgets)
# new function for approach #2
actionBttn_with_style <- function(inputId, label = NULL, icon = NULL, style = "unite",
color = "default", size = "md", block = FALSE,
no_outline = TRUE, my_additional_style = "") {
value <- shiny::restoreInput(id = inputId, default = NULL)
style <- match.arg(
arg = style,
choices = c("simple", "bordered", "minimal", "stretch", "jelly",
"gradient", "fill", "material-circle", "material-flat",
"pill", "float", "unite")
)
color <- match.arg(
arg = color,
choices = c("default", "primary", "warning", "danger", "success", "royal")
)
size <- match.arg(arg = size, choices = c("xs", "sm", "md", "lg"))
tagBttn <- htmltools::tags$button(
id = inputId, type = "button", class = "action-button bttn", `data-val` = value,
class = paste0("bttn-", style),
class = paste0("bttn-", size),
class = paste0("bttn-", color), list(icon, label),
class = if (block) "bttn-block",
class = if (no_outline) "bttn-no-outline",
style = my_additional_style
)
shinyWidgets:::attachShinyWidgetsDep(tagBttn, "bttn")
}
After you make your custom button function, you can use it just like actionBttn inside your ui.
ui <- dashboardPage(
dashboardHeader(
title = "example"
),
dashboardSidebar(),
dashboardBody(
# for approach #3, but this is far away from the button in the code
htmltools::tags$head(
htmltools::tags$style('button#clear_ext_css { margin-top:25px }')
),
box(
width = 12,
column(
width = 2,
dateRangeInput(
"dateRange",
"Date Range",
start = "2017-01-01",
end = Sys.Date(),
min = "2001-01-01",
max = Sys.Date(),
format = "mm/dd/yy",
separator = " - "
)
),
column(
width = 1,
actionButton('Apply', 'Apply', style = 'margin-top:25px')
),
column(
width = 3,
# approach #1, just wrapping it in a styled div
div(
actionBttn(
inputId = 'clear_div',
label = "Clear with div",
style = "gradient",
color = "danger"
),
style = 'margin-top:25px'
)
),
column(
width = 3,
# approach #2, custom function from above
actionBttn_with_style(
inputId = 'clear_fn',
label = "Clear with custom function",
style = "gradient",
color = "danger",
my_additional_style = 'margin-top:25px'
)
),
column(
width = 3,
# approach #3, but you don't see any custom logic here
actionBttn(
inputId = 'clear_ext_css',
label = "Clear with external CSS",
style = "gradient",
color = "danger"
)
)
)
)
)
server <- function(input, output, session) {
}
shinyApp(ui, server)

Show/Hide entire box content with RadioButton Shiny

I have 3 boxes in the dashboard body. When radioButton in selected to "P3G", box1 and box3 should appear i.e hide box2. When radiobutton is selected to "Chose File", box2 and box3 should appear. I have the below code using shinyjs but it is not working as required i.e. not hiding complete box contents as coded in observeEvent. Any help?
sidebar <- dashboardSidebar(width=200,
sidebarMenu(id="tabs",
menuItem("Input File", tabName =
"tab1",icon = icon("fas fa-file"))))
body <- tabItem(tabName = "tab1",value="file_nput",h2("Select file"),
fluidRow(useShinyjs(),
radioButtons("file_rd",label= "Chose Dataset:",
choices = list("P3G","Chose File"),selected = "P3G"),
box( id ="box1",title = "Default Sample", width = 7, status = "info",
tabPanel("Sample Info",value="p3_samples",
DT::dataTableOutput("p3_table"))),
box(id= "box2", title = "Uploaded Sample", width = 7, status = "info",
tabsetPanel(id = "sam_tab",
tabPanel("Upload", value="upload_file",
fileInput(inputId ="FILE",label = "Upload file",multiple=FALSE,
accept = c(".txt")),
checkboxInput('header', label = 'Header', TRUE),
actionButton("createdb","Create DB")),
tabPanel("File Info",value="samples",tableOutput("summary"),icon = icon("info"),
DT::dataTableOutput("full_table"),actionButton("upload","Proceed")))),
box(id = "box3" ,status = "info", width = 5,
tabBox(id = "infobox", height = "100%", width = "100%",
tabPanel("Instructions",h4("Instructions for uploading valid input file"))))))
ui<- shinyUI(dashboardPage(dashboardHeader(title = "TestApp", titleWidth = 150),sidebar,dashboardBody(tabItems(body))))
server <- function(input, output, session) {
observeEvent(input$file_rd, {
if (input$file_rd == "P3G") {
shinyjs::hide(id = "box2", anim=TRUE)
}else {
shinyjs::hide(id = "box1",anim=TRUE)
}
})
}
shinyApp(ui=ui, server=server)
You can simply use
conditionalPanel()
so conditionalPanel for box1 will be like this:
conditionalPanel('input.file_rd === "P3G"', box(id = 'box1', ...)
and for box2 and box3:
conditionalPanel('input.file_rd != "P3G"', box(id = 'box2', ...), box(id = 'box3', ...)

dropdownButton alignment within dashboardSidebar

I'm using the dropdownButton function from this link drop-down checkbox input in shiny that is in shinyWidgets, with a slight modification so that the text is black.
I want the dropdownButton to look like the selectInput drop down I have above it as much as possible. I got them to line up in the sidebar with column(1,) function, but I also want the width of the dropdownButton to be the same width as the selectInput.
I also got the width of the dropdown choices to be the same width of the selectInput above it with width=200, but I want the dropdown button to also be the same size.
Can someone help me modify the dropDownButton function or my UI so that this is the case?
library(shiny)
library(shinydashboard)
dropdownButton2 <- function(label = "", status = c("default", "primary", "success", "info", "warning", "danger"), ..., width = NULL) {
status <- match.arg(status)
# dropdown button content
html_ul <- list(
class = "dropdown-menu",
style = if (!is.null(width))
paste0("width: ", validateCssUnit(width), ";"),
lapply(X = list(...), FUN = tags$li, style = "margin-left: 10px; margin-right: 10px;color:black")
)
# dropdown button apparence
html_button <- list(
class = paste0("btn btn-", status," dropdown-toggle"),
type = "button",
` data-toggle` = "dropdown"
)
html_button <- c(html_button, list(label))
html_button <- c(html_button, list(tags$span(class = "caret")))
# final result
tags$div(
class = "dropdown",
do.call(tags$button, html_button),
do.call(tags$ul, html_ul),
tags$script(
"$('.dropdown-menu').click(function(e) {
e.stopPropagation();
});")
)
}
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(width = 325,
selectInput('month',label='Filter 1:',choices= month.name,multiple = FALSE,selected = "March"),
br(),
column(1,
h5(strong(("Filter 2:"))),
dropdownButton2(
label = "Filter 2:", status = "default", width = 200,#circle = FALSE,
checkboxGroupInput(inputId = "check1", label = "Choose", choices = c("A","B","C"))
)
)),
dashboardBody()
)
server <- function(input, output){
}
shinyApp(ui = ui, server = server)
You can do so by adding the css tag tags$style(type = 'text/css', ".btn-default{width: 275px;}") in your ui code as below:
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(width = 325,
selectInput('month',label='Filter 1:',choices= month.name,multiple = FALSE,selected = "March"),
br(),
column(1,
h5(strong(("Filter 2:"))),
tags$style(type = 'text/css', ".btn-default{width: 275px;}"),
dropdownButton2(
label = "Filter 2:", status = "default", width = 200,#circle = FALSE,
checkboxGroupInput(inputId = "check1", label = "Choose", choices = c("A","B","C"))
)
)),
dashboardBody()
)
On adding the tag you get something like this:
[EDIT]:
I later realized that the caret was not right aligned as in the case of selectInput hence to align that I further added couple of css tags as follows:
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(width = 325,
selectInput('month',label='Filter 1:',choices= month.name,multiple = FALSE,selected = "March"),
br(),
column(1,
h5(strong(("Filter 2:"))),
tags$style(type = 'text/css', ".btn-default{width: 275px;}"),
tags$style(type = 'text/css', ".btn .caret{position: relative;}"),
tags$style(type = 'text/css', ".caret{top: 45%; right:-35%}"),
dropdownButton2(
label = "Filter 2:", status = "default", width = 200,#circle = FALSE,
checkboxGroupInput(inputId = "check1", label = "Choose", choices = c("A","B","C"))
)
)),
dashboardBody()
)
The additional tags resulted the caret to be aligned as follows:

Resources