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:
Related
This is a follow-on to post How to build a drag and drop hierarchical tree that automatically updates. I am exploring the ways to visualize and manipulate a hierarchical tree in Shiny, in order to allow the user to flexibly apply a sequence of mathematical operations. The hierarchical tree would allow the user to arrange the order of mathematical operations (preferably using drag and drop), and make certain inputs, as shown in the illustration at the bottom.
Initially and ideally when invoking, the user would be presented with one parent and an allocation of 100% to that parent. From there, the user would have the ability to add parents/children/nodes, to build out a hierarchy tree of increasing complexity; preferably using drag/drop or list of options with a right mouse button click for example.
I've been reviewing packages jsTreeR and shinyTree, and they seem like they might work for this purpose. If you think these work, can you provide with any examples to get me started on the right path? Or are there other packages that might work better for this? My last resort may be rhandsontable for an Excel-like approach, which is my default mindset from years of using XLS, but that would be giving up on my visual aspiration. I've also been exploring the shinyDND and sortable packages which might ultimately work, but I need to explore all options early before risking getting stuck in a rabbit hole. And also as I fiddle with hierarchy trees they seem to make the most sense, visually, for the context of my application.
Example reproducible code (it could give me a start in the right direction):
library(shiny)
library(shinyTree)
values_parents <- function(tree){
sapply(tree, function(parent) attr(parent, "stinfo"))
}
total_values_children <- function(tree){
sapply(
lapply(tree, function(parent){
sapply(parent, function(children){
attr(children, "stinfo")
})
}),
function(x){if(is.list(x)) NA else sum(x)}
)
}
ui <- fluidPage(
tags$head(
tags$style(HTML("pre {font-size: 17px;} .jstree-anchor {font-size: large;}"))
),
fluidRow(
column(
width = 6,
shinyTree("tree", dragAndDrop = TRUE, checkbox = FALSE)
),
column(
width = 6,
tags$fieldset(
tags$legend("Values of parents:"),
verbatimTextOutput("parentsValues")
),
br(),
tags$fieldset(
tags$legend("Total value of children:"),
verbatimTextOutput("childrenTotalValue")
)
)
)
)
server <- function(input, output, session) {
output[["tree"]] <- renderTree({
list(
ParentA = structure(list(
ChildrenA1 = structure(NA, stinfo = 5),
ChildrenA2 = structure(NA, stinfo = 4)
),
stinfo = 10, stopened = FALSE),
ParentB = structure(list(
ChildrenB1 = structure(NA, stinfo = 6),
ChildrenB2 = structure(NA, stinfo = 8)
),
stinfo = 12, stopened = FALSE)
)
})
output[["parentsValues"]] <- renderPrint({
values_parents(input[["tree"]])
})
output[["childrenTotalValue"]] <- renderPrint({
total_values_children(input[["tree"]])
})
}
shinyApp(ui, server)
Illustration:
I'd give shinyTree a try. It seems to fit your requirements when setting dragAndDrop = TRUE and contextmenu = TRUE:
library(shiny)
library(shinyTree)
ui <- fluidPage(
pageWithSidebar(
# Application title
headerPanel("Simple shinyTree!"),
sidebarPanel(
helpText(HTML("A simple Shiny Tree example.
<hr>Created using shinyTree."))
),
mainPanel(
shinyTree("tree", stripes = TRUE, multiple = FALSE, animation = FALSE, dragAndDrop = TRUE, contextmenu = TRUE)
)
)
)
server <- function(input, output, session) {
output$tree <- renderTree({
list(
root1 = "",
root2 = list(
SubListA = list(leaf1 = "", leaf2 = "", leaf3=""),
SubListB = list(leafA = "", leafB = "")
),
root3 = list(
SubListA = list(leaf1 = "", leaf2 = "", leaf3=""),
SubListB = list(leafA = "", leafB = "")
)
)
})
}
shinyApp(ui, server)
I have an application which uses box::dropdownMenu to render a dropdown menu which the user will use to set plot options. I'm able to implement this functionality without any issue, but I would like to do two additional things.
Is it possible to:
(1) Hide the arrow to the right of the cog-icon?
(2) On the dropdown menu, is it possible to keep the text left-alligned, but have the radio buttons be right aligned?
Current State:
Desired End Result:
Code:
library(shiny)
library(shinyWidgets)
library(shinydashboardPlus)
ui <- fluidPage(
box(
title = "Box Title",
dropdownMenu = dropdown(
width = "200px",
icon = icon("gear"),
materialSwitch(inputId = "Id079", label = "Color:"),
materialSwitch(inputId = "Id079", label = "Display Goal:"),
),
textOutput("text")
)
)
server <- function(input, output, session) {
output$text <- renderText("Hello World!")
}
shinyApp(ui, server)
To remove the arrow, one should change style to something other than the default. You can use fill or bordered for example.
shinyWidgets::dropdown(
width = "200px",
style = "fill",
icon = icon("cog"),
materialSwitch(inputId = "Id079", label = "Color:"),
# Change IDs to unique IDs otherwise it won't work
materialSwitch(inputId = "Id080", label = "Display Goal:"),
)
For the alignment, you can play around with the .label-default elements (attrinutes?)
ui <- fluidPage(
# Need to play with the margin-left part
tags$head(tags$style(HTML(".label-default{
margin-left: 50px;}
"))),
shinyWidgets::dropdown(
width = "300px",
style = "fill",
icon = icon("cog"),
materialSwitch(inputId = "Id079", label = "Color:"),
materialSwitch(inputId = "Id080", label = "Display Goal:"),
),
textOutput("text")
)
The problem with this is that it is not easy to uniformly change the margins for non-equal labels.
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
I'm trying to build a Shiny dashboard that responds to user inputs by displaying a series of boxes with nicely formatted html content. Because the user's selections determine how many boxes will be displayed, I'm using lapply() to render the boxes on the server side and then pushing the results of that process to uiOutput() on the ui side.
It's working with one crucial exception: the html content isn't appearing in the boxes. I don't get any error messages or warnings; I just don't get any content inside the boxes, other than the reactive titles.
What follows is a simple, reproducible example. What do I need to do differently to get contents to appear inside the boxes in the body of the ui?
library(shiny)
library(shinydashboard)
library(shinyWidgets)
dat <- data.frame(food = c("hamburger", "hot dog", "pizza", "kale salad"),
price = c("$2.50", "$1.50", "$2.00", "$3.50"),
peanut_gallery = c("beefy!", "dachsund!", "pie time!", "healthy!"),
stringsAsFactors = FALSE)
### UI ###
header <- dashboardHeader(title = "My Food App", titleWidth = 400)
sidebar <- dashboardSidebar(width = 400,
fluidRow(column(width = 12,
checkboxGroupButtons(
inputId = "my_food",
label = "Pick a food",
choices = c("hamburger", "hot dog", "pizza", "kale salad"),
selected = NULL
)
))
)
body <- dashboardBody(
fluidRow(
uiOutput("little_boxes")
)
)
ui <- dashboardPage(header, sidebar, body, skin = "black")
### SERVER ###
server <- function(input, output) {
output$little_boxes <- renderUI({
req(input$my_food)
lapply(input$my_food, function(x) {
df <- dat[dat$food == x,]
contents <- div(h4(df$peanut_gallery),
h5(df$price),
p(sprintf("Isn't %s great? I love to eat it.", df$food)))
box(title = df$food,
width = 6,
background = "red",
collapsible = TRUE, collapsed = TRUE,
uiOutput(contents) )
})
})
}
## RUN ##
shinyApp(ui, server)
Try :
htmltools::tagList(contents)
instead of
uiOutput(contents)
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