EDIT: The author of the bs4Dash package, David Granjon, recently provided an answer to the question asked in the Github issue referenced below and closed it.
My question is very likely related to this issue in bs4Dash github repo, but no answer was provided there.
The full reproducible codes are at the end of the question
My goal
I am making a modularized Shiny application and am attempting to do it with the bs4Dash package. This is what the application looks like:
Picture 1
The end application has several sections (I only made the Introduction for this example) and each section contains at least one bs4TabCard. The tabcard in the picture above has one uiOutput and one rhandsontableOutput element, which are rendered in the server function. Note that these are both ***Output elements. In the reproducible code for Picture 1 (which you can find at the end of the question), I do not use any module. However, my goal is to use several modules because the application has the potential to become quite large. For this simple example, I try to use two modules: one module for each section (i.e. each bs4TabItem) and one module for each tabcard. This means that the two modules will invariably be nested: the tabcard module will be inside the section module.
Picture 2
The issue
The issue is that when I implement the modules, the ***Output elements are not displayed:
Picture 3
The surprising thing is that ***Input elements are displayed. I made a third module containing a numericInput only and placed it in the second tab of the tabcard. The picture below shows that the numericInput is displayed with no problem:
Picture 4
I did my homework
In this issue, a similar problem is reported, but there has not been any solution offered and my digging around proved unsuccessful. It seems that there is a problem when an output element is placed deep inside several nested containers in bs4Dash.
The reproducible code
Reproducible code for picture 1
library(shiny)
library(bs4Dash)
library(rhandsontable)
shiny::shinyApp(
ui = bs4DashPage(
old_school = FALSE,
sidebar_min = TRUE,
sidebar_collapsed = FALSE,
controlbar_collapsed = FALSE,
controlbar_overlay = TRUE,
title = "Basic Dashboard",
navbar = bs4DashNavbar(),
sidebar = bs4DashSidebar(
sidebarMenu(
bs4Dash::menuItem(
text = "Introduction",
tabName = "tab-introduction",
icon = ""
)
)
),
controlbar = bs4DashControlbar(),
footer = bs4DashFooter(),
body = bs4DashBody(
bs4TabItems(
bs4TabItem(
tabName = "tab-introduction",
bs4TabCard(
id = "tabcard", title = "Tab Card", side = "right",
bs4TabPanel(
tabName = "Tab 1",
uiOutput("ui"),
rHandsontableOutput("hot")
),
bs4TabPanel(
tabName = "Tab 2",
p("Hey")
)
)
)
)
)
),
server = function(input, output) {
output$hot <- renderRHandsontable({ rhandsontable(mtcars[1:10, 1:3]) })
output$ui <- renderUI({
numericInput("num_ui", label = "Num In", value = 15)
})
}
)
Reproducible code for Picture 3 and Picture 4
library(shiny)
library(bs4Dash)
library(rhandsontable)
# Tabcard module ----------------------------------------------------------
mod_tabcard_ui <- function(id){
ns <- NS(id)
bs4TabCard(
id = ns("tabcard"), title = "Tab Card", side = "right",
bs4TabPanel(
tabName = "Tab 1",
uiOutput(ns("ui")),
rHandsontableOutput(ns("hot"))
),
bs4TabPanel(
tabName = "Tab 2",
mod_numinput_ui(ns("num"))
)
)
}
mod_tabcard_server <- function(input, output, session){
output$hot <- renderRHandsontable({ rhandsontable(mtcars[1:10, 1:3]) })
output$ui <- renderUI({
numericInput(session$ns("num_ui"), label = "Num In", value = 15)
})
callModule(mod_numinput_server, "num")
}
# Numeric input module ----------------------------------------------------
mod_numinput_ui <- function(id){
ns <- NS(id)
numericInput(ns("num"), "Num In", 0, 0, 10)
}
mod_numinput_server <- function(input, output, server){
return(reactive({input$num}))
}
# Section module ----------------------------------------------------------
mod_section_ui <- function(id){
ns <- NS(id)
mod_tabcard_ui(id = "tabcard")
}
mod_section_server <- function(input, output, session){
callModule(mod_tabcard_server, id = "tabcard")
}
# The app -----------------------------------------------------------------
shiny::shinyApp(
ui = bs4DashPage(
old_school = FALSE,
sidebar_min = TRUE,
sidebar_collapsed = FALSE,
controlbar_collapsed = FALSE,
controlbar_overlay = TRUE,
title = "Basic Dashboard",
navbar = bs4DashNavbar(),
sidebar = bs4DashSidebar(
sidebarMenu(
bs4Dash::menuItem(
text = "Introduction",
tabName = "tab-introduction",
icon = ""
)
)
),
controlbar = bs4DashControlbar(),
footer = bs4DashFooter(),
body = bs4DashBody(
bs4TabItems(
bs4TabItem(
tabName = "tab-introduction",
mod_section_ui(id = "mod")
)
)
)
),
server = function(input, output) {
callModule(mod_section_server, id = "mod")
}
)
you are missing a namespace in the mod_section_ui module. It should be:
mod_section_ui <- function(id){
ns <- NS(id)
mod_tabcard_ui(id = ns("tabcard"))
}
Related
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")
})
}
)
I am dealing with an issue for several hours, please do not punish me on points. tried pretty much everything was suggested on stack overflow. I use golem library to build up the app, thus please be aware of this aspect. Also, if you want to look on the wider code here is the branch I am working on github:
https://github.com/gabrielburcea/bftb
I put a snippet of the code where the error takes place:
app_server <- function(input, output, session) {
shiny::callModule(mod_tools_server, "tools_path_ui_1")
shiny::callModule(mod_gene_expressions_sign_path_server, "gene_expression_sign_path_ui_1")
shiny::callModule(mod_genomic_server, "genomic_ui_1")
# Your application server logic
}
#' The application User-Interface
#'
#' #param request Internal parameter for `{shiny}`.
#' DO NOT REMOVE.
#' #import shiny
#' #noRd
app_ui <- function(request) {
tagList(
# Leave this function for adding external resources
golem_add_external_resources(),
# Your application UI logic
shinyUI(
navbarPage(
windowTitle = "Page",
title = div(img(src = ".png", height = "30px"), "Toolbox"),
theme = shinythemes::shinytheme("cerulean"),
tabPanel("Toolbox", icon = icon("wrench"),
shinydashboard::dashboardPage(
skin = "black",
header = shinydashboard::dashboardHeader(title = "Toolbox", titleWidth = 300),
shinydashboard::dashboardSidebar(
width = 300 ,
shinydashboard::sidebarMenu(
shinydashboard::menuItem(
"Tools",
tabName = "tools_app",
icon = icon("wrench"),
shinydashboard::menuSubItem(
"Gene Expression/Signature/Pathways",
tabName = "gene_app",
icon = icon("chart-line")
),
shinydashboard::menuSubItem(
"Genomic",
tabName = "genomic_app",
icon = icon("universal-access")
),
)
)
)
),
shinydashboard::dashboardBody(
shinydashboard::tabItems(
shinydashboard::tabItem("tools_app", mod_tools_path_ui("tools_path_ui_1")),
shinydashboard::tabItem("gene_app",mod_gene_expressions_sign_path_ui("gene_expression_sign_path_ui_1")),
shinydashboard::tabItem("genomic_app", mod_genomic_ui("genomic_ui_1"))
}
#' Add external Resources to the Application
#'
#' This function is internally used to add external
#' resources inside the Shiny application.
#'
#' #import shiny
#' #importFrom golem add_resource_path activate_js favicon bundle_resources
#' #noRd
golem_add_external_resources <- function() {
add_resource_path(
"www",
app_sys("app/www")
)
tags$head(
favicon(),
bundle_resources(
path = app_sys("app/www"),
app_title = "bftb"
)
# Add here other external resources
# for example, you can add shinyalert::useShinyalert()
)
}
And I get error such as:
Error: argument "body" is missing, with no default
And with more explanations on the error I get is here:
Error: argument "body" is missing, with no default
Backtrace:
1. bftb::app_ui()
at test-golem-recommended.R:2:2
22. shinydashboard::dashboardPage(...)
23. shinydashboard:::tagAssert(body, type = "div", class = "content-wrapper")
dashboardPage(header, sidebar, body) is missing its body parameter (in your above code dashboardBody isn't called in the right place - note the parenthesis).
Please try the following:
app_server <- function(input, output, session) {
shiny::callModule(mod_tools_server, "tools_path_ui_1")
shiny::callModule(mod_gene_expressions_sign_path_server, "gene_expression_sign_path_ui_1")
shiny::callModule(mod_genomic_server, "genomic_ui_1")
shiny::callModule(mod_epi_server, "epi_ui_1")
shiny::callModule(mod_io_server, "io_ui_1")
shiny::callModule(mod_pharm_server, "pharm_ui_1")
shiny::callModule(mod_cell_server, "cell_ui_1")
shiny::callModule(mod_mouse_server, "mouse_ui_1")
shiny::callModule(mod_hemebase_server, "hemebase_ui_1")
shiny::callModule(mod_multiomics_server, "multiomics_ui_1")
shiny::callModule(mod_other_server, "other_ui_1")
# Your application server logic
}
#' The application User-Interface
#'
#' #param request Internal parameter for `{shiny}`.
#' DO NOT REMOVE.
#' #import shiny
#' #noRd
app_ui <- function(request) {
tagList(
# Leave this function for adding external resources
golem_add_external_resources(),
# Your application UI logic
shinyUI(
navbarPage(
windowTitle = "BFTB Landing Page",
title = div(img(src = "bftb_logo_v8_bare.png", height = "30px"), "AZ Oncology Bioinformatics Toolbox"),
theme = shinythemes::shinytheme("cerulean"),
tabPanel("Toolbox", icon = icon("wrench"),
shinydashboard::dashboardPage(
skin = "black",
header = shinydashboard::dashboardHeader(title = "AZ Oncology Bioinformatics Toolbox", titleWidth = 300),
shinydashboard::dashboardSidebar(
width = 300 ,
shinydashboard::sidebarMenu(
shinydashboard::menuItem(
"Tools",
tabName = "tools_app",
icon = icon("wrench"),
shinydashboard::menuSubItem(
"Gene Expression/Signature/Pathways",
tabName = "gene_app",
icon = icon("chart-line")
),
shinydashboard::menuSubItem(
"Genomic",
tabName = "genomic_app",
icon = icon("universal-access")
),
shinydashboard::menuSubItem(
"Epigenetics",
tabName = "epi_app",
icon = icon("chart-bar")
),
shinydashboard::menuSubItem(
"Immune-oncology",
tabName = "io_app",
icon = icon("heartbeat")
),
shinydashboard::menuSubItem(
"Pharmacology",
tabName = "pharm_app",
icon = icon("plus-square")
),
shinydashboard::menuSubItem(
"Cell line Selection",
tabName = "cell_app",
icon = icon("sellcast")
),
shinydashboard::menuSubItem("Mouse",
tabName = "mouse_app",
icon = icon("paw")),
shinydashboard::menuSubItem(
"Haem Oncology",
tabName = "hemebase_app",
icon = icon("h-square")
),
shinydashboard::menuSubItem("Multiomics",
tabName = "multiomics_app",
icon = icon("list")),
shinydashboard::menuSubItem(
"Other",
tabName = "other_app",
icon = icon("option-horizontal", lib = "glyphicon"))
)
)
),
shinydashboard::dashboardBody(
shinydashboard::tabItems(
shinydashboard::tabItem("tools_app", mod_tools_path_ui("tools_path_ui_1")),
shinydashboard::tabItem("gene_app",mod_gene_expressions_sign_path_ui("gene_expression_sign_path_ui_1")),
shinydashboard::tabItem("genomic_app", mod_genomic_ui("genomic_ui_1")),
shinydashboard::tabItem("epi_app", mod_epi_ui("epi_ui_1")),
shinydashboard::tabItem("io_app", mod_io_ui("io_ui_1")),
shinydashboard::tabItem("pharm_app", mod_pharm_ui("pharm_ui_1")),
shinydashboard::tabItem("cell_app", mod_cell_ui("cell_ui_1")),
shinydashboard::tabItem("mouse_app", mod_mouse_ui("mouse_ui_1")),
shinydashboard::tabItem("hemebase_app", mod_hemebase_ui("hemebase_ui_1")),
shinydashboard::tabItem("multiomics_app", mod_multiomics_ui("multiomics_ui_1")),
shinydashboard::tabItem("other_app", mod_other_ui("other_ui_1"))))
))
)))
}
#' Add external Resources to the Application
#'
#' This function is internally used to add external
#' resources inside the Shiny application.
#'
#' #import shiny
#' #importFrom golem add_resource_path activate_js favicon bundle_resources
#' #noRd
golem_add_external_resources <- function() {
add_resource_path(
"www",
app_sys("app/www")
)
tags$head(
favicon(),
bundle_resources(
path = app_sys("app/www"),
app_title = "bftb"
)
# Add here other external resources
# for example, you can add shinyalert::useShinyalert()
)
}
I am facing a problem with the layout in R Shiny when I use the R Markdown file inside it I get the final result in a wired layout size (small and only in the middle of the screen ) as shown in the following photo:
Attached to you the code:
library(shiny)
library(shinydashboard)
library(knitr)
ui <-
dashboardPage(
dashboardHeader(title ='Virtual Excursion'),
dashboardSidebar( sliderTextInput(
inputId = "mySliderText",
label = "Story line",
grid = TRUE,
force_edges = TRUE,
choices = c('1','2')
)
),
dashboardBody(
fluidRow(
column(9,
box(
title = "Operations ",
closable = FALSE,
width = 9,
status = "primary",
solidHeader = FALSE,
collapsible = TRUE,
uiOutput("operations")
)
)
),
fluidRow(
column(9,
box(
title = "Challenges",
closable = FALSE,
width = 9,
status = "primary",
solidHeader = FALSE,
collapsible = TRUE,
uiOutput("challenges")
)
)
)
)
)
server <- function(input, output,session){
output$operations <- renderUI({
req(input$mySliderText==1)
HTML(markdown::markdownToHTML(knit('trial1.rmd', quiet = TRUE)))
})
}
shinyApp(ui = ui, server = server)
Could you please guide me on how to fix this problem!
The problem is that you are including an full html file within an html page. The conflicts between the two pages is causing the display problem. You need to output an html fragment which excludes the heading. Add fragment.only = TRUE to your markdown render function.
HTML(markdown::markdownToHTML(knit("trial1.rmd", quiet=T),fragment.only = T))
You can also add output: html_fragment in your yaml section inside the rmd file for good measure.
Below is a sample code which takes two inputs: 1) input file and 2) input number of rows. Upon clicking the "Analyze" button the output from the server command return to the "Table" in "Results" tabset. This is a simple example where the command will be executed quickly and switches to the "Results" tabsetpanel.
The below withProgress code only shows the progress bar for the set time and disappears and then the actual code is executed. I would like to show a "Status Message" or "Progress Bar" when the "Analyze" is hit and show as long as the command is run. As long as the progress bar is running the current user (other users can use the app) cannot perform any action from the side bar. Because in the real app, sidebar has more menuItems which does similar tasks like this and each task has a Analyze button. If the user is allowed to browse to sidebar pages and hit Analyze then the app will have overload of performing multiple tasks. Ideally the progress bar functionality should we used with multiple actionButtons.
I read the blogs about async but unable to put right code in the right place. any help is appreciated with a bounty!!
library(shiny)
library(shinydashboard)
sidebar <- dashboardSidebar(width = 200,
sidebarMenu(id = "tabs",
menuItem(
"File", tabName = "tab1", icon = icon("fas fa-file")
)))
body <- tabItem(tabName = "tab1",
h2("Input File"),
fluidRow(
tabPanel(
"Upload file",
value = "upload_file",
fileInput(
inputId = "uploadFile",
label = "Upload Input file",
multiple = FALSE,
accept = c(".txt")
),
checkboxInput('header', label = 'Header', TRUE)
),
box(
title = "Filter X rows",
width = 7,
status = "info",
tabsetPanel(
id = "input_tab",
tabPanel(
"Parameters",
numericInput(
"nrows",
label = "Entire number of rows",
value = 5,
max = 10
),
actionButton("run", "Analyze")
),
tabPanel(
"Results",
value = "results",
navbarPage(NULL,
tabPanel(
"Table", DT::dataTableOutput("res_table"),
icon = icon("table")
)),
downloadButton("downList", "Download")
)
)
)
))
ui <-
shinyUI(dashboardPage(
dashboardHeader(title = "TestApp", titleWidth = 150),
sidebar,dashboardBody(tabItems(body))
))
server <- function(input, output, session) {
file_rows <- reactiveVal()
observeEvent(input$run, {
withProgress(session, min = 1, max = 15, {
setProgress(message = 'Analysis in progress',
detail = 'This may take a while...')
for (i in 1:15) {
setProgress(value = i)
Sys.sleep(0.5)
}
})
system(paste(
"cat",
input$uploadFile$datapath,
"|",
paste0("head -", input$nrows) ,
">",
"out.txt"
),
intern = TRUE)
head_rows <- read.delim("out.txt")
file_rows(head_rows)
})
observeEvent(file_rows(), {
updateTabsetPanel(session, "input_tab", "results")
output$res_table <-
DT::renderDataTable(DT::datatable(
file_rows(),
options = list(
searching = TRUE,
pageLength = 10,
rownames(NULL),
scrollX = T
)
))
})
output$downList <- downloadHandler(
filename = function() {
paste0("output", ".txt")
}, content = function(file) {
write.table(file_rows(), file, row.names = FALSE)
}
)
}
shinyApp(ui = ui, server = server)
Here is a solution based on the (absolutely under-star-ed) library(ipc).
I came across this library due to a question of #Dean Attali, where Joe Cheng mentioned it.
The quick-start guide of the ipc-package gives an example of what you are asking for: AsyncProgress.
Furthermore it provides an example on how to kill a future using AsyncInterruptor.
However, I haven't been able to test it yet.
I worked around the cancel-problem by using #Dean Attali's great package shinyjs to simply start a new session and ignore the old Future (You might be able to improve this, by using AsyncInterruptor).
But nevertheless, I gave your code a Future, dropped your system() cmd because I'm currently running R on Windows and found a way to disable (tribute to #Dean Attali) the analyze button session-wise by giving it session-dependant names:
library(shiny)
library(shinydashboard)
library(ipc)
library(promises)
library(future)
library(shinyjs)
library(datasets)
library(V8)
plan(multiprocess)
header <- dashboardHeader(title = "TestApp", titleWidth = 150)
sidebar <- dashboardSidebar(width = 200,
sidebarMenu(id = "tabs",
menuItem(
"File", tabName = "tab1", icon = icon("fas fa-file")
)))
body <- dashboardBody(useShinyjs(),
fluidRow(column(
12, tabItem(
tabName = "tab1",
h2("Input File"),
textOutput("shiny_session"),
tabPanel(
"Upload file",
value = "upload_file",
fileInput(
inputId = "uploadFile",
label = "Upload Input file",
multiple = FALSE,
accept = c(".txt")
),
checkboxInput('header', label = 'Header', TRUE)
),
box(
title = "Filter X rows",
width = 7,
status = "info",
tabsetPanel(
id = "input_tab",
tabPanel(
"Parameters",
numericInput(
"nrows",
label = "Entire number of rows",
value = 5,
max = 10
),
column(1, uiOutput("sessionRun")),
column(1, uiOutput("sessionCancel"))
),
tabPanel(
"Results",
value = "results",
navbarPage(NULL,
tabPanel(
"Table", DT::dataTableOutput("res_table"),
icon = icon("table")
)),
downloadButton("downList", "Download")
)
)
)
)
)))
ui <- shinyUI(dashboardPage(
header = header,
sidebar = sidebar,
body = body,
title = "TestApp"
))
server <- function(input, output, session) {
output$shiny_session <-
renderText(paste("Shiny session:", session$token))
file_rows <- reactiveVal()
run_btn_id <- paste0("run_", session$token)
cancel_btn_id <- paste0("cancel_", session$token)
output$sessionRun <- renderUI({
actionButton(run_btn_id, "Analyze")
})
output$sessionCancel <- renderUI({
actionButton(cancel_btn_id, "Cancel")
})
paste("Shiny session:", session$token)
observeEvent(input[[run_btn_id]], {
file_rows(NULL)
shinyjs::disable(id = run_btn_id)
progress <- AsyncProgress$new(message = 'Analysis in progress',
detail = 'This may take a while...')
row_cnt <- isolate(input$nrows)
get_header <- isolate(input$header)
future({
fileCon <- file("out.txt", "w+", blocking = TRUE)
linesCnt <- nrow(iris)
for (i in seq(linesCnt)) {
Sys.sleep(0.1)
progress$inc(1 / linesCnt)
writeLines(as.character(iris$Species)[i],
con = fileCon,
sep = "\n")
}
close(fileCon)
head_rows <- read.delim("out.txt", nrows = row_cnt, header=get_header)
progress$close() # Close the progress bar
return(head_rows)
}) %...>% file_rows
return(NULL) # Return something other than the future so we don't block the UI
})
observeEvent(input[[cancel_btn_id]],{
session$reload()
})
observeEvent(file_rows(), {
shinyjs::enable(id = run_btn_id)
updateTabsetPanel(session, "input_tab", "results")
output$res_table <-
DT::renderDataTable(DT::datatable(
req(file_rows()),
options = list(
searching = TRUE,
pageLength = 10,
rownames(NULL),
scrollX = T
)
))
})
output$downList <- downloadHandler(
filename = function() {
paste0("output", ".txt")
},
content = function(file) {
write.table(file_rows(), file, row.names = FALSE)
}
)
}
shinyApp(ui = ui, server = server)
App running:
This question has been answered on a different forum
For future reference, if anyone comes across this question, here's the full answer (I did not come up with this answer, it's by Joe Cheng)
This seems to be the main piece of code you're asking about:
observeEvent(input$run, {
withProgress(session, min = 1, max = 15, {
setProgress(message = 'Analysis in progress',
detail = 'This may take a while...')
for (i in 1:15) {
setProgress(value = i)
Sys.sleep(0.5)
}
})
system(paste(
"cat",
input$uploadFile$datapath,
"|",
paste0("head -", input$nrows) ,
">",
"out.txt"
),
intern = TRUE)
head_rows <- read.delim("out.txt")
file_rows(head_rows)
})
With futures/promises, you need to clearly decide what operations happen inside of the Shiny process, and what operations happen in the future process. In this case, here are the steps that we want to happen, in order:
Show progress message (Shiny process)
Read reactives: input$uploadFile$datapath, input$nrows (Shiny)
Write all but the last nrows to out.txt (future process)
Read out.txt (Could be either, let's say future)
Dismiss progress (Shiny)
Assign result to file_rows (Shiny)
Here's what that looks like:
observeEvent(input$run, {
prog <- Progress$new(session)
prog$set(message = "Analysis in progress",
detail = "This may take a while...",
value = NULL)
path <- input$uploadFile$datapath
nrows <- input$nrows
future({
readLines(path) %>% head(-nrows) %>% writeLines("out.txt")
read.delim("out.txt")
}) %...>%
file_rows() %>%
finally(~prog$close())
})
As long as the future/promise pipeline is the last expression in the observeEvent (which it is in this case, as file_rows() and finally(...) are part of the pipeline) then Shiny will hold off on processing any messages on behalf of the user.
There are two things this solution doesn't address.
Progress messages take a step back; not only are we forced to use the Progress$new() syntax instead of the cleaner withProgress(), but we lost the ability to report on the progress percentage. You can try the new ipc package for a solution to that problem.
This doesn't stop the user from clicking around in the UI; it won't do anything while the async operation is executing, but when the operation is done those interactions will have accumulated in a queue and will be handled in the order that they arrived. If you'd like to actually disable the UI entirely so that they're not able to do anything at all, there's not currently a built-in way to do that in Shiny. Although come to think of it, you might try replacing the use of Progress with showModal(modalDialog(title = "Analysis in progress", "This may take a while...", footer=NULL)); I think that will at least stop mouse clicks.
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)