Related
I am in the process of creating a shiny app for a process at work and am struggling to figure something out on the UI side of the app. I would like to display a data table next to a sidebar menu containing options for the app. The issue is that when I do so, the data table is pushed down below the sidebar panel instead of beside it (see the original data tab).
I found a work around as seen in the suggested tab, but that comes with its own issues. I need to be able to lock the column headers while scrolling through the app and when the data table is inside the box element, I am unable to find a way to do so.
Here is the code to a simplified version of the app.
library(shiny)
library(lubridate)
library(tidyverse)
library(DT)
library(shinydashboard)
library(shinythemes)
library(sortable)
library(reactlog)
ui<- dashboardPage(
#this gives you the name displayed on the tab
dashboardHeader(title = "HHS Resin Purchasing 0.99"),
#this gives you your sidebar (page) options
dashboardSidebar(
sidebarMenu(
menuItem("Original Data", tabName = "original"),
menuItem("Suggested", tabName = "suggested")
)
),
#this is the body of the webpages
dashboardBody(
#this gives you the body options that are displayed on every page
sidebarPanel(width = 2,
h2("Menu Options"),
h4(strong("Upload Data:")),
fileInput("file", "Data", buttonLabel = "Upload..."),
textInput("delim", "Delimiter (leave blank to guess)", ""),
numericInput("skip", "Rows to skip", 0, min = 0),
h4(strong("User Options:")),
selectInput("plant", "Select a Plant", choices =
c("All")),
dateInput("latest_date", "Select the latest W_LEAD date in the data",
value = Sys.Date()),
numericInput("avg_multiple", "Multiple of Daily Useage for Cuttoff",21, min = 1, max = 50),
h4(strong("Download Options:")),
actionButton("complete_orders", "Analysis for plant orders complete"),
actionButton("complete_checks", "Mid month check complete"),
downloadButton("downloadData1", label = "Download Suggested Orders...", class = "btn-block"),
downloadButton("downloadData2", label = "Download Flags...", class = "btn-block"),
downloadButton("downloadData3", label = "Download Full Suggested Orders Data...", class = "btn-block")
),
#This is the actual data that fills those page options listed above
tabItems(
tabItem(tabName = "original",
DT::dataTableOutput(outputId = "preview1")
),
tabItem(tabName = "suggested",
box(title = "Suggested Orders",width = 9, status = "primary", height = "auto",
solidHeader = T, dataTableOutput("preview2"), style = "max-height:800px; overflow-y: scroll;overflow-x: scroll;")
)
)
)
)
server <- function(input, output) {
output$preview1 <- renderDataTable({
DT::datatable(iris, options = list(searching = T, pageLength = 20, lengthMenu = c(5,10,15, 20))
})
output$preview2 <- renderDataTable({
DT::datatable(iris, options = list(searching = T, pageLength = 20, lengthMenu = c(5,10,15, 20))
})
}
shinyApp(ui, server)
Help in fixing either of the issues outlined above would be very appreciated! Thanks in advance.
I think using the column() function will support your first question of the datatable moving under the sidebar sidebarPanel. Please see example below.
I think the second request of freezing the row header in the datatable can be resolved with the advice found at Freezing header and first column using data.table in Shiny
library(shiny)
library(lubridate)
library(tidyverse)
library(DT)
library(shinydashboard)
library(shinythemes)
library(sortable)
library(reactlog)
ui<- dashboardPage(
#this gives you the name displayed on the tab
dashboardHeader(title = "HHS Resin Purchasing 0.99"),
#this gives you your sidebar (page) options
dashboardSidebar(
sidebarMenu(
menuItem("Original Data", tabName = "original"),
menuItem("Suggested", tabName = "suggested")
)
),
#this is the body of the webpages
dashboardBody(
#this gives you the body options that are displayed on every page
fluidRow(
column(width = 2,
sidebarPanel(width = 2,
h2("Menu Options"),
h4(strong("Upload Data:")),
fileInput("file", "Data", buttonLabel = "Upload..."),
textInput("delim", "Delimiter (leave blank to guess)", ""),
numericInput("skip", "Rows to skip", 0, min = 0),
h4(strong("User Options:")),
selectInput("plant", "Select a Plant", choices =
c("All")),
dateInput("latest_date", "Select the latest W_LEAD date in the data",
value = Sys.Date()),
numericInput("avg_multiple", "Multiple of Daily Useage for Cuttoff",21, min = 1, max = 50),
h4(strong("Download Options:")),
actionButton("complete_orders", "Analysis for plant orders complete"),
actionButton("complete_checks", "Mid month check complete"),
downloadButton("downloadData1", label = "Download Suggested Orders...", class = "btn-block"),
downloadButton("downloadData2", label = "Download Flags...", class = "btn-block"),
downloadButton("downloadData3", label = "Download Full Suggested Orders Data...", class = "btn-block")
)
),
#This is the actual data that fills those page options listed above
column(width = 6,
tabItems(
tabItem(
tabName = "original",
DT::dataTableOutput("preview1",
options = list(dom = 't',
scrollX = TRUE,
paging=FALSE,
fixedHeader=TRUE,
fixedColumns = list(leftColumns = 1, rightColumns = 0)))
),
tabItem(tabName = "suggested",
box(title = "Suggested Orders",width = 9, status = "primary", height = "auto",
solidHeader = T, dataTableOutput("preview2"), style = "max-height:800px; overflow-y: scroll;overflow-x: scroll;")
)
)
)
)
)
)
server <- function(input, output) {
output$preview1 <- renderDataTable({
DT::datatable(iris, options = list(searching = T, pageLength = 20, lengthMenu = c(5,10,15, 20)))
})
output$preview2 <- renderDataTable({
DT::datatable(iris, options = list(searching = T, pageLength = 20, lengthMenu = c(5,10,15, 20)))
})
}
shinyApp(ui, server)
I have a reproducible example below where only the first tabPanel is working, however when I switch to another panel, I don't get any renders (the toggle becomes un-interactable also). I have looked into conditionalPanel however I see them getting done without the use of mainPanel I was wondering if it possible to have tabs where each tab has its own mainPanel , so I can see a different sidebar and an output contained within different tabs. Any help is welcome!
options(scipen = 99999) #converts the sci numbers to their regular format
library(shiny)
library(shinyjs)
library(shinyWidgets)
library(shinyalert)
library(esquisse)
library(DT)
library(dplyr)
#library(devtools)
#library(remotes)
#remotes::install_github("dreamRs/esquisse")
library(hrbrthemes)
library(ggthemes)
library(ggplot2)
library(svglite)
ui <- fluidPage(
shinyjs::useShinyjs(), # enables javascript/jQuery enhanchments
# Create Right Side Text
navbarPage(
title= div(HTML("G<em>T</em>")),
#General reports
tabPanel("General Reports",
shinyWidgets::materialSwitch(inputId = "toggleSidebar", label = "Toggle Panel: ",
value = TRUE, status = "warning"),
sidebarLayout(
# radio/action buttons
sidebarPanel(
id = "Sidebar",
shinyWidgets::prettyRadioButtons(
inputId = "controller",
label = "Choose:",
choices = c("About"= 1,
"iris"= 2),
icon= icon("check"),
selected = 1,
status = "success",
animation="smooth"
),
br(),
br(),
a(actionButton(inputId = "admin_email", label = "Contact",
icon = icon("envelope", lib = "font-awesome")),
href="mailto:xyz#email.us")
),
#panel where output is shown from server
mainPanel(
id = "main_panel",
tabsetPanel(
id = "hidden_tabs",
type = "hidden",
tabPanelBody(
"panel1", "Text coming soon."
),
tabPanelBody(
"panel2",
tabsetPanel(
tabPanel("Data", DT::DTOutput('panel2_data')),
tabPanel(
"DIY Plot",
esquisse::esquisse_ui(
id = "esquisse2",
header = FALSE,
container = esquisseContainer(
width = "100%", height = "760px", fixed = FALSE
),
controls = c("labs", "parameters", "appearance", "filters", "code")
)
)
)
)
)
)
)
),
# monthly reports
tabPanel("Extra General Reports",
shinyWidgets::materialSwitch(inputId = "toggleSidebar", label = "Toggle Panel: ",
value = TRUE, status = "warning"),
sidebarLayout(
# radio/action buttons
sidebarPanel(
id = "Sidebar",
shinyWidgets::prettyRadioButtons(
inputId = "controller",
label = "Choose:",
choices = c("About"= 3,
"mtcars"= 4),
icon= icon("check"),
selected = 3,
status = "success",
animation="smooth"
),
br(),
br(),
a(actionButton(inputId = "admin_email", label = "Contact",
icon = icon("envelope", lib = "font-awesome")),
href="mailto:xyz#email.us")
),
#panel where output is shown from server
mainPanel(
id = "main_panel",
tabsetPanel(
id = "hidden_tabs",
type = "hidden",
tabPanelBody(
"panel3", "Text coming soon."
),
tabPanelBody(
"panel4",
tabsetPanel(
tabPanel("Data", DT::DTOutput('panel4_data')),
tabPanel(
"DIY Plot",
esquisse::esquisse_ui(
id = "esquisse4",
header = FALSE,
container = esquisseContainer(
width = "100%", height = "760px", fixed = FALSE
),
controls = c("labs", "parameters", "appearance", "filters", "code")
)
)
)
)
)
)
)
),
#resizes the navbar tabs/button
tags$head(tags$style(HTML('.navbar-brand {width: 270px; font-size:35px; text-align:left;
font-family: "serif";')))
)
)
server <- function(input, output, session) {
# this event hides the side panel when toggled on/off
observeEvent(input$toggleSidebar, {
shinyjs::toggle(id = "Sidebar", condition = input$toggleSidebar)
if(!isTRUE(input$toggleSidebar)) {
shinyjs::runjs("$('#main_panel').removeClass('col-sm-8').addClass('col-sm-12')")
} else {
shinyjs::runjs("$('#main_panel').removeClass('col-sm-12').addClass('col-sm-8')")
}
})
# here we put all the data
data_sets <- list(df1 = data.frame(),
df2 = iris,
df3 = data.frame(),
df4 = mtcars)
# store current dataset in reactive so we can work with plot panels
data_to_use <- reactiveValues(name = "df", data = data.frame())
# modules only need to be called it once but individually for esquisse
esquisse::esquisse_server(id = "esquisse2", data_rv = data_to_use)
esquisse::esquisse_server(id = "esquisse4", data_rv = data_to_use)
observeEvent(input$controller, {
# skip first panel since it is used to display navigation
updateTabsetPanel(session, inputId= "hidden_tabs", selected = paste0("panel", input$controller))
# enswure value is avilable throught selected tabSet
req(input$controller)
# get current data and df name
data_to_use$data <- data_sets[[as.numeric(input$controller)]]
data_to_use$name <- names(data_sets[as.numeric(input$controller)])
# update table and sum. Use server = FALSE to get full table
output[[paste0('panel', input$controller, '_data')]] <- DT::renderDT(server = FALSE, {
DT::datatable(data_to_use$data,
filter = 'top',
extensions = 'Buttons')})
})
}
#runs the app
shinyApp(ui= ui, server= server)
You have two radioButtons, one for each sidebar, but both of them have the inputId = "controller". Same with inputId = "toggleSidebar". InputIds need to be unique in shiny!
I suggest you either use a single sidebar for the entire app, or since both tabs are essentially identical you can also use modules.
I am trying to make a dynamic UI for my shiny dashboard. Here, I want to show a pickerInput field only when the input in a checkboxGroup is a specific value. For example, when the input from the checkboxGroup field is A, I want to show the pickerInput field, otherwise I want to show a different input field.
Currently, the part of my code looks, using conditionalPanel, like the following:
output$UI_selection <- renderUI({
tagList(
p(tags$i("Define the network")),
checkboxGroupInput(inputId = "choice1",
label = "Make a choice",
choices = list("A", "B")
),
conditionalPanel(condition = "input$choice1 == 'A'",
pickerInput(inputId = "select1",
label = "Select first:",
choices = list(
"Hierarchies" = grouplist_1),
selected = NULL,
options = list(`actions-box` = TRUE, `none-selected-text` = "Select hierarchy", `live-search` = TRUE, title = "Select hierarchy"),
multiple = FALSE
)
)
)
})
However, this doesn't work and shows both the checkboxGroupInput as well as the PickerInput. Does anyone know how to fix this?
The shiny package functions (such as conditionalPanel) translate all of the R language code you supply into JS. Conditions you supply in conditionalPanel need to be interpretable in JS, which uses . in place of $.
You need to replace your condition = "input$choice1 == 'A'" with condition = "input.choice1 == 'A'".
Full working app is here:
library(shiny)
library(shinyWidgets)
ui <- fluidPage(
uiOutput("UI_selection")
)
server <- function(input, output, session) {
output$UI_selection <- renderUI({
tagList(
p(tags$i("Define the network")),
checkboxGroupInput(inputId = "choice1",
label = "Make a choice",
choices = list("A", "B")
),
conditionalPanel(condition = "input.choice1 == 'A'",
pickerInput(inputId = "select1",
label = "Select first:",
choices = list(
"Hierarchies" = c("X","Y","Z")),
selected = NULL,
options = list(`actions-box` = TRUE, `none-selected-text` = "Select hierarchy", `live-search` = TRUE, title = "Select hierarchy"),
multiple = FALSE
)
)
)
})
}
shinyApp(ui, server)
The process_map() function in the server in the R shiny script creates the diagram image as below. My requirement is that there are two attributes "FUN" and "units" that are part of the performance() function. They have standard four values each that are available in the ui code below under PickerInput ID's Case4 and Case5. Currently, I am hard coding the value to create the map, can you help me to use the id's in the server code and make it dynamic such that when I select the value in the PickerInput, the formula fetches the value directly. Thanks and please help.
library(shiny)
library(shinydashboard)
library(bupaR)
library(processmapR)
library(lubridate)
library(dplyr)
library(edeaR)
library(shinyWidgets)
library(DiagrammeR)
ui <- dashboardPage(
dashboardHeader(title = "Diagram Plot",titleWidth = 290),
dashboardSidebar(width = 0),
dashboardBody(
tabsetPanel(type = "tab",
tabPanel("Overview", value = 1,
box(
column(1,
dropdown(
pickerInput(inputId = "resources",
label = "",
choices = c("Throughput Time"),
choicesOpt = list(icon = c("fa fa-bars",
"fa fa-bars",
"fa fa-safari")),
options = list(`icon-base` = "")),
circle = FALSE, status = "primary", icon = icon("list", lib = "glyphicon"), width = "300px"
),
conditionalPanel(
condition = "input.resources == 'Throughput Time' ",
tags$br(),
tags$br(),
tags$br(),
dropdown(
pickerInput(inputId = "Case4",
label = "Select the Process Time Summary Unit",
choices = c("min","max","mean","median"), options = list(`actions-box` = TRUE),
multiple = F),
circle = FALSE, status = "primary", icon = icon("eye-close", lib = "glyphicon"), width = "300px"
),
tags$br(),
tags$br(),
tags$br(),
dropdown(
pickerInput(inputId = "Case5",
label = "Select the Process Time Unit",
choices = c("mins","hours","days","weeks"), options = list(`actions-box` = TRUE),
multiple = F, selected = "days"),
circle = FALSE, status = "primary", icon = icon("eye-close", lib = "glyphicon"), width = "300px"
))),
title = "Process Map",
status = "primary",height = "575", width = "500",
solidHeader = T,
column(10,grVizOutput("State")),
align = "left")
),
id= "tabselected"
)))
server <- function(input, output) {
output$State <- renderDiagrammeR(
{
if(input$resources == "Throughput Time")
patients %>% process_map(performance(FUN = mean,units = "days"))
else
return()
})}
shinyApp(ui, server)
test this:
output$State <- renderDiagrammeR({
if(input$resources == "Throughput Time")
{
if(input$Case4=="mean"){
patients %>% process_map(performance(FUN = mean,units = input$Case5))}
else if(input$case4=="min"){
patients %>% process_map(performance(FUN = min,units = input$Case5))
}else if(input$case4=="max"){
patients %>% process_map(performance(FUN = max ,units = input$Case5))
}else{
patients %>% process_map(performance(FUN = median ,units = input$Case5))
}
}else
return()
})
or you can use this:
patients %>%
process_map(performance(FUN = eval(parse(text=input$Case4)) ,units = input$Case5))
enjoy;)
here is a sample:
library(shiny)
ui <- fluidPage(
selectInput(inputId = "func", label = "Choose The Function", choices = c("mean", "sum", "median"))
,
textOutput("text")
)
server <- function(input, output, session) {
main_data <- reactive({
data.frame(a= rnorm(100), b=rnorm(100) )
})
output$text <- renderText({
df <- main_data()
apply(df,2, FUN = eval(parse(text=input$func)) )
})
}
shinyApp(ui = ui, server = server)
You could use do.call to call a function from its name, see the example below. You can add arguments by adding them in the list in the do.call function, e.g. list(x,units=input$Case5).
library(shiny)
x=c(1,2,3,4,5,6,7)
ui <- fluidPage(
selectInput('select','Select Function: ', choices=c('mean','max','min','median')),
textOutput('text')
)
server <- function(input,output)
{
output$text <- renderText({
result = do.call(input$select, list(x))
paste0('The ', input$select, ' of [', paste(x,collapse=', '),'] is ', result)
})
}
shinyApp(ui,server)
Hope this helps!
I have an shinydashboard app, the app get an filter box and a tabset which show a datatatable depending on filter.
I have a reset button which reset the filters whith shinyjs::reset function, and I want to reset also the tableset and showing the complete table or nothing.
I want also to do it for a valuboxes.
My app is like this :
For server interface I have an basic : output$tableprint_A <- DT::renderDataRable ({})
ui :
body <- dashboardBody(
tabItems(
#### First tab item #####
tabItem(tabName = "fpc",
fluidRow(
infoBoxOutput("kpm_inf", width = 6),
infoBoxOutput(outputId = "fpc_inf", width = 6)
),
fluidRow(
box(title = "Variables filter",
shinyjs::useShinyjs(),
id = "side_panel",
br(),
background = "light-blue",
solidHeader = TRUE,
width = 2,
selectInput("aaa", "aaa", multiple = T, choices = c("All", as.character(unique(fpc$aaa))))
br(),
br(),
p(class = "text-center", div(style = "display:inline-block", actionButton("go_button", "Search",
icon = icon("arrow-circle-o-right"))),
div(style = "display:inline-block", actionButton("reset_button", "Reset",
icon = icon("repeat")))),
p(class = 'text-center', downloadButton('dl_fpc', 'Download Data'))),
tabBox(
title = tagList(),
id = "tabset1",
width = 10,
tabPanel(
"A \u2030 ",
DT::dataTableOutput("tableprint_A"),
bsModal(id = 'startupModal', title = 'Update message', trigger = '',
size = 'large',
tags$p(tags$h2("Last update of A : 01/09/2017",
br(), br(),
"Last update of B : 01/09/2017",
br(), br(),
"Last update of C : 01/09/2017",
style = "color:green", align = "center")))
),
tabPanel(
"B % Table",
DT::dataTableOutput("tableprint_B")),
type = "pills"
)
),
fluidRow(
# Dynamic valueBoxes
valueBoxOutput("info_gen", width = 6)
)
I tried this :
observeEvent(input$reset_button, {
output$tableprint_A <- NULL
})
Edit:
I want something like that, but when I action the search button I want it to appear again :
shinyjs::onclick("reset_button",
shinyjs::toggle(id = "tableprint_A", anim = TRUE))
You should try this out:
output$tableprint_A <- renderDataTable({
if(input$reset_button == 1) {
NULL
}else{
datatable(...)
}
})
if the button is clicked then nothing will be displayed, else the datatable is shown.
[EDIT]
library(shiny)
library(DT)
shinyApp(
ui = fluidPage(selectInput("select", "select", choices = unique(iris$Species), multiple = T),
actionButton("go_button", "Search",
icon = icon("arrow-circle-o-right")),
actionButton("reset_button", "Reset",
icon = icon("repeat")),
DT::dataTableOutput('tbl')),
server = function(input, output) {
values <- reactiveValues(matrix = NULL)
observe({
if (input$go_button == 0)
return()
values$matrix <- iris[iris$Species %in% input$select, ]
})
observe({
if (input$reset_button == 0)
return()
values$matrix <- NULL
})
output$tbl = DT::renderDataTable({
datatable(values$matrix, options = list(lengthChange = FALSE))}
)
}
)