I have this code:
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
shinyApp(
ui = dashboardPage(
header = dashboardHeader(userOutput("user")),
sidebar = dashboardSidebar(shinyjs::useShinyjs(),uiOutput("sidebarpanel")),
body = dashboardBody(uiOutput("body")),
title = "DashboardPage"
),
server = function(input, output) {
output$user <- renderUser({
dashboardUser(
name = "Divad Nojnarg",
image = "https://adminlte.io/themes/AdminLTE/dist/img/user2-160x160.jpg",
title = "shinydashboardPlus",
subtitle = "Author",
footer = p("The footer", class = "text-center"),
fluidRow(
actionButton("personalInfo","Personal Info")
)
)
})
observeEvent(input$personalInfo, {
output$body <- renderUI({h4("Personal Info Dahsboard (no menuItem)")})
})
output$sidebarpanel <- renderUI({
sidebarMenu(id="tabs",
menuItem("Dashboard 1", tabName = "dashboard1", icon = icon("dashboard"))
,menuItem("Dashboard 2", tabName = "dashboard2", icon = icon("dashboard"))
)
})
output$body <- renderUI({
tabItems(
tabItem(tabName ="dashboard1",
fluidRow(box(width = 12, h4("Dashboard 1 (menuItem)"))))
,tabItem(tabName ="dashboard2",
fluidRow(box(width = 12, h4("Dashboard 2 (menuItem)"))))
)
})
}
)
I would like to do two things:
First: When I click on "Personal Info" button, then, prevent the menuItem to be shadowed (I assume I need to remove the class "selected" or "active" or something like that)
Second: I want to fix this: After pressing "Personal Info" button, the menuItems do not work:
As already shown in my earlier answer here we can use a hidden menuItem to modify the body content independent from the visibly selected menuItem.
Furthermore, I'd recommend to stop using renderUI in this scenario. In general it is slower to re-render a UI element instead of updating an existing element (here we can switch to the hidden menuItem via updateTabItems - however, this applies also to e.g. using updateSelectInput instead of renderUI({selectInput(...)})). In this context you should also question whether you really need the to create the dashboardUser on the server side.
If you really need a server side generated dashboardSidebar you still should not use renderUI - There are the renderMenu() / sidebarMenuOutput() functions available for this. Please see the related docs here.
library(shiny)
library(shinyjs)
library(shinydashboard)
library(shinydashboardPlus)
shinyApp(
ui = dashboardPage(
header = dashboardHeader(userOutput("user")),
sidebar = dashboardSidebar(shinyjs::useShinyjs(),
sidebarMenu(id="tabs",
menuItem("Tab 1", tabName = "tab1", icon = icon("dashboard")),
menuItem("Tab 2", tabName = "tab2", icon = icon("dashboard")),
hidden(menuItem("Personal Tab", tabName = "personal_tab", icon = icon("dashboard")))
)),
body = dashboardBody(useShinyjs(),
tabItems(
tabItem(tabName ="tab1",
fluidRow(box(width = 12, h4("Tab 1 (menuItem)")))),
tabItem(tabName ="tab2",
fluidRow(box(width = 12, h4("Tab 2 (menuItem)")))),
tabItem(tabName ="personal_tab",
fluidRow(box(width = 12, h4("Personal Info Dahsboard (no menuItem)"))))
)
),
title = "DashboardPage"
),
server = function(input, output, session) {
output$user <- renderUser({
dashboardUser(
name = "Divad Nojnarg",
image = "https://adminlte.io/themes/AdminLTE/dist/img/user2-160x160.jpg",
title = "shinydashboardPlus",
subtitle = "Author",
footer = p("The footer", class = "text-center"),
fluidRow(
actionButton("personalInfo","Personal Info")
)
)
})
observeEvent(input$personalInfo, {
shinydashboard::updateTabItems(session, inputId = "tabs", selected = "personal_tab")
})
}
)
Related
I am using boxSidebar for my non-english shiny app, and would really like to replace the 'More' text that appears on hovering over the icon. Can anyone help me with a solution for this?
Alternatively, I was thinking to remove it by using shinyjs::hide(), but the ID seems to change on every hover so I do not know if that's an option here.
minimum example:
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
shinyApp(
ui = dashboardPage(
header = dashboardHeader(),
body = dashboardBody(
box(
title = "Hover icon",
sidebar = boxSidebar(
id = "mycardsidebar",
p("Sidebar Content")
)
)
),
sidebar = dashboardSidebar()
),
server = function(input, output, session) {
}
)
We can use {htmltools} to do the work:
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
library(htmltools)
library(magrittr)
shinyApp(
ui = dashboardPage(
header = dashboardHeader(),
body = dashboardBody(
box(
title = "Hover icon",
sidebar = boxSidebar(
id = "mycardsidebar",
p("Sidebar Content")
)
) %>% {
tagQuery(.)$
find("#mycardsidebar")$
removeAttrs("data-original-title")$
addAttrs(`data-original-title`="whatever")$
allTags()
}
),
sidebar = dashboardSidebar()
),
server = function(input, output, session) {
}
)
change whatever to your text.
Is there a way to automatically upload the excel file.
Right now, the user has to manually upload the excel file(file.xlsx) that is kept under project folder.
Now the expected output is the moment the user clicks on "Automatically Upload the exceil file", the file should get uploaded.
Is there a way to achieve this? Let me know if this makes sense
library(tidyverse)
library(shiny)
library(shinydashboard)
library(DT)
ui <-
dashboardPage(
skin = "green",
dashboardHeader(
title = "Test",
titleWidth = 280
),
dashboardSidebar(
width = 280,
sidebarMenu(
menuItem(text = "File(s) Upload", tabName = "Files", icon = icon("file-upload")),
menuItem(text = "Output", tabName = "Out1", icon = icon("file-upload"))
)
),
dashboardBody(
tabItems(
tabItem(
tabName = "Files",
fluidRow(
column(
width = 4,
inputPanel(
fileInput(inputId = "File1", label = "File", multiple = TRUE, accept = c(".xlsx")),
selectInput(inputId = "Sheet1", label = "Select sheet", choices = NULL, selected = NULL),
actionButton("sub", "Automatically Upload the exceil file")
)
)
)
),
tabItem(
tabName = "Out1",
fluidRow(column(width = 10, strong("Data")), align = "center"),
br(),
fluidRow(dataTableOutput("Data1"))
)
)
)
)
server <- function(input, output){
# Populate the drop down menu with the names of the different Excel Sheets, but
# only after a new file is supplied
observe({
sheet_names <- readxl::excel_sheets(input$File1$datapath)
shiny::updateSelectInput(
inputId = "Sheet1",
choices = sheet_names,
selected = sheet_names[[1]]
)
}) %>%
bindEvent(input$File1)
# When the drop down meny is populated, read the selected sheet from the Excel
# file
thedata <- reactive({
req(input$Sheet1)
readxl::read_xlsx(input$File1$datapath, sheet = input$Sheet1)
})
output$Data1 <-
renderDataTable(
thedata()
, extensions = "Buttons"
, options = list(
dom = "Bfrtip"
, buttons = c("copy", "csv", "excel", "pdf", "print")
)
)
# observe({
# print(reactiveValuesToList(input, all.names = FALSE))
# })
}
runApp(
list(ui = ui, server = server)
, launch.browser = TRUE
)
Lets take the example of the reference: https://rstudio.github.io/shinydashboard/structure.html#sidebar-menu-items-and-tabs. When put more items in the menuItem(), your associate tab don't works anymore. I tried in this simple modification in example below and just shown the widgets' tab:
sidebar <- dashboardSidebar(
sidebarMenu(
menuItem("Dashboard",
tabName = "dashboard",
icon = icon("dashboard"),
selected = TRUE,
startExpanded = TRUE,
numericInput("num1",
"Put the First Number",
value = 1,
min = 0),
numericInput("num2",
"Put the Second Number",
value = 1,
min = 0)
),
menuItem("Widgets",
icon = icon("th"),
tabName = "widgets")
)
)
body <- dashboardBody(
tabItems(
tabItem(tabName = "dashboard",
h2("Dashboard tab content"),
fluidRow(
valueBoxOutput("box1", width = 6),
valueBoxOutput("box2", width = 6)
)
),
tabItem(tabName = "widgets",
h2("Widgets tab content")
)
)
)
# Put them together into a dashboardPage
ui <- dashboardPage(
skin = "green",
dashboardHeader(title = "Example"),
sidebar,
body
)
server <- function(input, output){
output$box1 <- renderValueBox({
valueBox(input$num1,
"First Number",
color = "aqua",
icon = icon("chart-line"))
})
output$box2 <- renderValueBox({
valueBox(input$num2,
"Second Number",
color = "aqua",
icon = icon("chart-line"))
})
}
shinyApp(ui, server)
That is because childfull menuItem behaves differently as noted here. Therefore, you need to define a menuItem or a menSubItem within that dashboard page so that your desired content can be displayed.
Try this
sidebarMenu(id = "tabs",
menuItem("Dashboard",
tabName = "dashboard",
icon = icon("tachometer-alt"),
selected = TRUE,
startExpanded = TRUE,
#icon = icon(fontawesome:::fa_tbl[[1]][505]),
menuItem("Sub-item 1", tabName = "subitem1"),
### menuSubItem("Sub-item 1", tabName = "subitem1"), ## it can be menuSubItem instead of menuItem
numericInput("num1",
"Put the First Number",
value = 1,
min = 0),
numericInput("num2",
"Put the Second Number",
value = 2,
min = 0)
),
menuItem("Widgets",
icon = icon("th"),
tabName = "widgets")
)
)
body <- shinydashboard::dashboardBody(
tabItems(
tabItem(tabName = "subitem1",
h2("Sub item1 tab content in Dashboard"),
fluidRow(
valueBoxOutput("box1", width = 6),
valueBoxOutput("box2", width = 6)
)
),
tabItem(tabName = "widgets",
h2("Widgets tab content")
)
)
)
# Put them together into a dashboardPage
ui <- shinydashboard::dashboardPage(
skin = "green",
shinydashboard::dashboardHeader(title = "Example"),
sidebar,
body
)
server <- function(input, output, session){
output$box1 <- renderValueBox({
valueBox(input$num1,
"First Number",
color = "aqua",
icon = icon("chart-line"))
})
output$box2 <- renderValueBox({
valueBox(input$num2,
"Second Number",
color = "aqua",
icon = icon("chart-line"))
})
observe({print(input$tabs)})
}
shinyApp(ui, server)
Now intially the box is open instead of that i need the box should be closed.
The box should't open untill i click on the collapsible
library(shiny)
library(shinydashboard)
shinyApp(
ui = dashboardPage(
dashboardHeader(),
dashboardSidebar(),
dashboardBody(
gradientBox(
title = "My gradient Box",
icon = "fa fa-th",
gradientColor = "teal",
boxToolSize = "sm",
footer = sliderInput(
"obs",
"Number of observations:",
min = 0, max = 1000, value = 500
),
"This is a gradient box"
)
),
title = "Description Blocks"
),
server = function(input, output) { }
)
There doesn't seem to be an argument in gradientBox that enables the box to be collapsed on startup.
Since {shinydashboardPlus} version 2.0.0 gradientBox has been removed and can use box instead. This has the argument collapsed which when true will start collapsed:
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(),
dashboardBody(
box(
"This is a gradient box",
title = "My gradient Box",
gradient = TRUE,
background = "teal",
collapsible = TRUE,
collapsed = TRUE,
boxToolSize = "sm",
footer = sliderInput(
"obs",
"Number of observations:",
min = 0,
max = 1000,
value = 500
)
)
),
title = "Description Blocks"
)
shinyApp(
ui = ui,
server = function(input, output) { }
)
If you cannot upgrade {shinydashboardPlus} then you can use boxPlus. It won't be able to use the gradient, but will still be able to start collapsed.
I have a dashboard that is supposed to help the user keep track of a list of chores. The chores are listed as menuSubItems in the sidebarMenu. So, if the file corresponding to a chore has been created, I want a check-icon to be placed beside the menuSubItem.
I'm having a hard time understanding why do the menuSubItems wait untill I have clicked on test and then home again to be rendered... I tried printing out input$test_subitems and it seems that I can't track when test is selected.
library(shiny)
library(shinydashboard)
ui <- dashboardPage(
skin = "blue",
dashboardHeader(title = "Dynamic Menu"),
dashboardSidebar(
sidebarMenu(
id = "sidebarMenu",
menuItem("Home", tabName = "home", icon = icon("home")),
menuItem("Item with subitems", tabName = "test",
uiOutput("test_subitems"))
)
),
dashboardBody( id = "dashboardBody" )
)
server <- shinyServer(function(input, output, session) {
observe(cat('1:', input$sidebarMenu, '\n'))
output$test_subitems <- renderUI({
print(input$sidebarMenu)
tabs <- c("st1","st2")
lapply(tabs, function(tab) {
menuSubItem(icon = NULL, paste('Test:', tab), tabName = tab)
})
})
session$onSessionEnded(stopApp)
})
shinyApp(ui, server)
Althought I didn't find a way to id an item with subitems, it seems that suspendWhenHidden does the trick for me:
outputOptions(output, "test_subitems", suspendWhenHidden = FALSE)