I recently discovered flipbox, an excellent UI on shinydashboardPlus(version 2.0.0). I want to insert numericinput in the front, but every time I click the input, it flips. Is it possible to make the flip executed only on the actionbutton?
example img
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
shinyApp(
ui = dashboardPage(
dashboardHeader(),
dashboardSidebar(),
dashboardBody(
fluidRow(
column(
width = 12,
uiOutput("active_side"),
actionButton("toggle", "Toggle flip box"),
flipBox(
id = "myflipbox",
trigger = "click",
width = 12,
front = div(
class = "text-center",
h1("Flip on click"),
numericInput("obs", "Observations:", 10, min = 1, max = 100)
),
back = div(
class = "text-center",
height = "300px",
width = "100%",
h1("Flip on hover"),
p("More information....")
)
)
)
)
)
),
server = function(input, output, session) {
observeEvent(input$toggle, {
updateFlipBox("myflipbox")
})
}
)
Related
I have the following code to build a Shinydashboard app. I'm trying to change the background color in the box on the top of my screen to a custom color (a color hex code color), however the options for the argument background only allow for a set of default colors. Is there a way to change the background color of this box specifically while keeping the white background for the remainder of my boxes?
library(shiny)
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(title = 'Dashboard'),
dashboardSidebar(sidebarMenu
(menuItem(tabName = 'Panel1', text = 'Panel 1'),
dateInput("Start_Date", "Start Date", min = '2000-01-01', max = Sys.Date(), value = '2020-01-01',format = "yyyy-mm-dd")
)
),
dashboardBody(
tabItems(tabItem(tabName = 'Panel1',
fluidRow(box(selectizeInput('select_mean', 'Select Number',
choices = c(12,24,36,48,60,120)),height=80,width=4,
background = 'black')),
fluidRow(box(width = 13, height = 655))
)
)
)
)
server <- function(input, output) {
}
shinyApp(ui, server)
You can use htmltools::tagQuery to add a style:
library(htmltools)
library(shinydashboard)
library(shiny)
b <- box(selectInput("id", "label", c("a", "b", "c")))
b <- tagQuery(b)$find(".box")$addAttrs(style = "background-color: pink;")$allTags()
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(),
dashboardBody(b)
)
server <- function(input, output, session) {}
shinyApp(ui, server)
You can do the following steps :
put your box into a tags$div and give it an ID (here : "toto")
add some CSS to the box, which is two div childs after your div toto
You can also put the CSS in a separate file, see https://shiny.rstudio.com/articles/css.html
library(shiny)
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(title = 'Dashboard'),
dashboardSidebar(sidebarMenu
(menuItem(tabName = 'Panel1', text = 'Panel 1'),
dateInput("Start_Date", "Start Date", min = '2000-01-01', max = Sys.Date(), value = '2020-01-01',format = "yyyy-mm-dd")
)
),
dashboardBody(
tags$head(
tags$style(HTML("
#toto > div:nth-child(1) > div:nth-child(1) {
background-color: rgb(128, 0, 0);
}"))),
tabItems(tabItem(tabName = 'Panel1',
fluidRow(
tags$div(
id = "toto",
box(selectizeInput('select_mean', 'Select Number',
choices = c(12,24,36,48,60,120)),height=80,width=4)
)
),
fluidRow(box(width = 13, height = 655))
)
)
)
)
server <- function(input, output) {
}
shinyApp(ui, server)
I am trying to change the color tone of the login page from the shinymanager package.
I have seen these posts:
Change Text and Colors in Shinymanager Login Page
Change the color tone of a shinytheme
How to style shimymanager login screen with CSS only?
How to modify the themes of shinythemes?
However, since I don't know much about CSS, I am struggling with this.
This is a reproducible example:
library(shiny)
library(shinydashboard)
library(shinyWidgets)
library(shinymanager)
credentials <- data.frame(
user = c("shiny"),
password = c("shiny"),
stringsAsFactors = FALSE
)
css <- HTML(" body {
background-color: #0dc5c1;
}")
ui <- dashboardPage(
dashboardHeader(title = "Dashboard"),
## Sidebar content
dashboardSidebar(
sidebarMenu(
menuItem("App1", tabName = "App1", icon = icon("th"))
)
),
dashboardBody(
fluidRow(
tabItems(
tabItem(tabName = "App1",
sidebarPanel(
numericInput("num",
"Select a number",
min = 1,
value = 10),
sliderInput("slider1",
"Number of bins:",
min = 1,
max = 50,
value = 30),
checkboxInput("remove", "Remove...", value = FALSE),
),
mainPanel(
verbatimTextOutput("value"),
plotOutput("plot1"),
)
)
)
)
)
)
ui <- secure_app(ui,
# changing theme for the credentials
theme = shinythemes::shinytheme("united"),
tags_top = tags$div(
tags$head(tags$style(css)),
tags$img(
src = "https://marketplace.egi.eu/101-large_default/the-r-project-for-statistical-computing.jpg", width = 200, height = 200, alt="Logo not found", deleteFile=FALSE
))
)
server <- function(input, output, session) {
res_auth <- secure_server(
check_credentials = check_credentials(credentials)
)
}
shinyApp(ui, server)
My objective is to change the colour of the login page to the following tone #0dc5c1, in particular the border and the button of the page.
I tried adding:
css <- HTML(" body {
background-color: #0dc5c1;
}")
But it doesn't work.
Does anyone know how to solve it?
Thanks very much in advance
Please check the following:
library(shiny)
library(shinydashboard)
library(shinyWidgets)
library(shinymanager)
credentials <- data.frame(
user = c("shiny"),
password = c("shiny"),
stringsAsFactors = FALSE
)
css <- HTML(".btn-primary {
color: #ffffff;
background-color: #0dc5c1;
border-color: #0dc5c1;
}
.panel-primary {
border-color: #0dc5c1;
}")
ui <- dashboardPage(
dashboardHeader(title = "Dashboard"),
## Sidebar content
dashboardSidebar(
sidebarMenu(
menuItem("App1", tabName = "App1", icon = icon("th"))
)
),
dashboardBody(
fluidRow(
tabItems(
tabItem(tabName = "App1",
sidebarPanel(
numericInput("num",
"Select a number",
min = 1,
value = 10),
sliderInput("slider1",
"Number of bins:",
min = 1,
max = 50,
value = 30),
checkboxInput("remove", "Remove...", value = FALSE),
),
mainPanel(
verbatimTextOutput("value"),
plotOutput("plot1"),
)
)
)
)
)
)
ui <- secure_app(ui,
# changing theme for the credentials
theme = shinythemes::shinytheme("united"),
tags_top = tags$div(
tags$head(tags$style(css)),
tags$img(
src = "https://marketplace.egi.eu/101-large_default/the-r-project-for-statistical-computing.jpg", width = 200, height = 200, alt="Logo not found", deleteFile=FALSE
))
)
server <- function(input, output, session) {
res_auth <- secure_server(
check_credentials = check_credentials(credentials)
)
}
shinyApp(ui, server)
I modified the CSS.
ui <- secure_app(ui,
# changing theme for the credentials
theme = shinythemes::shinytheme("united"),
tags_top = tags$div(
tags$head(
tags$style(
".row {
background-color: #0dc5c1;"
),
tags$style(
".panel-body {
background-color: #0dc5c1;"
),
tags$style(
".panel-auth {
background-color: #0dc5c1;"
)
),
tags$img(
src = "https://marketplace.egi.eu/101-large_default/the-r-project-for-statistical-computing.jpg", width = 200, height = 200, alt="Logo not found", deleteFile=FALSE
))
)
I am not sure where exactly the background color should be changed. If it's too much, just remove some of the CSS.
Is there a way of aligning a widget inside a shinydashboard box? For example, in the following app:
library(shiny)
library(shinydashboard)
library(shinyWidgets)
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(),
dashboardBody(box(
title = "Test", width = 4, solidHeader = TRUE, status = "primary",
dropdownButton(
inputId = "mydropdown",
label = "Controls",
icon = icon("sliders"),
status = "primary",
circle = FALSE,
numericInput("obs", "Observations:", 10, min = 1, max = 100)
),
plotOutput('plot')
))
)
server <- function(input, output) {
output$plot <- renderPlot({
hist(runif(input$obs))
})
}
shinyApp(ui, server)
I would like to align the dropdownButton widget to the bottom right corner of the Test box. How can I do that?
Just put the dropdownButton after the plot and inside a div with a class "pull-right"
library(shiny)
library(shinydashboard)
library(shinyWidgets)
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(),
dashboardBody(box(
title = "Test", width = 4, solidHeader = TRUE, status = "primary",
plotOutput('plot'),
div(class = "pull-right",
dropdownButton(
inputId = "mydropdown",
label = "Controls",
icon = icon("sliders"),
status = "primary",
circle = FALSE,
numericInput("obs", "Observations:", 10, min = 1, max = 100)
)
)
))
)
server <- function(input, output) {
output$plot <- renderPlot({
hist(runif(input$obs))
})
}
shinyApp(ui, server)
I am trying to build a shiny app where the user can decide how many tabs he wants to be shown. Here's what I have so far:
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
library(glue)
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(
sliderInput(inputId = "slider", label = NULL, min = 1, max = 5, value = 3, step = 1)
),
dashboardBody(
fluidRow(
box(width = 12,
p(
mainPanel(width = 12,
column(6,
uiOutput("reference")
),
column(6,
uiOutput("comparison")
)
)
)
)
)
)
)
server <- function(input, output) {
output$reference <- renderUI({
tabsetPanel(
tabPanel(
"Reference",
h3("Reference Content"))
)
})
output$comparison <- renderUI({
req(input$slider)
tabsetPanel(
lapply(1:input$slider, function(i) {
tabPanel(title = glue("Tab {i}"),
value = h3(glue("Content {i}"))
)
})
)
})
}
shinyApp(ui = ui, server = server)
This does not produce the desired results, as the comparison tabs are not shown properly.
I have already checked out these 2 threads:
R Shiny - add tabPanel to tabsetPanel dynamically (with the use of renderUI)
R Shiny dynamic tab number and input generation
but they don't seem to solve my problem. Yes, they create tabs dynamically with a slider, but they don't allow to fill these with content as far as I can tell.
What works for me is a combination for lapply and do.call
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
library(glue)
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(
sliderInput(inputId = "slider", label = NULL, min = 1, max = 5, value = 3, step = 1)
),
dashboardBody(
fluidRow(
box(width = 12,
p(
mainPanel(width = 12,
column(6,
uiOutput("reference")
),
column(6,
uiOutput("comparison")
)
)
)
)
)
)
)
server <- function(input, output) {
output$reference <- renderUI({
tabsetPanel(
tabPanel(
"Reference",
h3("Reference Content"))
)
})
output$comparison <- renderUI({
req(input$slider)
myTabs = lapply(1:input$slider, function(i) {
tabPanel(title = glue("Tab {i}"),
h3(glue("Content {i}"))
)
})
do.call(tabsetPanel, myTabs)
})
}
shinyApp(ui = ui, server = server)
I have two tabs in my App and when I go to the video tab and click full screen and then go back to my leaflet page, the map is not displayed properly, please see the code and screenshot below.
step 1: click video tab
step 2: click full screen button (of the video)
step 3: hit ESC key
step 4: click dashboard tab
ui.R
library("shinydashboard")
library("shiny")
library("leaflet")
dashboardPage(
header = dashboardHeader(),
sidebar = dashboardSidebar(disable = FALSE,
collapsed = FALSE,
sidebarMenu(
menuItem("Dashboard", tabName = "dashboard"),
menuItem("Video", tabName = "video")
)
),
body = dashboardBody(
tabItems(
tabItem(tabName = "dashboard",
fluidRow(
column(width = 9, box(width = NULL, solidHeader = TRUE, leafletOutput("map", height=700)))
)
),
tabItem(
tabName = "video",
fluidRow(
column(width = 9, tags$video(src = "http://mirrors.standaloneinstaller.com/video-sample/jellyfish-25-mbps-hd-hevc.mp4", type = "video/mp4", height = "320px",
weight = "640px", controls = "controls")
)
)
)
)
)
)
server.R
library("shinydashboard")
library("shiny")
library("leaflet")
function(input, output, session){
output$map <- renderLeaflet(
leaflet() %>%
addTiles() %>%
setView(lng = -77.0387185, lat = 38.8976763, zoom = 10)
)
}
Thanks
This seems like a bug to me, but I am not sure on which side, leaflet/shinydashboard or shiny, as this also seems to happen when using fluidPage and tabsetPanel.
A workaround would be to trigger a fake resize event on the window, as this apparently solves the problem, also when done manually.
The jscode waits for a click on the sidebar-menu list and triggers a new resize Event. Make sure to include the Jquery code in the HTML by adding tags$head(tags$script(jscode)) to the dashboardBody.
library(shinydashboard)
library(shiny)
library(leaflet)
jscode = HTML("
$(document).on('shiny:connected', function() {
$('.sidebar-menu li').on('click', function(){
window.dispatchEvent(new Event('resize'));
});
});
")
ui <- {dashboardPage(
header = dashboardHeader(),
sidebar = dashboardSidebar(disable = FALSE,
collapsed = FALSE,
sidebarMenu(
menuItem("Dashboard", tabName = "dashboard"),
menuItem("Video", tabName = "video")
)
),
body = dashboardBody(
tags$head(tags$script(jscode)),
tabItems(
tabItem(tabName = "dashboard",
fluidRow(
column(width = 9, box(width = NULL, solidHeader = TRUE, leafletOutput("map", height=700)))
)
),
tabItem(
tabName = "video",
fluidRow(
column(width = 9, tags$video(src = "http://mirrors.standaloneinstaller.com/video-sample/jellyfish-25-mbps-hd-hevc.mp4", type = "video/mp4", height = "320px",
weight = "640px", controls = "controls")
)
)
)
)
)
)}
server <- function(input, output, session){
output$map <- renderLeaflet(
leaflet() %>%
addTiles() %>%
setView(lng = -77.0387185, lat = 38.8976763, zoom = 10)
)
}
shinyApp(ui, server)