I don't understand R's message vs cat vs print vs etc. too deeply, but I'm wondering if it's possible to capture messages and show them in a shiny app?
Example: the following app can capture cat statements (and print statements as well) but not message statements
runApp(shinyApp(
ui = fluidPage(
textOutput("test")
),
server = function(input,output, session) {
output$test <- renderPrint({
cat("test cat")
message("test message")
})
}
))
Cross post from the shiny-discuss Google group since I got 0 answers.
Yihui suggested I use withCallingHandlers, and that indeed let me to a solution. I wasn't quite sure how to use that function in a way that would do exactly what I needed because my problem was that I had a function that printed out several messages one at a time and using a naive approach only printed the last message. Here is the my first attempt (which works if you only have one message to show):
foo <- function() {
message("one")
message("two")
}
runApp(shinyApp(
ui = fluidPage(
actionButton("btn","Click me"),
textOutput("text")
),
server = function(input,output, session) {
observeEvent(input$btn, {
withCallingHandlers(
foo(),
message = function(m) output$text <- renderPrint(m$message)
)
})
}
))
Notice how only two\n gets outputted. So my final solution was to use the html function from shinyjs package (disclaimer: I wrote that package), which lets me change or append to the HTML inside an element. It worked perfectly - now both messages got printed out in real-time.
foo <- function() {
message("one")
Sys.sleep(0.5)
message("two")
}
runApp(shinyApp(
ui = fluidPage(
shinyjs::useShinyjs(),
actionButton("btn","Click me"),
textOutput("text")
),
server = function(input,output, session) {
observeEvent(input$btn, {
withCallingHandlers({
shinyjs::html("text", "")
foo()
},
message = function(m) {
shinyjs::html(id = "text", html = m$message, add = TRUE)
})
})
}
))
I know this isn't nearly as elegant, but I worked around a bit similar problem using capture.output; sadly sink doesn't allow simultaneous capture of messages and output though. You don't get them in the original order, but you can extract both streams at least (here turned to HTML):
runApp(shinyApp(
ui = fluidPage(
uiOutput("test")
),
server = function(input,output, session) {
output$test <- renderUI({
HTML(
paste(capture.output(type = "message", expr = {
message(capture.output(type = "output", expr = {
cat("test cat<br>")
message("test message")
cat("test cat2<br>")
message("test message2")
}))
}), collapse="<br>")
)})
})
)
Output:
test message
test message2
test cat
test cat2
Perhaps in the case if user wants to capture both but also separate them, this will provide a handy work-around. (Your shinyjs package seems neat, need to take a look at it!)
This can now be done with the high-level function shinyCatch from the spsComps package.
Basic usage
library(shiny)
library(spsComps)
ui <- fluidPage(
actionButton("msg", "msg"),
actionButton("warn", "warn"),
actionButton("err", "err"),
)
server <- function(input, output, session) {
observeEvent(input$msg, {
shinyCatch({message("a message")}, prefix = '')
})
observeEvent(input$warn, {
shinyCatch({warning("a warning")}, prefix = '')
})
observeEvent(input$err, {
shinyCatch({stop("an error")}, prefix = '')
})
}
shinyApp(ui, server)
Choose blocking level
If exceptions happened, we can choose to continue the code or block downstream code in the reactive context. For example, we want to stop downstream code if an error/warning/message happens:
library(shiny)
library(spsComps)
ui <- fluidPage(
actionButton("err", "code not blocked after error"),
actionButton("err_block", "code blocked after error"),
)
server <- function(input, output, session) {
observeEvent(input$err, {
shinyCatch({stop("an error")}, prefix = '')
print("error does not block ")
})
observeEvent(input$err_block, {
shinyCatch({stop("an error")}, prefix = '', blocking_level = "error")
print("you can't see me if error happens")
})
}
shinyApp(ui, server)
More advanced use
check website and demo
cat and print
There is still no good method to catch real-time info from cat and print. I will come back to update this answer if I found a fix for this.
Related
The below example code "Code" saves to the browser the user slider input from one session to the next, using package shinyStorePlus. I would like the user to be able to clear the saved inputs via a click of the "clear" actionButton(). When the commented-out code in "Code" is uncommented, revealing the clear function in the server section, clicking that actionButton() results in error Warning: Error in envir$session$sendCustomMessage: attempt to apply non-function. However, if I pull the clear data code of clearStore(appId = appid) out of the observer and run the code this way, it works fine in clearing out the saved browser data. As an example, running the "Isolated Clearing Code" at the very bottom, completely outside the observer, clears out the browser data like it should.
What am I doing wrong here with my use of an observer? I've fooled around with using isolate(), making the appid reactive, etc., and nothing seems to work.
Code:
library(shiny)
library(shinyStorePlus)
ui <- fluidPage(
initStore(), br(),
sliderInput("input1",label=NULL,min=1,max=200,value=100),
actionButton("clear","Clear data")
)
server <- function(input, output, session) {
appid <- "application001"
setupStorage(
appId = appid,
inputs = list("input1")
)
# observeEvent(input$clear,{
# clearStore(appId = appid)
# })
}
shinyApp(ui, server)
Isolated Clearing Code:
ui <- fluidPage(
initStore(),
)
server <- function(input, output, session) {
appid <- "application001"
clearStore(appId = appid)
}
shinyApp(ui, server)
This seems to be an issue with shinyStorePlus' code:
> clearStore
function (appId)
{
envir <- parent.frame()
envir$session$sendCustomMessage("clearStorage", appId)
}
using parent.frame() to get the session is unfavorable.
Please check the following instead:
library(shiny)
library(shinyStorePlus)
clearStore <- function(appId, session = getDefaultReactiveDomain()){
session$sendCustomMessage("clearStorage", appId)
}
ui <- fluidPage(
initStore(), br(),
sliderInput("input1",label=NULL,min=1,max=200,value=100),
actionButton("clear","Clear data")
)
server <- function(input, output, session) {
appid <- "application001"
setupStorage(
appId = appid,
inputs = list("input1")
)
observeEvent(input$clear,{
clearStore(appId = appid)
})
}
shinyApp(ui, server)
I left a PR here.
The scenario I'm emulating with the below minimal example is allowing a user to engage with a Shiny App (click the numericInput control and see server-side events occur) while a long-running download is occurring (simulated with Sys.sleep(10) within downloadHandler).
In a synchronous setting, when the "Download" button is clicked, the user can still interact with UI elements, but other Shiny calculations (in this case, renderText), get put in a queue. I'd like the asynchronous setting, where the download occurs in the background, and users can still interact with the UI elements and get desired output (e.g. renderText).
I'm using callr::r_bg() to achieve asynchronicity within Shiny, but the issue is that my current code of the downloadHandler is incorrect (mtcars should be getting downloaded, but the code is unable to complete the download, 404 error message), I believe it's due to the specific way in which downloadHandler expects the content() function to be written, and the way I've written callr::r_bg() is not playing nicely with that. Any insights would be appreciated!
Reference:
https://www.r-bloggers.com/2020/04/asynchronous-background-execution-in-shiny-using-callr/
Minimal Example:
library(shiny)
ui <- fluidPage(
downloadButton("download", "Download"),
numericInput("count",
NULL,
1,
step = 1),
textOutput("text")
)
server <- function(input, output, session) {
long_download <- function(file) {
Sys.sleep(10)
write.csv(mtcars, file)
}
output$download <- downloadHandler(
filename = "data.csv",
content = function(file) {
x <- callr::r_bg(
func = long_download,
args = list(file)
)
return(x)
}
)
observeEvent(input$count, {
output$text <- renderText({
paste(input$count)
})
})
}
shinyApp(ui, server)
I figured out a solution, and learned the following things:
Because downloadHandler doesn't have a traditional input$X, it can be difficult to include reactivity in the traditional way. The workaround was to present the UI as a hidden downlodButton masked by an actionButton which the user would see. Reactivity was facilitated in the following process: user clicks actionButton -> reactive updates -> when the reactive finishes (reactive()$is_alive() == FALSE), use shinyjs::click to initiate the downloadHandler
Instead of placing the callr function within the downloadHandler, I kept the file within the content arg. There seems to be some difficulties with scoping because the file needs to be available within the content function environment
I'm using a reactive function to track when the background job (the long-running computation) is finished to initiate the download using the syntax: reactive()$is_alive()
The invalidateLater() and toggling of a global variable (download_once) is important to prevent the reactive from constantly activating. Without it, what will happen is your browser will continually download files ad infinitum -- this behavior is scary and will appear virus-like to your Shiny app users!
Note that setting global variables is not a best practice for Shiny apps (will think of a better implementation)
Code Solution:
library(shiny)
library(callr)
library(shinyjs)
ui <- fluidPage(
shinyjs::useShinyjs(),
#creating a hidden download button, since callr requires an input$,
#but downloadButton does not natively have an input$
actionButton("start", "Start Long Download", icon = icon("download")),
downloadButton("download", "Download", style = "visibility:hidden;"),
p("You can still interact with app during computation"),
numericInput("count",
NULL,
1,
step = 1),
textOutput("text"),
textOutput("did_it_work")
)
long_job <- function() {
Sys.sleep(5)
}
server <- function(input, output, session) {
#start async task which waits 5 sec then virtually clicks download
long_run <- eventReactive(input$start, {
#r_bg by default sets env of function to .GlobalEnv
x <- callr::r_bg(
func = long_job,
supervise = TRUE
)
return(x)
})
#desired output = download of mtcars file
output$download <- downloadHandler(filename = "test.csv",
content = function(file) {
write.csv(mtcars, file)
})
#output that's meant to let user know they can still interact with app
output$text <- renderText({
paste(input$count)
})
download_once <- TRUE
#output that tracks progress of background task
check <- reactive({
invalidateLater(millis = 1000, session = session)
if (long_run()$is_alive()) {
x <- "Job running in background"
} else {
x <- "Async job in background completed"
if(isTRUE(download_once)) {
shinyjs::click("download")
download_once <<- FALSE
}
invalidateLater(millis = 1, session = session)
}
return(x)
})
output$did_it_work <- renderText({
check()
})
}
shinyApp(ui, server)
Thanks #latlio for your great answer. I think it cloud be easily improved.
invalidateLater should be used very carefully and only WHEN needed. I use invalidateLater only once and moved it to the logical part where we are waiting for the result. Thus we are NOT invalidating the reactivity infinitely.
library(shiny)
library(callr)
library(shinyjs)
ui <- fluidPage(
shinyjs::useShinyjs(),
#creating a hidden download button, since callr requires an input$,
#but downloadButton does not natively have an input$
actionButton("start", "Start Long Download", icon = icon("download")),
downloadButton("download", "Download", style = "visibility:hidden;"),
p("You can still interact with app during computation"),
numericInput("count",
NULL,
1,
step = 1),
textOutput("text"),
textOutput("did_it_work")
)
long_job <- function() {
Sys.sleep(5)
}
server <- function(input, output, session) {
#start async task which waits 5 sec then virtually clicks download
long_run <- eventReactive(input$start, {
#r_bg by default sets env of function to .GlobalEnv
x <- callr::r_bg(
func = long_job,
supervise = TRUE
)
return(x)
})
#desired output = download of mtcars file
output$download <- downloadHandler(filename = "test.csv",
content = function(file) {
write.csv(mtcars, file)
})
#output that's meant to let user know they can still interact with app
output$text <- renderText({
paste(input$count)
})
#output that tracks progress of background task
check <- reactive({
if (long_run()$is_alive()) {
x <- "Job running in background"
invalidateLater(millis = 1000, session = session)
} else {
x <- "Async job in background completed"
shinyjs::click("download")
}
return(x)
})
output$did_it_work <- renderText({
check()
})
}
shinyApp(ui, server)
I'm trying to create an app that just adds text to the mainPanel. However, the text output is very slow when adding text.
I'd like to make this instant and fast instead of it taking so much time. Is there a way to make it be processed in the browser instead of going to R?
Code
library(shiny)
ui <- fluidPage(sidebarLayout(
sidebarPanel(textInput("text", label = NULL)),
mainPanel(textOutput("textout"))
))
server <- function(input, output, session) {
output$textout <- renderText({
input$text
})
}
shinyApp(ui, server)
This is due to the way the inputs are used by shiny. In the javascript it has an option with a 'debounce' of 250ms which explains why it only updates after you stop typing for a quarter of a second.
You can override this but it seems to involve writing a replacement for textInput. The crucial bit is the getRatePolicy function in the javascript.
library(shiny)
library(shinyCustom)
textinput_script <- "
<script>
var customTextInputBinding = $.extend({}, Shiny.inputBindings.bindingNames['shiny.textInput'].binding, {
find: function(scope) {
return $(scope).find('input.customTextInput');
},
subscribe: function(el, callback) {
$(el).on('keyup.customTextInputBinding input.customTextInputBinding', function(event) {
callback();
});
$(el).on('focusout.customTextInputBinding', function(event) { // on losing focus
callback();
});
},
unsubscribe: function(el) {
$(el).off('.customTextInputBinding');
},
getRatePolicy: function() {
return {
policy: 'direct'
};
}
});
Shiny.inputBindings.register(customTextInputBinding, 'shiny.customTextInput');
</script>
"
ui <- fluidPage(sidebarLayout(
sidebarPanel(
HTML(textinput_script),
customTextInput("text", label = NULL)
),
mainPanel(textOutput("textout"))
))
server <- function(input, output, session) {
output$textout <- renderText({
input$text
})
}
shinyApp(ui, server)
This is cannibalized from here, and the actual guide for doing this in general is here.
This approach does not go after the cause of the delay (like #pseudospins great answer) but rather uses a crutch. It is a shiny-only solution which is why it may still be of some interest.
It uses the "greedier" reactivePoll. The check function always yields TRUE to make sure that input$text gets evaluated after every polling interval no matter what. The argument intervalMillis can be changed to fit the requirements of the app. Here it is set to 1/10 of a second.
Please note, that this approach is simple and effective but it can make your app very slow if you overdo it. The check argument may be a chance to save resources. You can try storing the length of the last string and compare it to the new state every after every intervalMillis interval. In this simple example, though, I doubt that will help much.
library(shiny)
ui <- fluidPage(sidebarLayout(
sidebarPanel(textInput("text", label = NULL)),
mainPanel(textOutput("textout"))
))
server <- function(input, output, session) {
text <- reactivePoll(intervalMillis = 100, session,
checkFunc = function() TRUE,
valueFunc = function () input$text
)
output$textout <- renderText({
text()
})
}
shinyApp(ui, server)
I have downloaded and would like to incorporate in my R Shiny app the following JavaScript library: GitHub link
As you can see in the snippet below, I have incorporated the sequence-viewer.min.js file in the head of the UI. Additionally, using the tags$div(id="sequence-viewer") I am able to see the corresponding <div> tag in the source of the web page, so up to this point I think everything is fine.
Using the following code, I construct and render a sample Datatable with sequences. From the link of the last column, I would like to dynamically change the value of the var seq=new Sequence(''); with the sequences of the Datatable and draw the result in the sequence-viewer div every time a link is clicked.
library(shiny)
ui <- fluidPage(
theme = shinytheme("yeti"),
useShinyjs(),
useShinyalert(),
tags$head(tags$script(src = "handlebars.js"),
tags$script(src = "sequence-viewer.min.js")),
mainPanel( DT::dataTableOutput("DTtable"),
br(),
tags$div(id="sequence-viewer")
)
)
server <- function(input, output) {
exp1 <- reactive({
tbl <- as.data.frame(c("MALWMPGPGAGSL", "MALKYTFDCVBJUYGFGPGAGSL", "IUYTFVBNMKIUYF"))
names(tbl) <- "Sequence"
tbl$link <- createLink(tbl$Sequence)
return(tbl)
})
createLink <- function(val) {
link <- paste0("<a href='#' onclick='var seq=new Sequence('",val,"'); seq.render('#sequence-viewer');'>Show seq</a>", sep="")
return(link)
}
output$DTtable <- DT::renderDataTable({ exp1()
}, escape = FALSE, options = list(scrollX = TRUE, dom = 'lfrtip', pageLength = 10,
lengthMenu=c(10, 25, 50, 100)), rownames = FALSE)
}
# Run the application
shinyApp(ui = ui, server = server)
I have read many threads and tutorials on how to run custom javascript code in R Shiny, but all the examples that I've found make the call in the ui , not in the server side, could you please advice me how to get the desired output?
NOTE: According to the instructions on github page, the dependencies jquery, handlebars and bootstrap.min.css are required. I suppose that only the handlebars.js has to manually be added given that R Shiny comes already with bootstrap and jquery?
UPDATE 1: Ok, I think I'm now almost there. Thanks to the comments of #YBS I managed to get the idea of how to work with external javascript libraries. The code below works fine if I click the actionLink but it does not work when clicking the custom links inside the Datatable that I create using the createLink function. I get the following exception in the console of the browser: Uncaught ReferenceError: js$seque is not defined. Any ideas why this is happening?
library(shiny)
library(shinyjs)
jsCode = '
shinyjs.seque = function(params) {
var defaultParams = {
seq : "LKJHGFVBJKUGFKGFFGHJKUYTRFGHJUYTGHJIUYT"
};
params = shinyjs.getParams(params, defaultParams);
var seq=new Sequence(params.seq);
seq.render("#sequence-viewer");
}
'
ui <- fluidPage(
useShinyjs(),
extendShinyjs(text = jsCode, functions = c("seque")),
tags$head(tags$script(src = "handlebars.js"),
tags$script(src = "sequence-viewer.min.js")
),
mainPanel( DT::dataTableOutput("DTtable"),
br(),
actionLink(inputId = "action",
label = "action"),
br(),
tags$div(id="sequence-viewer")
)
)
server <- function(input, output) {
exp1 <- reactive({
tbl <- as.data.frame(c("MALWMPGPGAGSL", "MALKYTFDCVBJUYGFGPGAGSL", "IUYTFVBNMKIUYF"))
names(tbl) <- "Sequence"
tbl$link <- createLink(tbl$Sequence)
return(tbl)
})
createLink <- function(val) {
link <- paste0("<a href='#' onclick='js$seque(",val,")' id='",val,"' class='action-button shiny-bound-input'>Show sequence</a>", sep="")
return(link)
}
observeEvent(input$action, {
js$seque("MALKYTFDCVBJUYGFGPGAGSL")
})
output$DTtable <- DT::renderDataTable({
exp1()
}, escape = FALSE, options = list(scrollX = TRUE, dom = 'lfrtip', pageLength = 10,
lengthMenu=c(10, 25, 50, 100)), rownames = FALSE)
}
# Run the application
shinyApp(ui = ui, server = server)
UPDATE 2:
After many hours of debbugging I managed to solve the issue by replacing the onclick='js$seque(",val,")' event of the button in the createLink function with the following: onclick='shinyjs.seque(\"",val,"\")' - or alternatively even clearer onclick='shinyjs.seque(JSON.stringify(val))'
In short, the js$seque call was incorrect at this point, I had to replace this line with shinyjs.seque, namely with the actual name of the function in JS. On the other hand, a typical R actionButton element requires js$seque. I will try to write a clear MRE code and provide it as an answer of this thread.
The usage of shinyjs is an overkill in your case, because you do not want to call the JS function from R but anyways through the client. Thus you can simply use plain JavaScript like in this toy example:
library(shiny)
js <- HTML("seque = function(seq) {
alert(seq);
}")
ui <- fluidPage(tags$head(tags$script(js)),
tags$a(hreg = "#", onclick = "seque('test message')",
"Click me to send test message"))
server <- function(...) {}
shinyApp(ui, server)
Don't get me wrong shinyjs: has its merits, but the typical use case is that you want to trigger JavaScript code from the R side like in this example:
library(shiny)
library(shinyjs)
js_code <- HTML("shinyjs.seque = function(par) {
var def_par = {seq: 'test message'};
par = shinyjs.getParams(par, def_par);
alert(par.seq);
}")
ui <- fluidPage(useShinyjs(),
extendShinyjs(text = js_code, functions = "seque"),
actionButton("click", "Click me to send message"))
server <- function(input, output, session) {
observeEvent(input$click, {
js$seque("test message from R")
})
}
shinyApp(ui, server)
In this example I use shinyjs to call JS directly from R, while in the previous example the JS is called via the onclick.
For your example you could use an actionLink in your table and add an observer and in this you call js$queue but since you will have one link per line this may be tricky (yet not impossible) to code (basically you need dynamic listeners),
Thus, relying on pure JS (onclick) as in your example may be the better option, but then you don't need shinyjs.
I have created an application using R and Shiny and want to output everything that happens in the console to a special status window in the Shiny app.
Here is how the skeleton of the function called by Shiny application looks.
myfunction = function(x,y,path....){
if(...){...}
cat("Reading Database\n")
df = read.csv(...)
cat("Processing\n")
#MORE CODE
}
I want a status bar that shows the progress of the called function by viewing the cat(...) console outputs.
If yes, can it be done without making any changes to the original function (making changes only in server.R and/or ui.R)?
Unfortunately I don't know how to do this with the normal Shiny approach of using reactivity. I tried getting it to work with textOuput+printText but I was unable. I'd love to see other solutions, but here is my solution that uses shinyjs package to update the element instead of using reactivity. I hope this works for you, it's pretty simple.
library(shiny)
library(shinyjs)
calculate <- function() {
lapply(1:5, function(x) {
message(x)
Sys.sleep(0.5)
})
message("Done")
}
runApp(shinyApp(
ui = fluidPage(
shinyjs::useShinyjs(), br(),
actionButton("btn","Click me"), br(), br(),
"Progress:",
tags$pre(id = "progress")
),
server = function(input,output, session) {
observeEvent(input$btn, {
withCallingHandlers({
shinyjs::text("progress", "")
calculate()
},
message = function(m) {
shinyjs::text(id = "progress", text = m$message, add = TRUE)
})
})
}
))