How can I read parameters of a box element in shinydashboard?
box(..., title = NULL, footer = NULL, status = NULL,
solidHeader = FALSE, background = NULL, width = 6, height = NULL,
collapsible = FALSE, collapsed = FALSE)
In particular, I want to save parameter collapsed so that application does not redraw the box in collapsed state if a user expanded it (or vise versa).
Parameter collapsed returns to the originally set value if the tabs are generated.
Example code is below. Collapsed state is reset after adding a tab by the button.
library(shiny)
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(title = "Collapsed Box Example"),
dashboardSidebar(sidebarMenuOutput("menu"),
actionButton("addTab", label = "Add Tab")),
dashboardBody(uiOutput("body"))
)
server <- function(input, output) {
tabsCount <- reactiveVal(2)
#count button clicks
observeEvent(input$addTab, {
newValue <- tabsCount() + 1
tabsCount(newValue)
}
)
output$menu <- renderMenu(sidebarMenu(
do.call(menuItem, c(text = "Tabs", tabName = "tabs", startExpanded = T,
lapply(1:tabsCount(), function(i) {
menuSubItem(text = paste0("Tab ", i),
tabName=paste0("tab",i))
})
))
)
)
output$body <- renderUI({
Tabs <- vector("list", tabsCount())
for(i in 1:tabsCount()) {
tabname <- paste0("tab",i)
Tabs[[i]] <- tabItem(tabName = tabname, uiOutput(tabname))
}
do.call(tabItems, Tabs)
})
observe({
for (i in 1:tabsCount()) {
local({
my_i <- i
tabname <- paste0("tab", my_i)
output[[tabname]] <- renderUI(
box(title = paste("Box", my_i, sep = " "), collapsible = T, collapsed = T)
)
})
}
})
}
shinyApp(ui, server)
Related
In the Shiny App below, I want to update the value of selectInput box based on the row that is double-clicked by the user in the table of tab 3. For example, if user double clicks at row 3 in the table, then the value of selectInput should change to 3.
Here is my code -
library(shiny)
library(shinydashboard)
siderbar <- dashboardSidebar(
sidebarMenu(
# Add buttons to choose the way you want to select your data
selectizeInput(inputId = "select_by", label = "Select by:",
choices = c(as.character(1:5)))
)
)
body <- dashboardBody(
fluidRow(
tabBox(
side = "right",
selected = "Tab3",
tabPanel("Tab1", "Tab content 1", textOutput("tabset1Selected")),
tabPanel("Tab2", "Tab content 2", textOutput("tabset2Selected")),
tabPanel("Tab3", "Tab content 3", textOutput("tabset3Selected"),
DT::dataTableOutput("table", width = "100%", height = "100%"), color="#bb0a1e", size = 1.5, type = 8)
)
),
)
shinyApp(
ui = dashboardPage(
dashboardHeader(title = "tabBoxes"),
siderbar,
body
),
server = function(session, input, output) {
# The currently selected tab from the first box
output$tabset1Selected <- output$tabset2Selected <- output$tabset3Selected <- renderText({
input$select_by
})
outputOptions(output, "tabset1Selected", suspendWhenHidden = FALSE)
outputOptions(output, "tabset2Selected", suspendWhenHidden = FALSE)
outputOptions(output, "tabset3Selected", suspendWhenHidden = FALSE)
table_dt <- reactive({data.table(values = c(1,2,3,4,5))})
output$table <- DT::renderDataTable({
DT::datatable(table_dt(), filter = 'top', selection = "single", fillContainer = TRUE, width = "90%",
callback = htmlwidgets::JS(
"table.on('dblclick', 'td',",
" function() {",
" var data = table.row(this).data();",
" Shiny.setInputValue('table_tbl_dblclick', {dt_data: data});",
" }",
");"
))
}
)
observeEvent(input$table_tbl_dblclick, {
reactTXT$selected <- input$table_tbl_dblclick$dt_data[[2]] # Since table index starts with 0, adding 1 to map index with data.table
})
reactTXT <- reactiveValues()
observeEvent(eventExpr = input$select_by, handlerExpr = {
req(input$select_by)
reactTXT$selected <- input$select_by
updateSelectizeInput(session, "select_by", selected = reactTXT$selected)
}, ignoreInit = TRUE)
}
)
Can someone point out the reason selectInput is not updated after clicking inside the table?
I don't quite understand what the purpose of your observeEvents are. If it is only to update the selectize input this one works for me:
observeEvent(input$table_tbl_dblclick, {
updateSelectizeInput(session, "select_by", selected = input$table_tbl_dblclick$dt_data[[2]])
})
Updated alternative to preserve reactTXT as the source of the new value:
observeEvent(input$table_tbl_dblclick, {
selected <- input$table_tbl_dblclick$dt_data[[2]] # Since table index starts with 0, adding 1 to map index with data.table
reactTXT$selected <- selected
})
reactTXT <- reactiveValues()
observeEvent(reactTXT$selected, handlerExpr = {
updateSelectizeInput(session, "select_by", selected = reactTXT$selected)
}, ignoreInit = TRUE)
From comments below
I'm trying to create a page to include and exclude boxes dynamically using boxDropdownItem from shinydashboardplus package, but the application is crashing, could someone help me please?
*Solutions using javascript are also welcome :)
Here my code:
shinyApp(
ui = dashboardPage(
dashboardHeader(),
dashboardSidebar(),
dashboardBody(
uiOutput("boxes")
)
),
server = function(input, output) {
rvs = reactiveValues(boxDropdownItem = list(), observers = list())
output$boxes <- renderUI({
for(i in 1:5) {
rvs$boxDropdownItem[[i]] =
column(width = 12,
box( id = paste("box",i),
title = paste("box",i),
width = 4,
status = NULL,
dropdownMenu = boxDropdown(
icon = icon("ellipsis-v"),
boxDropdownItem(id = paste0("del",i), "Delete")
)
)
)
}
rvs$observers = lapply(1:(length(rvs$boxDropdownItem)),function(i) {
observeEvent(input[[paste0("del",i)]],{
rvs$observers <- rvs$observers[-i]
rvs$boxDropdownItem <- rvs$boxDropdownItem[-i]
})
})
do.call(fluidRow, rvs$boxDropdownItem)
})
}
)
You need to first create the boxes as a reactiveValues object. Then you can control what you display in renderUI. I have shown here for 3 boxes. You can modify it to dynamic number. Try this
library(shinydashboardPlus)
shinyApp(
ui = shinydashboard::dashboardPage(title = "My Box Dropdown",
dashboardHeader(),
dashboardSidebar(),
dashboardBody(
uiOutput("boxes")
)
),
server = function(input, output) {
rvs = reactiveValues(boxDropdownItem = list(), observers = list(), tmp=list())
observe({
for(i in 1:3) {
rvs$boxDropdownItem[[i]] <-
box(id = paste0("box",i),
title = paste("box",i),
width = 12,
status = "warning",
solidHeader = TRUE,
collapsible = TRUE,
dropdownMenu = boxDropdown(
icon = icon("ellipsis-v"),
boxDropdownItem("Click me", id = paste0("dropdownItem",i), icon = icon("heart")),
dropdownDivider(),
boxDropdownItem(id = paste0("del",i), "Delete")
),
paste("My Box",i)
)
}
})
output$boxes <- renderUI({
if (length(rvs$tmp)>0){
rvs$boxDropdownItem[!(rvs$boxDropdownItem %in% rvs$tmp)]
} else rvs$boxDropdownItem
})
lapply(1:3, function(i) {
observeEvent(input[[paste0("del",i)]],{
rvs$tmp[[i]] <<- rvs$boxDropdownItem[[i]]
}, ignoreInit = TRUE)
observeEvent(input[[paste0("dropdownItem",i)]], {
showNotification("Hello", duration = i, type = "error")
})
})
}
)
The picture below shows box 2 deleted.
I am unable to create a conditional sidebar menu via renderMenu because the if statement fails. "Warning: Error in if: argument is of length zero".
I found conditional RenderUI R shiny and Conditional panel in Shiny dashboard but neither are what I am looking for. A conditional panel might work in this instance but in the long run I will need to be able to do this server side.
if (interactive()) {
library(ggplot2)
library(shiny)
library(shinydashboard)
library(shinipsum)
ui <- dashboardPage(
header = dashboardHeader(),
dashboardSidebar(
sidebarMenuOutput("plotDataVHA"),
sidebarMenuOutput("tabSelector")
),
dashboardBody(tabItems(
tabItem(tabName = "facilities",
fluidRow(box(
uiOutput("selectedFacilityTime")
))),
tabItem(tabName = "service",
fluidRow(box(
uiOutput("selectedFacilityYyCases")
)))
))
)
server <- function(input, output) {
output$renderedSelectedFacilityTime <- renderPlot({
random_ggplot(type = "line")
})
output$selectedFacilityTime <- renderUI({
plotOutput("renderedSelectedFacilityTime")
})
output$renderedFacilityYyCases <- renderPlot({
random_ggplot(type = "bar")
})
output$selectedFacilityYyCases <- renderUI({
plotOutput("renderedFacilityYyCases")
})
output$tabSelector <- renderMenu({
sidebarMenu(id = "test",
menuItem(
text = "Chart data",
menuSubItem(
text = "Facilities",
tabName = "facilities",
selected = TRUE
),
menuSubItem(
text = "Service & Specialty",
tabName = "service",
icon = NULL
)
))
})
output$plotDataVHA <- renderMenu({
if (input$test == "facilities") {
sidebarMenu(
menuItem(
text = "VHA data",
menuSubItem(
text = "None",
selected = TRUE,
icon = NULL
),
menuSubItem(text = "Mean", icon = NULL)
)
)
}
})
}
shinyApp(ui, server)
}
When working properly the menu "VHA data" should only be visible when the submenu "facilities" is selected.
Interesting question. The reason you were getting the argument is of length zero error is because you are rendering both menus on the server side through renderMenu(). So when the app starts, input$test doesn't have a value assigned to it. You can avoid this by using req() which will evaluate the test input$test == "facilities" only after input$test has been initiated.
Now for the menu to only appear when another submenu is selected, you want to create the menu independently of renderMenu(). It is better to evaluate the condition in a normal reactive() and then pass this reactive function as input to renderMenu(). Finally, to remove the menu when input$test == "facilities" is FALSE, you can render an empty html container.
Here is the updated code:
library(ggplot2)
library(shiny)
library(shinydashboard)
library(shinipsum)
ui <- dashboardPage(
header = dashboardHeader(),
dashboardSidebar(
sidebarMenuOutput("plotDataVHA"),
sidebarMenuOutput("tabSelector")
),
dashboardBody(tabItems(
tabItem(tabName = "facilities",
fluidRow(box(
uiOutput("selectedFacilityTime")
))),
tabItem(tabName = "service",
fluidRow(box(
uiOutput("selectedFacilityYyCases")
)))
))
)
server <- function(input, session, output) {
output$renderedSelectedFacilityTime <- renderPlot({
random_ggplot(type = "line")
})
output$selectedFacilityTime <- renderUI({
plotOutput("renderedSelectedFacilityTime")
})
output$renderedFacilityYyCases <- renderPlot({
random_ggplot(type = "bar")
})
output$selectedFacilityYyCases <- renderUI({
plotOutput("renderedFacilityYyCases")
})
output$tabSelector <- renderMenu({
sidebarMenu(id = "test",
menuItem(
text = "Chart data",
menuSubItem(
text = "Facilities",
tabName = "facilities",
selected = TRUE
),
menuSubItem(
text = "Service & Specialty",
tabName = "service",
selected = FALSE,
icon = NULL
)
))
})
make_menu <- reactive({
cat("Current submenu selected: ", input$test, "\n\n")
if (req(input$test) == "facilities") {
sidebarMenu(
menuItem(
text = "VHA data",
menuSubItem(
text = "None",
selected = TRUE,
icon = NULL
),
menuSubItem(text = "Mean", icon = NULL)
)
)
} else {
# return an empty HTML container
div()
}
})
output$plotDataVHA <- renderMenu({
make_menu()
})
}
shinyApp(ui, server)
I am trying to use a package that allows users to graph their data in shiny (esquiss). It works fine. However the user interface for the shiny module in the package requires a fixed height container. I have therefore placed the call to the module in tag$div (inside a modal) called by a button.
The problem is that this call to this module seems to get rid of all the scrollbars for the main page of the app (so I can't scroll to the bottom of the main page (it is a one page app).
How can I limit the html of the module to prevent it from overriding the rest of the app? The code for the module being called is here.
My reproducible example follows:
ui.R
library(shiny)
library(esquisse)
library(shinyBS)
ui <- fluidPage(
dashboardPage(
dashboardHeader(title = ''),
dashboardSidebar(
sidebarMenu(
menuItem("Dashboard")
)),
dashboardBody(
actionButton(inputId = "esquissGraphs",label = "esquissGraphs"),
DT::dataTableOutput("mytable"),
bsModal("modalExample", "Data Table", "esquissGraphs", size = "large",
tags$h1("Use esquisse as a Shiny module"),
radioButtons(
inputId = "data",
label = "Data to use:",
choices = c("Mydftbbinnit", "mtcars"),
inline = TRUE
),
tags$div(
style = "height: 700px;", # needs to be in fixed height container
esquisserUI(
id = "esquisse",
header = FALSE, # dont display gadget title
choose_data = FALSE # dont display button to change data
)
)
)
)
)
)
server.R
RV <- reactiveValues(data = data.frame())
RV2 <- reactiveValues(data = data.frame())
server <- function(input, output, session) {
n<-c("1","434","101")
t<-c("Bugs","Mugs","Thugs")
RV$data<-data.frame(n,t,stringsAsFactors = FALSE)
o<-c("1","434","101")
p<-c("Bugs","Mugs","Thugs")
RV2$data<-data.frame(o,p,stringsAsFactors = FALSE)
output$mytable = DT::renderDataTable({
mtcars
})
data_r <-reactiveValues(data = data.frame())
observeEvent(input$data, {
if (input$data == "Mydftbbinnit") {
data_r$data <- RV$data
data_r$name <- "Mydftbbinnit"
} else {
data_r$data <- RV2$data
data_r$name <- "The rest"
}
})
callModule(module = esquisserServer, id = "esquisse", data = data_r)
}
shinyApp(ui, server)
You need to add
tags$style("html, body {overflow: visible !important;")
in your UI to force scrollbar to appear.
Source : https://github.com/dreamRs/esquisse/blob/master/R/esquisserUI.R
Full example gives :
library(shiny)
library(shinydashboard)
library(esquisse)
library(shinyBS)
library(shiny)
library(esquisse)
library(shinyBS)
ui <- fluidPage(
dashboardPage(
dashboardHeader(title = ""),
dashboardSidebar(
sidebarMenu(
menuItem("Dashboard")
)
),
dashboardBody(
tags$style("html, body {overflow: visible !important;"),
actionButton(inputId = "esquissGraphs", label = "esquissGraphs"),
DT::dataTableOutput("mytable"),
bsModal("modalExample", "Data Table", "esquissGraphs",
size = "large",
tags$h1("Use esquisse as a Shiny module"),
radioButtons(
inputId = "data",
label = "Data to use:",
choices = c("Mydftbbinnit", "mtcars"),
inline = TRUE
),
tags$div(
style = "height: 700px;", # needs to be in fixed height container
esquisserUI(
id = "esquisse",
header = FALSE, # dont display gadget title
choose_data = FALSE # dont display button to change data
)
)
)
)
)
)
RV <- reactiveValues(data = data.frame())
RV2 <- reactiveValues(data = data.frame())
server <- function(input, output, session) {
n <- c("1", "434", "101")
t <- c("Bugs", "Mugs", "Thugs")
RV$data <- data.frame(n, t, stringsAsFactors = FALSE)
o <- c("1", "434", "101")
p <- c("Bugs", "Mugs", "Thugs")
RV2$data <- data.frame(o, p, stringsAsFactors = FALSE)
output$mytable <- DT::renderDataTable({
mtcars
})
data_r <- reactiveValues(data = data.frame())
observeEvent(input$data, {
if (input$data == "Mydftbbinnit") {
data_r$data <- RV$data
data_r$name <- "Mydftbbinnit"
} else {
data_r$data <- RV2$data
data_r$name <- "The rest"
}
})
callModule(module = esquisserServer, id = "esquisse", data = data_r)
}
shinyApp(ui, server)
I used ShinyBS package to make a popup modal. When I hit view, it pops up a window. Inside of the popup modal is a data table made by the DT package. I wanted to select rows and display the ID number of the row I selected at the bottom of the popup window. However, I don't know what's the correct "Input" name to get it.
The following is my sample code.
#rm(list = ls())
library(DT)
library(shiny)
library(shinyBS)
library(shinyjs)
library(shinydashboard)
# This function will create the buttons for the datatable, they will be unique
shinyInput <- function(FUN, len, id, ...) {inputs <- character(len)
for (i in seq_len(len)) {
inputs[i] <- as.character(FUN(paste0(id, i), ...))}
inputs
}
ui <- dashboardPage(
dashboardHeader(title = "Simple App"),
dashboardSidebar(
sidebarMenu(id = "tabs",
menuItem("Menu Item 1", tabName = "one", icon = icon("dashboard"))
)
),
dashboardBody(
tabItems(
tabItem(tabName = "one",h2("Datatable Modal Popup"),
DT::dataTableOutput('my_table'),uiOutput("popup")
)
)
)
)
server <- function(input, output, session) {
my_data <- reactive({
testdata <- cars
as.data.frame(
cbind(
View = shinyInput(actionButton,
nrow(testdata),
'button_',
label = "View",
onclick = 'Shiny.onInputChange(\"select_button\", this.id)' ),
testdata))
})
output$my_table <- DT::renderDataTable(my_data(),selection = 'single',options = list(searching = FALSE,pageLength = 10),server = FALSE, escape = FALSE,rownames= FALSE)
SelectedRow <- eventReactive(input$select_button,{
as.numeric(strsplit(input$select_button, "_")[[1]][2])
})
observeEvent(input$select_button, {
toggleModal(session, "modalExample", "open")
})
DataRow <- eventReactive(input$select_button,{
iris
})
## I guess my input name is not right
output$y11 = renderPrint(input$popup_rows_selected)
output$popup <- renderUI({
bsModal("modalExample", paste0("Data for Row Number: ",SelectedRow()), "", size = "large",
column(12,
DT::renderDataTable(DataRow()),
h4("The following didn't show when I select the rows"),
verbatimTextOutput('y11')
)
)
})
}
shinyApp(ui, server)
This will work, the event has to be bound to the table id, which you had it for ui element(can contain multiple things)
#rm(list = ls())
library(DT)
library(shiny)
library(shinyBS)
library(shinyjs)
library(shinydashboard)
# This function will create the buttons for the datatable, they will be unique
shinyInput <- function(FUN, len, id, ...) {inputs <- character(len)
for (i in seq_len(len)) {
inputs[i] <- as.character(FUN(paste0(id, i), ...))}
inputs
}
ui <- dashboardPage(
dashboardHeader(title = "Simple App"),
dashboardSidebar(
sidebarMenu(id = "tabs",
menuItem("Menu Item 1", tabName = "one", icon = icon("dashboard"))
)
),
dashboardBody(
tabItems(
tabItem(tabName = "one",h2("Datatable Modal Popup"),
DT::dataTableOutput('my_table'),uiOutput("popup")
)
)
)
)
server <- function(input, output, session) {
my_data <- reactive({
testdata <- cars
as.data.frame(
cbind(
View = shinyInput(actionButton,
nrow(testdata),
'button_',
label = "View",
onclick = 'Shiny.onInputChange(\"select_button\", this.id)' ),
testdata))
})
output$my_table <- DT::renderDataTable(my_data(),selection = 'single',options = list(searching = FALSE,pageLength = 10),server = FALSE, escape = FALSE,rownames= FALSE)
SelectedRow <- eventReactive(input$select_button,{
as.numeric(strsplit(input$select_button, "_")[[1]][2])
})
observeEvent(input$select_button, {
toggleModal(session, "modalExample", "open")
})
DataRow <- eventReactive(input$select_button,{
iris
})
## I guess my input name is not right
output$y11 = renderPrint(input$my_test_rows_selected)
output$my_test <- DT::renderDataTable(DataRow())
output$popup <- renderUI({
bsModal("modalExample", paste0("Data for Row Number: ",SelectedRow()), "", size = "large",
column(12,
dataTableOutput("my_test"),
h4("The following didn't show when I select the rows"),
verbatimTextOutput('y11')
)
)
})
}
shinyApp(ui, server)