I'm using the splitLayout() function within a dashboardSidebar() from the shinydashboard package. When I do, there is a significant gap between inputs within my splitLayout().
When I used vanilla shiny, I could control this gap with parameter cellArgs = list(style="padding: 0px") but this seems to have a different effect within a dashboardSidebar().
Question:
How can I control the gap between inputs inside a splitLayout() within a dashboardSidebar()?
Here is a MRE which shows my unsuccessful attempts at using padding
library(shinydashboard)
library(shiny)
sidebar <- dashboardSidebar(width=400,
sidebarMenu(
menuItem("Default", tabName = "dashboard", icon = icon("dashboard"),startExpanded = T,
splitLayout(cellWidths = c(100,100,100,100),
textInput("a1",label=NULL,value = 1),
textInput("a2",label=NULL,value = 2),
textInput("a3",label=NULL,value = 3),
textInput("a4",label=NULL,value = 4)
),
splitLayout(cellWidths = c(100,100,100,100),cellArgs = list(style="padding: 0px"),
textInput("b1",label=NULL,value = 1),
textInput("b2",label=NULL,value = 2),
textInput("b3",label=NULL,value = 3),
textInput("b4",label=NULL,value = 4)
),
#see the effect of padding
splitLayout(cellWidths = c(100,100,100,100),cellArgs = list(style="padding: 20px"),
textInput("c1",label=NULL,value = 1),
textInput("c2",label=NULL,value = 2),
textInput("c3",label=NULL,value = 3),
textInput("c4",label=NULL,value = 4)
)
)
)
)
body <- dashboardBody(
)
# Put them together into a dashboardPage
ui <- dashboardPage(
dashboardHeader(title = "Padding demo",titleWidth=400),
sidebar,
body
)
server <- function(input, output) {
}
shinyApp(ui,server)
your problem is not the padding of the the splitCells - that is working fine. It has more to do with that the inputs also have padding around them. To remove this you can add the following code
body <- dashboardBody(
tags$head(
tags$style(
".shiny-input-container{padding:0px !important;}"
)
)
)
hope this helps
Related
I am currently building a Shiny app and would like to display some text blocks. The text blocks are of different lengths, and I would like to color each block and also have some gap between the blocks.
However since the blocks have different text lengths, I am only able to color the block upto the point where there is text and not in the empty area. However that results in a bit ugly coloring.
Also the minimum gap between the columns apparently is 1, and that is too much of a gap from a visual point of view.
What I want to get to is coloring of Columns B & C down to the length of Column A.
I also want to reduce the gap between the columns and I have set it to an offset of 1, but I am unable to offset it to a fraction < 1.
This is the code that results in the picture above:
ui <- fluidPage(
mainPanel(
tabsetPanel(
tabPanel("Data Visualization",
fluidRow(
column(3,h3("Title A",align = "center"),style = "background-color: red;"),
column(3,h3("Title B",align = "center"),style = "background-color: yellow;",offset = 1),
column(3,h3("Title C",align = "center"),style = "background-color: green;",offset = 1)
),
fluidRow(
column(3, h4(tags$li("Text A")),style = "background-color: red;"),
column(3,tags$li(h4("Text B")),style = "background-color: yellow;",offset = 1),
column(3,tags$li(h4("Text C")),style = "background-color: green;",offset = 1)
),
fluidRow(
column(3, h4(tags$li("More Text A")),style = "background-color: red;"),
column(3,"",style = "background-color: yellow;", offset = 1),
column(3,"",style = "background-color: green;", offset = 1)
),
fluidRow(
column(3, h4(tags$li("More and More Text A")),style = "background-color: red;"),
column(3,"",style = "background-color: yellow;", offset = 1),
column(3,"",style = "background-color: green;", offset = 1)
)
))))
server <- function(input,output) {}
shinyApp(ui = ui, server = server)
Kindly let me know how do I style this without any hardcoded pixel widths (as that might impact the viewing experience of different screen sizes) to get the coloring equal to the max length column.
If there is another way to have such text boxes in shiny then also it would help to know.
Many thanks!
I think using shinydashboard::box() would be an easier approach:
library(shiny)
library(shinydashboard)
body <- dashboardBody(
# change this to set space between boxes
tags$head(tags$style(
HTML('.row div {padding: 0% 1% 0% 1% !important;}'))),
fluidRow(
box(
title = "Title A", width = 4, background = "red",
"Some text that is contained within a red box"
),
box(
title = "Title B", width = 4, background = "yellow",
"Some text that is contained within a yellow box and also a bit longer
than the other boxes."
),
box(
title = "Title C",width = 4, background = "green",
"Some text that is contained within a green box"
)
),
fluidRow(
box(
width = 4, background = "red",
"And simply don't specify a title to create some more text about topic A."
)
)
)
ui <- dashboardPage(
dashboardHeader(title = "Example of Dashboard"),
dashboardSidebar(),
body
)
shinyApp(ui = ui, server = function(input, output) { })
which gives you
I have the shiny dashboard below and I want to print inside the box "Red1" to "Red21" one below the other using a for() loop like in the screenshot. The box() should be created with renderUI()
library(shiny)
library(shinydashboard)
shinyApp(
ui = dashboardPage(
options = list(sidebarExpandOnHover = TRUE),
header = dashboardHeader(),
sidebar = dashboardSidebar(minified = TRUE, collapsed = TRUE),
body = dashboardBody(
uiOutput("box1")
),
title = "DashboardPage"
),
server = function(input, output) {
output$box1<-renderUI({
box(
for(i in 1:21){
"Red"[i]
br()
},
height = 300,width = 5
)
})
}
)
box() can take a list as first argument, so your code can be rewritten like this:
...
box({
text <- list()
for(i in 1:21){
text <- append(text, list(paste("Red", i), br()))
}
text
})
...
Doing this with an anonymous function (which this is) isn't that good for readability (at least for me) so I would suggest you build that list beforehand.
library(needs)
needs(
shiny,
ggplot2,
tidyverse,
shinydashboard,
DT
)
source("~/functions.R",local = T)
# Define UI for application that draws a histogram
header = dashboardHeader(
# tags$li(class = "dropdown",
# tags$style(".main-header {max-height: 80px}"),
# tags$style(".main-header .logo {height: 80px}")),
#title = tags$img(src='logo.png',height='100',width='200')
)
sidebar = dashboardSidebar(
menuItem("Full data",tabName="Data",icon=icon("table"),startExpanded = F,
fileInput("file","Upload CSV files",multiple=TRUE,accept=("text/comma"))),
menuItem(text = 'Simulate',tabName = 'simulate',icon=icon('chart-line'),
helpText('Simulation Parameters'),
radioButtons('type',"Please choose the type of analysis:",choices = list("Gender" = 1,"US Minority Status" = 2),selected = 1),
sliderInput("numSims","Number of simulations:",min = 1, max = 10000,step = 1000,value = 10000),
sliderInput("numYears","Number of years to simulate:",min = 1,max = 5,value = 3,step = 1),
numericInput('turnover','Total Turnover', value = 10),
sliderInput('promoRate','Set Promo rate', value = 25, min = 1, max = 100, step = 5),
sliderInput('growthRate','Set growth rate',value = 0,min=0,max=100,step = 1),
helpText('0% Growth Rate assumes a flat, constant headcount'),
actionButton('go',label = "Update"),width = 4)
)
body <- dashboardBody(
tabItems(
tabItem(
tabName = 'data',
fluidRow(wellPanel(
fileInput(
inputId = 'file',
label = "File Upload:",
accept = c("csv", ".csv")))),
wellPanel(DT::dataTableOutput('table'))),
tabItem(
tabName = 'simulate',
fluidRow(
wellPanel(
DT:::dataTableOutput('simDataTable')
))
)
))
ui = shinydashboard::dashboardPage(header,sidebar,body,skin='red')
server = server <- function(input, output) {
options(shiny.maxRequestSize = 30 * 1024 ^ 2)
dataset <- reactive({
req(input$file)
read.csv(input$file$datapath)
})
output$table = renderDataTable(dataset(), filter = 'top',options = list(scrollX = TRUE))
simulate = eventReactive(input$go,{
req(input$numSims,input$type)
x = dataset()
temp = dataSim(x,type=input$type,
numSims = input$numSims)
})
simulateAvg = reactive({
x = simulate()
y = x %>% group_by(Role) %>% summarise(mean(freq))
})
output$simDataTable = renderDataTable(simulateAvg())
}
shinyApp(ui,server)
I'm having some trouble with two issues.
1.) The formatting of the shiny dashboard is odd. The text on the side bar seems very compacted and not what other shiny dashboards look like. I'm not sure what the issue is.
2.) After upload, a table is suppose to appear on the dashboard body but it doesn't
3.) Once a table appears and I head to the simulate tab, will the dashboard body change accordingly and display the simulateAvgData set that I populated?
The dataSim function is from the source file on top. I don't receive any errors when I run anything so looking for guidance and inputs to whether or not this shiny dashboard work as intended. I'm newer to the dashboard packages from shiny.
You have a couple of issues here. You do not need a fileInput statement inside dashboardBody. Next, within dashboardSidebar, you can define fileInput at the top level of menuItem (option 1 in the code below), or a sub-level of the first menuItem (option 2 below). In either case, you need to have a menuItem with a tabName where you want to display the file that was read in. Once you read the input file, you need to select the appropriate tab to see the displayed data. Try this code
header <- dashboardHeader()
### option 1: fileInput at the first menuItem level
# sidebar <- dashboardSidebar(width=320,
# menuItem("Full data",tabName="Data",icon=icon("table"),startExpanded = F),
# fileInput("file","Upload CSV files",multiple=FALSE,accept=c("csv", ".csv"))
# )
### option 2 - fileInput as a subitem
sidebar <- dashboardSidebar(width=320,
menuItem("Full data",tabName="noData",icon=icon("table"),startExpanded = F, ## data not displayed for this tabName
menuItem("Full_data",tabName="Data", icon=icon("table")),
fileInput("file","Upload CSV files",multiple=FALSE,accept=c("csv", ".csv")))
)
body <- dashboardBody(
tabItems(
tabItem(
tabName = 'Data',
fluidRow(DTOutput('table')))
))
ui <- shinydashboard::dashboardPage(header,sidebar,body,skin='red')
server <- function(input, output, session) {
data1 <- reactive({
req(input$file)
data <- read.csv(input$file$datapath,sep = ",", header = TRUE)
})
output$table <- renderDT(data1())
}
shinyApp(ui,server)
I have multiple input fields in my shinyApp (fileInput, numericInput, textInput), and I would like to customize their height, as well as the character size.
I have tried with div(), but I could only change the gap between two fields. In this case setting div(style="height: 60px;",numericInput("rat","RATIO", value = 0,step=0.01 , width = '40%')) would only decrease the distance between the numeric input field and the slider.
Here is an example code:
sidebar <- dashboardSidebar(
sidebarMenu(
div(style="height: 70px;",fileInput('uploadfile',"Select result file(s)", multiple=TRUE,accep=".txt")),
div(style="height: 60px;",numericInput("rat","RATIO", value = 0,step=0.01 , width = '40%')),
div(style="height: 60px;",sliderInput("ratio",NULL, min= 0, max= 1, value = 0)),
textInput("mytext","Enter name",value='', width = '50%')
)
)
ui<-dashboardPage(
dashboardHeader(title = "Analysis"),
sidebar,
body <- dashboardBody()
)
server<-shinyServer(function(input, output, session){})
shinyApp(ui = ui, server = server)
I have never done any html, so I am not sure what should I look for exactly.
There are several ways of doing that using CSS.
You can either change all inputs that have the same CSS class. Then all inputs of same type would be styled the same way. Or you use the knowledge that you know the id of the ui elements. For me it sounds like that latter is more interesting for you as it seems you want to do specific styling for each of the inputs.
Within shiny you can overwrite existing CSS with the tags$style() command. You can use the format #id{property: value}. So for the inputfile with the id uploadfile, you could use: #uploadfile{height: 70px}. (Note that if you are interested in adapting classes you would use .className{property: value}
Reproducible example:
sidebar <- dashboardSidebar(
sidebarMenu(
tags$head(
tags$style(
HTML('
#uploadfile{height: 70px}
#rat{height: 60px}
#ratio{height: 60px}
#mytext{width: 50px}
')
)
),
fileInput('uploadfile',"Select result file(s)", multiple=TRUE,accep=".txt"),
numericInput("rat","RATIO", value = 0,step=0.01 , width = '40%'),
sliderInput("ratio",NULL, min= 0, max= 1, value = 0),
textInput("mytext","Enter name",value='', width = '50%')
)
)
ui<-dashboardPage(
dashboardHeader(title = "Analysis"),
sidebar,
body <- dashboardBody()
)
server<-shinyServer(function(input, output, session){})
shinyApp(ui = ui, server = server)
I am trying to change the base layer in my Shiny App in a programatic way.
Since I don't want to use the LayerControl of 'Leaflet' and rather want to have all the controls in one panel. I decided to use shinyjs and go with the toggleState for a button to switch forth and back between two base layers.
At the moment I am in the phase to figure out the principles of changing the base layer, and since there can be only one base layer visible it seem like I have to remove the tiles of the initially loaded base layer.
Doing so I can change the base layer at display, but at the same time the base layer is changed I am loosing the overlay. How can I avoid that?
When using the button again I can see in the flicker that the overlay is still there, but not on top of the base layer anymore.
Here an example:
library(shiny)
library(leaflet)
library(shinydashboard)
# Definition of Sidebar elements
sidebar <- dashboardSidebar(
sidebarMenu(
menuItem("Maps", tabName = "maps", icon = icon("globe"),
menuSubItem(
HTML(paste("Diffuse kilder NH", tags$sub("3"), sep = "")),
tabName = "map_dif_nh3", icon = icon("map-o"), selected = TRUE
)
)
)
)
# Definition of body elements
body <- dashboardBody(
tabItems(
tabItem(tabName = "map_dif_nh3",
box(
width = 12,
div(style = "height: calc(100vh - 80px);",
leafletOutput(
"m_dif_nh3", width = "100%", height = "100%"
),
absolutePanel(id = "nh3_panel", class = "panel panel-default",
fixed = TRUE, style = "opacity: 0.87",
top = 80, left = "auto", right = 50, bottom = "auto",
width = 285, height = "auto",
fluidRow(
column(width = 10, offset = 1,
actionButton(inputId = 'btn_bgr_nh3', label = "", icon = icon("globe", class = "fa-lg"))
)
)
)
)
)
)
)
)
ui <- dashboardPage(
dashboardHeader(title = "Mixed layout"),
sidebar,
body
)
server <- function(input, output) {
init_lat <- 56.085935208960585
init_lon <- 10.29481415546154
init_zoom <- 7
output$m_dif_nh3 <- renderLeaflet({
leaflet(height = "100%") %>%
addProviderTiles("Stamen.Toner", layerId = 'mb_osm', group = "base") %>%
setView(init_lon, init_lat, init_zoom) %>%
addWMSTiles(
"http://gis.au.dk/geoserver_test/PRTR/gwc/service/wms",
layers = "PRTR:prtr_nh3_2014",
layerId = "nh3_2014",
group = "overlay",
options = WMSTileOptions(format = "image/png",
transparent = TRUE, opacity = 0.8
)
)
})
observeEvent(
input$btn_bgr_nh3, {
leafletProxy("m_dif_nh3") %>%
addProviderTiles("Esri.WorldImagery", layerId = 'mb_pic', group = 'base')
leafletProxy("m_dif_nh3") %>%
removeTiles(layerId = 'mb_osm')
}
)
}
shinyApp(ui, server)
I think what you can do is reset the value of ID the action button to 0 after clicking the button. Therefore, every time you toggle the ID value will be replaced by 0. It worked for me. Hope it work for you as well.
In Leaflet JS (I don't know about R), if myTileLayer is already part of your base layers, then myTileLayer.addTo(map) does the switching job. It doesn't add on top; and you don't need to remove the current layer. The overlay remains unaffected.
Ref: https://stackoverflow.com/a/33762133/4355695