How to apply css style to actionBttn from shinywigets in shiny - css

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)

Related

Generate dynamic Tab using argonDash (shiny framework) package

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)

trouble decreasing margin between elements in shiny app

I'm trying to reduce the margin between two elements on this shiny app. When open in a browser, the whitespace between the two is huge.
I tried setting the css by adding style = "margin:0px; padding:0px" to the UI, but it did not help. I also tried messing with the inline = TRUE settings, also no help.
ui <- fluidPage(
fluidRow(
column(width = 3,
htmlOutput("select1", inline = TRUE, style = "margin:0px; padding:0px")
),
column(width = 3,
htmlOutput("select2", inline = TRUE, style = "margin:0px; padding:0px")
),
column(width = 6)
)
)
server <- function(input, output, session) {
output$select1 <- renderUI({
pickerInput(
inputId = "select1",
label = "LETTERS",
#choices = sort(unique(inventory$SubDivision)),
choices = LETTERS,
options = list(
"actions-box" = TRUE,
size = 10,
`live-search`=TRUE
),
multiple = TRUE
)
})
output$select2 <- renderUI({
pickerInput(
inputId = "select2",
label = "letters",
#choices = sort(unique(inventory$SubDivision)),
choices = letters,
options = list(
"actions-box" = TRUE,
size = 10,
`live-search`=TRUE
),
multiple = TRUE
)
})
}
shinyApp(ui, server)
Whitespace in browser:
The issue here is not the margin or padding, but the limit of the width to 300px. To allow the control to grow to full size of the column, you can change the global style :
ui <- fluidPage(
fluidRow(
tags$head(
tags$style(HTML("
.shiny-input-container:not(.shiny-input-container-inline) {
width:100%;
}"))
),
column(width = 3,
htmlOutput("select1", inline = TRUE)
),
column(width = 3,
htmlOutput("select2", inline = TRUE)
),
column(width = 6)
)
)

How to fix the layout of semantic.dashboard?

I am trying to build a dashboard using semantic.dashboard library. I see that all the components are aligned at the center. How can I change the layout?
I have taken the following code from examples in the semantic.dashboard repo. It works absolutely fine when I run it. I see that there is a space between the sidebar menu and boxes in the main body. I want the components to be aligned without any space from the side bar menu. Is there any way I could achieve this?
library(shiny)
library(shiny.semantic)
library(semantic.dashboard)
library(ggplot2)
library(plotly)
library(DT)
ui <- dashboardPage(
dashboardHeader(
dropdownMenuOutput("dropdown"),
dropdownMenu(type = "notifications",
taskItem("Project progress...", 50.777, color = "red")),
dropdownMenu(
icon = uiicon("red warning sign"),
notificationItem("This is an important notification!", color = "red")
)
),
dashboardSidebar(side = "left",
sidebarMenu(
menuItem(
tabName = "plot_tab",
text = "My plot",
icon = icon("home")
),
menuItem(
tabName = "table_tab",
text = "My table",
icon = icon("smile")
)
)),
dashboardBody(tabItems(
tabItem(tabName = "plot_tab",
fluidRow(
valueBox(
"Unread Mail",
44,
icon("mail"),
color = "blue",
width = 5
)
),
fluidRow(
box(
title = "Sample box",
color = "blue",
width = 11,
selectInput(
inputId = "variable1",
choices = names(mtcars),
label = "Select first variable",
selected = "mpg"
),
selectInput(
inputId = "variable2",
choices = names(mtcars),
label = "Select second variable",
selected = "cyl"
),
plotlyOutput("mtcars_plot")
),
tabBox(
title = "Sample box",
color = "blue",
width = 5,
collapsible = FALSE,
tabs = list(
list(menu = "First Tab", content = "Some text..."),
list(menu = "Second Tab", content = plotlyOutput("mtcars_plot2"))
)
)
)),
tabItem(
tabName = "table_tab",
fluidRow(
valueBox(
"Unread Mail",
144,
icon("mail"),
color = "blue",
width = 6,
size = "small"
),
valueBox(
"Spam",
20,
icon("mail"),
color = "red",
width = 5,
size = "small"
),
valueBox(
"Readed Mail",
666,
icon("mail"),
color = "green",
width = 5,
size = "small"
)
),
fluidRow(
box(
title = "Classic box",
color = "blue",
ribbon = FALSE,
title_side = "top left",
width = 14,
tags$div(
dataTableOutput("mtcars_table")
,
style = paste0("color:", semantic_palette[["blue"]], ";")
)
)
)
)
)),
theme = "slate"
)
server <- function(input, output) {
output$mtcars_plot <-
renderPlotly(plot_ly(
mtcars,
x = ~ mtcars[, input$variable1],
y = ~ mtcars[, input$variable2],
type = "scatter",
mode = "markers"
))
output$mtcars_plot2 <-
renderPlotly(plot_ly(
mtcars,
x = ~ mtcars[, input$variable1],
y = ~ mtcars[, input$variable2],
type = "scatter",
mode = "markers"
))
output$mtcars_table <-
renderDataTable(mtcars, options = list(dom = 't'))
output$dropdown <- renderDropdownMenu({
dropdownMenu(
messageItem("User", "Test message", color = "teal", style = "min-width: 200px"),
messageItem("Users", "Test message", color = "teal", icon = "users"),
messageItem(
"See this",
"Another test",
icon = "warning",
color = "red"
)
)
})
}
shinyApp(ui, server)
It looks like the issue is behind the dashboardBody function. It uses a ui stackable container grid for each tab which is causing the large amount of padding.
There are two ways around it:
Hack around the dashboardBody function and remove "container" from the class:
dash_body <- function (...) {
shiny::div(
class = "pusher container", style = "min-height: 100vh;",
shiny::div(
class = "ui segment", style = "min-height: 100vh;",
shiny::tags$div(class = "ui stackable grid", ...)
),
semantic.dashboard:::body_js
)
}
Add CSS to remove the padding for this class (add first row in the dashboardBody arguments):
tags$style(".pusher.container .ui.segment .ui.stackable.container.grid {margin:0px!important;}")

Using Conditional Panel with PickerInput in R

In the given R shiny script below, I am trying to use a conditional panel with Picker Input shiny widget. There are three options in pickerInput, upon selection of "times" option, I wish to create new pickerInputs using a conditional panel, the following is possible using selectInput, but I need the same for Picker Input. Thanks and please help.
library(shiny)
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(title = "Picket",titleWidth = 290),
dashboardSidebar(width = 0),
dashboardBody(
tabsetPanel(type = "tab",
tabPanel("Overview", value = 1,
box(
column(1,
dropdown(
pickerInput(inputId = "resources",
label = "",
choices = c("cases",
"activities",
"times"),
choicesOpt = list(icon = c("fa fa-bars",
"fa fa-bars",
"fa fa-safari")),
options = list(`icon-base` = "")),
circle = FALSE, status = "primary", icon = icon("list", lib = "glyphicon"), width = "300px"
),
conditionalPanel(
condition = "input.Position == 'times' ",
dropdown(
pickerInput(inputId = "Id072",
label = "Select/deselect all options",
choices = c("A","Check-out", "b","c","d","e","f")
)))))),
id= "tabselected"
)
))
server <- function(input, output) {
}
shinyApp(ui, server)
Shouldnt this condition = "input.Position == 'times' ", be condition = "input.resources == 'times' ",?

R Shiny dropdownButton reactive size?

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"))
)
)

Resources