I have been trying to use Futures library in my Shiny code in order to make a particular task asynchronous, which is time taking. The promise handler of this Future object works well in reactive, eventReactive and observeEvent. But when it comes to download handler , it is not working and giving me an error.
The code is as follows. I place the task which is time taking inside the Future.
futureData <- eventReactive(input$generateButton, {
p <- Progress$new(session, min = 0, max = 100)
p$set(value = 20, message = "Fetching data",detail = "This might take a while...")
pwd <- getwd()
future({
setwd(pwd)
generateReport()
}) %>% finally({~p$set(value=100);~p$close()}) %...!%
(function(error) {
print(paste("Unexpected error: ",error,error$message))
})
})
pptData <- eventReactive(futureData(), {
futureData() %...>% {
futureData <- .
# Build Report Naming Convention
pptId <- paste(futureData$pptTitle, gsub(":", "-", Sys.time()),sep = "_")
pptFlName <- paste(pptId, ".pptx", sep = "")
pptFile <- paste("Reports/", pptFlName, sep = "")
return(list(
"pptId"= pptId,
"pptFlName"= pptFlName,
"pptFile"= pptFile
))
}
})
# Download handler on a button click
output$downloadwb <- downloadHandler(
filename = pptData() %...>% `[[`("wbFlName"),
content = function(file) {
file.copy(pptData() %...>% `[[`("wbFile"), file)
})
I get the following error:
Warning: Error in enc2utf8: argument is not a character vector
[No stack trace available]
Could you please help me wit this? Has anyone tried using promise object inside download handler in Shiny?
Related
My shiny app displays 10 different phovotvoltaic systems. For every pv-system the app does the exact same calculations. I use modules in shiny to reduce the amount of lines. The process is like follwing:
The data is loaded from an API (Module)
The data from the api is recalculated (Module)
The data is graphically processed with infoboxes, ggplot etc.
Currently the Code gets executed and the waiting time for loading the API data is very long. I want to reduce the waiting time for the enduser by using the future package.
Currently i dont understand how to implement the future() into my shiny modules.
For example:
API
api <- function(id,df, api_siteid, api_key, startmonth, startdate, url,db_location){ some code }
api(
id = "bb55",
df = read.csv("Anlagen/Barbarastrasse_55-1/bb55.csv"),
api_siteid = "8784240",
api_key = "EY0HXOAH1Y6fgMY912RGGPUGJD5C2G",
startmonth = "apr2029",
startdate <- "20200401",
url = "https://monitoringapi.solaredge.com/site/",
db_location = "Anlagen/barbstreet_55-1/bb55.csv"
)
bb55_act <- read.csv("Anlagen/Barbarastrasse_55-1/bb55.csv")
Module Server
ib_prod_month_pkWp_UI <- function(id){
valueBoxOutput(NS(id,"ib_prod_pkwp_month"))
}
ib_prod_month_pkWp_server <- function(id,df, kwp_size){
moduleServer(id, function(input, output, session){
output$ib_prod_pkwp_month <- renderInfoBox({
result <- df %>%
mutate(timestamp = as.POSIXct(timestamp, format = "%Y-%m-%d %H:%M:%S")) %>%
filter(year(timestamp) == year(Sys.Date()) &
month(timestamp) == month(Sys.Date())) %>%
summarise(kwh = sum(prod) / as.numeric(kwp_size))
valueBox(
subtitle = "Prod. diesen Monat p. kWp",
prettyNum(
result$kwh,
big.mark = ".",
decimal.mark = "," ,
digits = 4,
scientific = FALSE
)
)
})
})
}
ib_prod_today_pkWp_server("bb55_1_ib_prod_pkwp_today", df = bb55_act, kwp_size = bb55_size)
The result of api() is to write the new data into a csv file. After that the csv file gets loaded into bb55_act = df.
This process is repeated for each pv-system. I would like to parallelize the API call beacuse this is the predominant time consuming part of the code.
Thanks for your help!
As far as I can tell, the usage of {future} will only affect the performance if several users are using the app at the same time. Since you are saving the API responses in the local file system, I'd suggest you use callr::r_bg() to run the API requests in a background job and grab the responses using shiny::reactiveFileReader().
See the following example where I made some simplifications
api_args <- list(
list(id = "first_resource", destfile = "~/api_files/destfile1.csv"),
list(id = "second_resource", destfile = "~/api_files/destfile2.csv")
)
make_api_calls <- function() {
lapply(api_args, function(x) {
callr::r_bg(api, x)
})
}
mod_valuebox_server <- function(id) {
moduleServer(id, function(input, output, session) {
df <- reactiveFileReader(api_args[[1]]$destfile)
result <- df %>%
summarise(kwh = sum(prod) / as.numeric(kwp_size))
output$balueBox <- valueBox(result$kwh)
})
}
Simplifications
I assume that the API function has one argument defining the resource to be grabbed and one argument for the download location
The processing takes place in the "valuebox-module"
The "valuebox-module" only renders the results of the first API response
Is there a way to show happenings/errors/warnings from R script which is sourced inside server part of Shiny in Shiny panel?
Following is the sample code which works fine, but I need to see in Shiny if R throws an error while executing sourced GUI_trials2.R and if possible, a window to stream the happenings, like which line of GUI_trials2.R is running currently.
Sample code -
sidebar <- dashboardSidebar(
sidebarMenu(
menuItem("Required Calcs", tabName = "Requirements")
)
)
uibody <- dashboardBody(
tabItems(
tabItem(tabName = "Requirements", h2("Required Calcs")
,dateInput("ME_DATE_output",label=h2("Execution Date"), value="2020-05-29")
,hr()
,actionButton("calculate", "Calculate this" ))
))
ui = dashboardPage(dashboardHeader(title = "Results"), sidebar, uibody)
server = function(input, output) {
ME_DATE_GUI <- reactive({input$ME_DATE_output})
Code_loc <- "K:/Codes/"
observeEvent(input$calculate, {
ME_DATE <- ME_DATE_GUI()
source(paste0(Code_loc,"GUI_trials2.r"), local = TRUE)
})
}
shinyApp(ui, server)
GUI_trials looks like -
# Use ME_DATE from Shiny
ME_DATE <- as.Date(ME_DATE, format="%Y-%m-%d")
year_N_ME_DATE <- format(ME_DATE,"%Y")
month_N_ME_DATE <- format(ME_DATE,"%m")
month_T_ME_DATE <- months(ME_DATE)
# Location for Outputs
Output_DIR <- "K:/Outputs/"
Output_loc <- paste(Output_DIR,month_N_ME_DATE,". ",month_T_ME_DATE, " ",year_N_ME_DATE,"/",sep="")
success <- "Success"
write.csv(success, paste0(Output_loc,"Success.csv"))
Any help is deeply appreciated!
Use withCallingHandlers()
You can wrap your call to source() as follows and use arbitrary code to handle warnings and messages that arise when the code is run. To handle errors you will need to wrap this again in tryCatch() so your app doesn't crash. For example, you could choose to simply send notifications as follows:
tryCatch(
withCallingHandlers(
source(paste0(Code_loc,"GUI_trials2.r"), local = TRUE),
message = function(m) showNotification(m$message, type = "message"),
warning = function(w) showNotification(w$message, type = "warning")
),
error = function(e) showNotification(e$message, type = "error")
)
You can test this by using something like the following code in your GUI_trials2.R script:
for (i in 1:3) {
warning("This is warning ", i)
Sys.sleep(0.5)
message("This is message", i)
Sys.sleep(0.5)
}
stop("This is a fake error!")
Streaming Output in New Window
The easiest way to do this is to pepper your GUI_trials2.R script with informative calls to message() and then use withCallingHandlers() to output these as above. If you want to be more sophisticated and show these messages in a new window, you could do this by updating a modalDialog(), though this would require the shinyjs package. Here is a basic example:
server = function(input, output) {
ME_DATE_GUI <- reactive({input$ME_DATE_output})
# Show a modal that will be updated as your script is run
observeEvent(input$calculate, {
showModal(modalDialog(
shinyjs::useShinyjs(),
title = "Running my R script",
div("You can put an initial message here", br(), id = "modal_status")
))
Code_loc <- "K:/Codes/"
ME_DATE <- ME_DATE_GUI()
# Run the script and use `withCallingHandlers()` to update the modal.
# add = TRUE means each message will be added to all the previous ones
# instead of replacing them.
tryCatch(
withCallingHandlers(
source(paste0(Code_loc,"GUI_trials2.r"), local = TRUE),
message = function(m) {
shinyjs::html("modal_status", paste(m$message, br()), add = TRUE)
},
warning = function(w) {
shinyjs::html("modal_status", paste(w$message, br()), add = TRUE)
}
),
error = function(e) {
shinyjs::html("modal_status", paste(e$message, br()), add = TRUE)
}
)
})
}
Display Code From source()
The echo = TRUE argument to source() will mean that each expression in the file gets printed in the console. Unfortunately, applying handlers to text as it appears in the console isn't possible in R unless it's a message/warning/error, so echo = TRUE won't be of any use here. However, you could define a custom function, similar to source() which will allow you to handle the code as text before it gets evaluated. Here is an example:
# Default handler just prints the code to console, similar
# to `source(echo = TRUE)`
source2 <- function(file, handler = cli::cat_line, local = FALSE) {
# Copy `source()` method of handling the `local` argument
envir <- if (isTRUE(local))
parent.frame()
else if (isFALSE(local))
.GlobalEnv
else if (is.environment(local))
local
else stop("'local' must be TRUE, FALSE or an environment")
# Read each 'expression' in the source file
exprs <- parse(n = -1, file = file, srcfile = NULL, keep.source = FALSE)
# Apply `handler()` to each expression as text, then
# evaluate the expression as code
for (expr in exprs) {
handler(deparse(expr))
eval(expr, envir)
}
# Return nothing
invisible()
}
This will allow you to do anything you like with the code text before
it gets evaluated. E.g. you could apply some pretty HTML formatting and
then output it as a message, which would allow you to use something very similar to the code above, since withCallingHandlers() would handle
these messages for you:
# Define a function to show a message as code-formatted HTML
html_message <- function(msg) {
with_linebreaks <- paste(msg, collapse = "<br/>")
as_code <- sprintf("<code>%s</code>", with_linebreaks)
spaces_preserved <- gsub(" ", " ", as_code)
message(spaces_preserved)
}
# Then use very similar code to the above for `server`, so
# something like -
tryCatch(
withCallingHandlers(
source2(file = paste0(Code_loc,"GUI_trials2.r"),
handler = html_message,
local = TRUE),
# ... Same code as in the above example using normal source()
Bonus: Getting Fancy with HTML
If you want to get really fancy you could add some custom HTML formatting to each of your message/warning/error functions, e.g. you could show errors in red like so:
error = function(e) {
shinyjs::html("modal_status", add = TRUE, sprintf(
'<span style = "color: red;">%s</span><br/>', e$message
))
}
I am looking for some help please to print a reactive value in a Shiny session into a docx with WordR. A very stripped down version of my app is presented below.
The code for the docx template is `r reactive({declared_user()})` (which is bookended with MS Word’s formatting symbols). I don’t know how to show the format symbols or provide the docx template here on SO but that’s the only applicable code.
I have tried numerous ways of wrapping the declared_user() in a reactive context in both the r file and docx but still can’t seem to see either value/user in ‘slt_input’ printing out in rprt_out.docx.
All that prints out is…
function () { .dependents$register() if (.invalidated || .running) { ..stacktraceoff..(self$.updateValue()) } if (.error) { stop(.value) } if (.visible) .value else invisible(.value) }
library(shiny)
library(WordR)
library(officer)
library(dplyr)
ui <- fluidPage(
selectInput('slt_input', 'name', choices = c("god", 'devil')),
actionButton("btn_inline", 'inline')
)
server <- function(input, output, session) {
declared_user <- reactive({
input$slt_input
})
observeEvent(input$btn_inline,{
renderInlineCode("rprt_tmplt.docx", "rprt_out.docx")
})
}
shinyApp(ui, server)
Here is a solution. I think 2 things complicated the issue:
renderInlineCode extracts the R code from the .docx template and uses eval to evaluate the code. Somehow, it couldn't use the correct environment for the evaluation. Therefore I slightly changed the code so that you can pass the environment as an argument to the function.
it still doesn't work to evaluate shiny code. Therefore, I generated a normal variable out of the reactive directly before the docx rendering and use this in the template
library(shiny)
library(WordR)
library(officer)
library(dplyr)
renderInlineCode_2 <- function (docxIn, docxOut, eval_envir = parent.frame(), debug = F)
{
if (debug) {
browser()
}
doc <- officer::read_docx(docxIn)
smm <- officer::docx_summary(doc)
styles <- officer::styles_info(doc)
regx <- "^[ ]*`r[ ](.*)`$"
smm$expr <- ifelse(grepl(regx, smm$text), sub(regx, "\\1",
smm$text), NA)
smm$values <- sapply(smm$expr, FUN = function(x) {
eval(parse(text = x), envir = eval_envir)
})
smm <- smm[!is.na(smm$expr), , drop = F]
i <- 3
for (i in seq_len(nrow(smm))) {
stylei <- switch(ifelse(is.na(smm$style_name[i]), "a",
"b"), a = NULL, b = styles$style_name[styles$style_id ==
paste0(styles$style_id[styles$style_name == smm$style_name[i] &
styles$style_type == "paragraph"], "Char")])
doc <- officer::cursor_reach(doc, keyword = paste0("\\Q",
smm$text[i], "\\E")) %>% officer::body_remove() %>%
officer::cursor_backward() %>% officer::slip_in_text(smm$values[i],
pos = "after", style = stylei)
}
print(doc, target = docxOut)
return(docxOut)
}
ui <- fluidPage(
selectInput('slt_input', 'name', choices = c("god", 'devil')),
actionButton("btn_inline", 'inline')
)
server <- function(input, output, session) {
declared_user <- reactive({
input$slt_input
})
observeEvent(input$btn_inline,{
eval_user <- declared_user()
renderInlineCode_2("rprt_tmplt.docx", "rprt_out.docx")
})
}
shinyApp(ui, server)
In the template, use:
`r eval_user`
Edit
When thinking a bit more about it, I think in the original renderInlineCode function the parent.frame() of eval is renderInlineCode. Obviously, there the required objects are not included but in its parent.frame(). So you have to relay on R's scoping which doesn't work correctly here with shiny. I'm happy to get some more thorough explanations.
I have a function (clawCheck) defined in the file CheckClawback.R which takes three data frames as arguments. In my Shiny app, the user uploads three files which are then read into memory and used as the ClawCheck arguments. In order to save time, I want R to start reading a file into memory as soon as it is uploaded, and not only after the "GO" button is pressed, so that once the button is pressed, the arguments for ClawCheck are already in memory and ready to use.
I'm thinking that I have to use eventReactive expressions within the renderTable statement, since I don't want the files to be re-read every time a user changes some input. To avoid further complication, I assume the input is filled in in order, i.e first "account", then "commpaid", then "termriders". When I run the app and the first input file has been uploaded, there is no progress bar appearing which indicates that my code is not working correctly. Here is my (reduced) code:
library('shiny')
source("CheckClawback.R")
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
fileInput("account", "Account File (.csv)"),
fileInput("commpaid", "CommPaid File (.txt)"),
fileInput("termriders", "TermRiders File (.txt)"),
actionButton("do", "GO!")),
mainPanel(
tableOutput("out_table"))
)
)
server <- function(input, output) {
func <- eventReactive(input$do, {
req(acc)
req(comm)
req(term)
datat <<- clawCheck(acc, comm, term)
})
output$out_table <- renderTable({
eventReactive(input$account, {
withProgress(message = "Preparing Account Data...Please Wait", {
acc <<- read.csv(input$account$datapath, header = TRUE, sep = ",")
})
})
eventReactive(input$commpaid, {
withProgress(message = "Preparing CommPaid Data...Please Wait", {
comm <<- read.table(input$commpaid$datapath, header = TRUE, sep = "\t")
})
})
eventReactive(input$termriders, {
withProgress(message = "Preparing TermRiders Data...Please Wait", {
term <<- read.table(input$termriders$datapath, header = TRUE, sep = "\t")
})
})
withProgress(func(), message = "Loading Output...Please Wait")
datat
})
}
shinyApp(ui = ui, server = server)
Ideally, after a file is uploaded, a progress bar should appear, indicating that it is being processed. If, during this process, a second file is uploaded, a second progress bar should appear, indicating that the second file is being processed etc. Once the actual function call happens, I want the input files to be ready to go.
I am very thankful for any help!
Your use of <<- and withProgress() is wrong. Also, using eventReactive() inside a render*() is wrong. I suggest going through RStudio Shiny tutorials to get help on understanding how reactivity works. Also look at showNotification() instead of withProgress(). For now, here's what you probably need -
server <- function(input, output, session) {
acc <- reactive({
validate(need(input$account), "acc not uploaded")
# use showNotification(); use same approach for other files
read.csv(input$account$datapath, header = TRUE, sep = ",")
# use removeNotification() to remove mesg after file is uploaded
})
comm <- reactive({
validate(need(input$commpaid), "comm not uploaded")
read.table(input$commpaid$datapath, header = TRUE, sep = "\t")
})
term <- reactive({
validate(need(input$termriders), "term not uploaded")
read.table(input$termriders$datapath, header = TRUE, sep = "\t")
})
func <- eventReactive(input$do, {
clawCheck(acc(), comm(), term())
})
output$out_table <- renderTable({
func()
})
}
I have simplified a lot the shiny app I'm trying to build, but, in the idea, I have two functions :
choose_input <- function(n1,n2,n3){
x1 <<- n1+n2
x2 <<- n2+n3
x3 <<- (n1*n2)/n3
}
createmydata <- function(n){
c1 <- c(1:n)
c2 <- c1+(x2*x3)
c3 <- c2+x1
df <- data.frame("column1"=c1,"column2"=c2,"column3"=c3)
return(df)
}
You'll tell me that I can do simply one function with these two because they are very simple, but in my app there are a lot of lines and I have to separate the two. Anyway, here is my simulated code :
ui <- fluidPage(
numericInput("n1",label="Choose the first parameter",min=0,max=100,value=3),
numericInput("n2",label="Choose the second parameter",min=0,max=100,value=4),
numericInput("n3",label="Choose the third parameter",min=0,max=100,value=5),
numericInput("n",label="Choose dataframe length",min=1,max=10000,value=100),
radioButtons("filetype", "File type:",
choices = c("csv", "tsv")),
downloadButton('downloadData', 'Download'),
tableOutput("data")
)
server <- function(input,output){
RE <- reactive({
choose_input(input$n1,input$n2,input$n3)
createmydata(input$n)
})
output$data <- renderTable({
RE()
})
output$downloadData <- downloadHandler(
filename = function() {
paste(name, input$filetype, sep = ".")
},
content = function(file) {
sep <- switch(input$filetype, "csv" = ",", "tsv" = "\t")
write.table(RE(), file, sep = sep,
row.names = FALSE)
}
)
}
shinyApp(ui = ui, server=server)
As you can see, I'd like to download the output table to a csv or excel file... I let you try the code and then try to click on the download button, it does not work...
Debugging
When I run the code up above and attempted to download the data set, I received the following warning and error message in the Console Pane within RStudio.
Warning: Error in paste: object 'name' not found
Stack trace (innermost first):
1: runApp
Error : object 'name' not found
This led me to examine the paste() function used within the filename argument in shiny::downloadHandler(). In your code, you use the object name without ever assigning it a value.
I replaced name with the text "customTable" within the filename argument inside of downloadHandler().
output$downloadData <- downloadHandler(
filename = function() {
paste( "customTable", input$filetype, sep = ".")
},
content = function(file) {
sep <- switch(input$filetype, "csv" = ",", "tsv" = "\t")
write.table(RE(), file, sep = sep,
row.names = FALSE)
}
)
Downloading Data in Browser
After running the app.R script, I clicked on the Open in Browser button to view the Shiny app in a new tab on Chrome. Once there, I was successfully able to download both a .csv and .tsv file after hitting the download button.
Note: I'm looking for a better reason as to why this action needs to occur, but for now, I came across this relevant SO post Shiny app: downloadHandler does not produce a file.