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
Related
I'm creating a simple GUI in Shiny for reading in a bunch of csv files and then filtering them by values present in the 5th column of each csv. I'm not sure how to access the correct shiny environment however. For example, within the server function, I first read the files in with the lines:
for (i in all_paths) {
n <- basename(i)
temp = list.files(path = i, pattern="*.csv",full.names = TRUE)
list2env(
lapply(setNames(temp, make.names(gsub(".*FRSTseg*", n, temp))),
read.csv), envir = .GlobalEnv)
}
And then filter with:
Pattern1<-grep("*.csv",names(.GlobalEnv),value=TRUE)
all_data<-do.call("list",mget(Pattern1))
newdfs <- lapply(all_data, function(x) subset(x, x[, 5] > 0))
list2env(newdfs,globalenv())
When I run the app, I get en error message saying it can't find the value of one of my csvs, which I have found to be the first element of the Pattern1 list. So I'm pretty sure the app fails right after the Pattern1 line.
I think the problem is that the csv files are not being read into the correct environment, such that the all_data <- do.call... line does not know where to look. So instead of using .GlobalEnv and globalenv, what should I be using? Any help is appreciated, thanks!
We can use reactiveValues and store the result of read_csv to be available across all observers in the app. I created a small app that reads the 5th column of different .csv files located in the project directory. In this case all the data will be stored inside an object called column_read$files that can be invoked inside any observer or reactive.
app:
library(tidyverse)
library(shiny)
set.seed(15)
#create the data
paste0('iris', 1:5, '.csv') %>%
map(~write_csv(x = slice_sample(iris,n = 10), .x))
ui <- fluidPage(
actionButton('read_files', "Read Files"),
textOutput('columns_print')
)
server <- function(input, output, session) {
columns_read <- reactiveValues(files = NULL)
observeEvent(input$read_files, {
files <- list.files(pattern = "*.csv",full.names = TRUE)
columns_read$files <- map(files, ~read_csv(.x, col_select = 5))
})
output$columns_print <- renderPrint({
req(columns_read$files)
columns_read$files
})
}
shinyApp(ui, server)
I have a shiny app which has many text inputs. I could not get the save data part right, for example, to save to a local drive. Any suggestions?
server = function(input, output) {
values <- reactiveValues()
#Initial Dataframe
values$df <- data.frame(matrix(ncol=4,nrow=0, dimnames=list(NULL, c("Name", "date","Traning", "certificate"))))
FinalData =observe({
if(input$submit >0) {
isolate(values$df <- rbind(values$df,data.frame("name" = input$name,"date" = input$date,
"training" = input$training, "certificate" = input$certificate)))
# saveRDS(values$df)
# saveRDS(FinalData)
}})
#display the inputs
output$Combined_table = renderDataTable({values$df})
}
)
Try this demonstration:
library(shiny)
.log <- function(...) message(format(Sys.time(), format = "[ %H:%M:%S ]"), " ", ...)
.read <- function(path) if (file.exists(path)) return(readRDS(path))
shinyApp(
ui = fluidPage(
textInput("txt", "Text: "),
actionButton("btn", "Submit"),
tableOutput("tbl")
),
server = function(input, output, session) {
.log("hello world")
rv <- reactiveValues()
rv$df <- data.frame(row = 0L, word = "a", stringsAsFactors = FALSE)[0,]
observeEvent(req(input$btn), {
.log("submit!")
rv$df <- rbind(rv$df,
data.frame(row = input$btn, word = input$txt,
stringsAsFactors = FALSE))
.log("saveRDS: ", nrow(rv$df))
saveRDS(rv$df, "local.rds")
})
filedata <- reactiveFileReader(1000, session, "local.rds", .read)
output$tbl <- renderTable(filedata())
}
)
The engineering of this app:
I use a reactiveValues like you did, in order to keep the in-memory data. (Note: iteratively adding rows to a frame is bad in the long-run. If this is low-volume adding, then you're probably fine, but it scales badly. Each time a row is added, it copies the entire frame, doubling memory consumption.)
I pre-fill the $df with a zero-row frame, just for formatting. Nothing fancy here.
observe and observeEvent do not return something you are interested in, it should be operating completely by side-effect. It does return something, but it is really only meaningful to shiny internals.
saveRDS as you do, nothing fancy, but it works.
I added a shiny::reactiveFileReader in order to demonstrate that the file was being saved. When the shiny table shows an update, it's because (1) the data was added to the underlying frame; (2) the frame was saved to the "local.rds" file; then (3) reactiveFileReader noticed that the underlying file exists and has changed, causing (4) it to call my .read function to read the contents and return it as reactive data into filedata. This block is completely unnecessary in general, just for demonstration here.
I create a function .read for this reactiveFileReader that is resilient to the file not existing first. If the file does not exist, it invisibly returns NULL. There may be better ways to do this.
I built a (complex) shiny app. The user uploads some data, creates plots, does some time consuming calculations, etc.
All necessary data will be stored in a model object model (R6). In order to continue the work in the future, the user can download this model object (with saveRDS) and upload it again whenever he wants.
The drawback: Since the whole R6 model object model will be saved you could easily load it with readRDS and read the whole code structure of the model object. This isn't the result I wanted, but it's still acceptable.
The other point is more about a security question: Someone could change the code of the model object and upload it. Is it possible to write some piece of R code that would be critical to the server?
To avoid this drawback, I encrypt the model with "cyphr" before saving it with saveRDS. But in this case the file is much bigger! And that's not an acceptable solution.
Are there good ways for saving a shiny state / apps, or encrypt the object in a "light version"?
The following example could be used for saving and uploading (modified) R6 object.
library(shiny)
library(R6)
server <- function(input, output, session) {
test_object <- Test_object$new()
output$download <- downloadHandler(
filename = "test.tst",
content = function(file) {
saveRDS(test_object, file = file)
},
contentType = "TST/tst"
)
observeEvent(input$upload, ignoreInit = T, {
test_object <<- readRDS(input$upload$datapath)
#print id
print(test_object$id)
})
observeEvent(input$print, ignoreInit = T, {
test_object$call_function()
})
}
ui <- function(request) {
fluidPage(
downloadButton("download"),
fileInput("upload", "upload", accept = "tst"),
actionButton("print","print")
)
}
#R6 object
Test_object <- R6Class(classname = "Test_object", lock_objects = T,
public = list(
id = "5",
# Change the content of this list with some critical code
# after reading the test.tst in r with readRDS(), save it with saveRDS and upload it
list = list("Hi", " there!"),
call_function = function(){
print(self$list)
}
)
)
shinyApp(ui = ui, server = server)
Update:
To avoid the security lack that someone could modified the model, I use a SHA256 checksum. Each saved model get an unique ID. The ID and the hash of the corresponding object will be saved in a database.
Something like this:
library(digest)
#R6 object
Test_object <- R6Class(classname = "Test_object", lock_objects = T,
public = list(
id = NULL,
list = list("Hi", " there!"),
call_function = function(){
print(self$list)
}
)
)
## Datebase
database <- list(id = c(0), hash = c(0))
# Object to be saved
new_object <- Test_object$new()
# get next id from db
next_id <- max(database$id) + 1
# set next_id to model
new_object$id <- next_id
# get sha of this object
sha <- digest(new_object, algo = "sha256")
# add id and sha to databse
database$id[length(database$id)+1] <- next_id
database$hash[length(database$hash)+1] <- sha
# write object
saveRDS(new_object, "object.abc")
# If someone uploads this file
uploaded_object <- readRDS("object.abc")
# get id
uploaded_id <- uploaded_object$id
# create sha again
uploaded_sha <- digest(uploaded_object, algo = "sha256")
# compare shas
sha_database <- database$hash[match(uploaded_id, database$id)]
if(uploaded_sha == sha_database) print("Uploaded object is valid!")
Encrypting the RDS file instead of the model object leads to a file that has similar size to the RDS file without encryption. (Using the package 'cyphr')
file = "test_object.abc"
saveRDS(test_object , file = file)
cyphr_key <- cyphr::key_openssl(openssl::aes_keygen())
cyphr::encrypt_file(file, dest = file, key = cyphr_key)
But I would recommend to use both a checksum and the encryption.
I'm having trouble deploying a shiny app to shiny server.
Basically, I have a CSV that updates every morning and I'd like for the shiny app on the server to check if there's been a refresh every five minutes and reactively edit the data and display the plot below.
This data munging (create_issue_spotter_data) takes a relatively long time in R, so I also have a slightly sketchy way of making sure this data refresh does not happen when a new session begins: I have a start variable that checks if it's equal to 1. If it is, it increments so the next time chat_file() is updated, the create_issue_spotter_data function will be called. I'm open to completely removing this if it's poor practice.
When this app is running locally, it works exactly how I want it. However, it does not work on shiny server. The code is posted below:
write.csv(mtcars, 'mtcars.csv')
create_issue_spotter_data = function(df) {
df$new_column = 0
df = df[df$mpg < 20, ]
return(df)
}
ui <- fluidPage(
fluidRow(align = "center", downloadButton("download_btn")),
fluidRow(align = "center", plotOutput("distPlot"))
)
server <- function(input, output) {
start <- 1
file <- reactiveFileReader(
intervalMillis = 1000 * 60 * 5,
session = NULL,
filePath = 'mtcars.csv',
readFunc = readr::read_csv
)
this_df = eventReactive(file(), {
if (start != 1) {
print(paste("Now updating the data. Date:", Sys.time()))
saved_df <<- create_issue_spotter_data(file())
df <- saved_df
} else {
start <<- start + 1
print(paste("Everything's good at", Sys.time()))
df <- saved_df
}
df
})
output$download_btn <- downloadHandler(
filename = paste0(paste("Issue", "Spotter", gsub("-", "_", Sys.Date()), sep = "_"), ".pdf"),
content = function(file) {
pdf(file)
p = build_cluster_viz(this_df(), download = TRUE)
print(p)
dev.off()
}, contentType = "pdf")
output$distPlot <- renderPlot({
plot(this_df()$mpg, this_df()$disp)
})
}
In shiny, it is possible to call client-side callbacks written in javascript from the server's logic. Say in ui.R you have some JavaScript including a function called setText:
tags$script('
Shiny.addCustomMessageHandler("setText", function(text) {
document.getElementById("output").innerHTML = text;
})
')
then in your server.R you can call session$sendCustomMessage(type='foo', 'foo').
Suppose I have a long-running function which returns some data to plot. If I do this normally, the R thread is busy while running this function, and so can't handle additional requests in this time. It would be really useful to be able to run this function using the futures package, so that it runs asynchronously to the code, and call the callback asyncronously. However, when I tried this is just didn't seem to work.
Sorry if this isn't very clear. As a simple example, the following should work until you uncomment the two lines trying to invoke future in server.R. Once those lines are uncommented, the callback never gets called. Obviously it's not actually useful in the context of this example, but I think it would be very useful in general.
ui.R:
library(shiny)
shinyUI(fluidPage(
sidebarLayout(
sidebarPanel(
sliderInput("max",
"Max random number:",
min = 1,
max = 50,
value = 30)
),
mainPanel(
verbatimTextOutput('output'),
plotOutput('plot')
)
),
tags$script('
Shiny.addCustomMessageHandler("setText", function(text) {
document.getElementById("output").innerHTML = text;
})
')
))
server.R:
library(shiny)
library(future)
plan(multiprocess)
shinyServer(function(input, output, session) {
output$plot <- reactive({
max <- input$max
#f <- future({
session$sendCustomMessage(type='setText', 'Please wait')
Sys.sleep(3)
x <- runif(1,0,max)
session$sendCustomMessage(type='setText', paste('Your random number is', x))
return(NULL)
#})
})
})
Here is a solution on how you could use the future package in a shiny app.
It is possible to have multiple sessions with no session blocking another session when running a computationally intensive task or waiting for a sql query to be finished. I suggest to open two sessions (just open http://127.0.0.1:14072/ in two tabs) and play with the buttons to test the functionality.
run_app.R:
library(shiny)
library(future)
library(shinyjs)
runApp(host = "127.0.0.1", port = 14072, launch.browser = TRUE)
ui.R:
ui <- fluidPage(
useShinyjs(),
textOutput("existsFutureData"),
numericInput("duration", "Duration", value = 5, min = 0),
actionButton("start_proc", h5("get data")),
actionButton("start_proc_future", h5("get data using future")),
checkboxInput("checkbox_syssleep", label = "Use Sys.sleep", value = FALSE),
h5('Table data'),
dataTableOutput('tableData'),
h5('Table future data'),
dataTableOutput('tableFutureData')
)
server.R:
plan(multiprocess)
fakeDataProcessing <- function(duration, sys_sleep = FALSE) {
if(sys_sleep) {
Sys.sleep(duration)
} else {
current_time <- Sys.time()
while (current_time + duration > Sys.time()) { }
}
return(data.frame(test = Sys.time()))
}
#fakeDataProcessing(5)
############################ SERVER ############################
server <- function(input, output, session) {
values <- reactiveValues(runFutureData = FALSE, futureDataLoaded = 0L)
future.env <- new.env()
output$existsFutureData <- renderText({ paste0("exists(futureData): ", exists("futureData", envir = future.env)," | futureDataLoaded: ", values$futureDataLoaded) })
get_data <- reactive({
if (input$start_proc > 0) {
shinyjs::disable("start_proc")
isolate({ data <- fakeDataProcessing(input$duration) })
shinyjs::enable("start_proc")
data
}
})
observeEvent(input$start_proc_future, {
shinyjs::disable("start_proc_future")
duration <- input$duration # This variable needs to be created for use in future object. When using fakeDataProcessing(input$duration) an error occurs: 'Warning: Error in : Operation not allowed without an active reactive context.'
checkbox_syssleep <- input$checkbox_syssleep
future.env$futureData %<-% fakeDataProcessing(duration, sys_sleep = checkbox_syssleep)
future.env$futureDataObj <- futureOf(future.env$futureData)
values$runFutureData <- TRUE
check_if_future_data_is_loaded$resume()
},
ignoreNULL = TRUE,
ignoreInit = TRUE
)
check_if_future_data_is_loaded <- observe({
invalidateLater(1000)
if (resolved(future.env$futureDataObj)) {
check_if_future_data_is_loaded$suspend()
values$futureDataLoaded <- values$futureDataLoaded + 1L
values$runFutureData <- FALSE
shinyjs::enable("start_proc_future")
}
}, suspended = TRUE)
get_futureData <- reactive({ if(values$futureDataLoaded > 0) future.env$futureData })
output$tableData <- renderDataTable(get_data())
output$tableFutureData <- renderDataTable(get_futureData())
session$onSessionEnded(function() {
check_if_future_data_is_loaded$suspend()
})
}
I retooled André le Blond's excellent answer to and made a gist showing a generic asynchronous task processor which can be used either by itself or with Shiny: FutureTaskProcessor.R
Note it contains two files: FutureProcessor.R which is the stand alone asynchronous task handler and app.R which is a Shiny App showing use of the async handler within Shiny.
One admittedly complicated workaround to the single-threaded nature of R within Shiny apps is to do the following:
Splinter off an external R process (run another R script located in
the Shiny app directory, or any directory accessible from within the
Shiny session) from within R (I've tried this splintering before,
and it works).
Configure that script to output its results to a temp directory (assuming you're running Shiny on a Unix-based system) and give the output file a unique filename (preferably named within the namespace of the current session (i.e. "/tmp/[SHINY SESSION HASH ID]_example_output_file.RData".
Use Shiny's invalidateLater() function to check for the presence of that output file.
Load the output file into the Shiny session workspace.
Finally, trash collect by deleting the generated output file after loading.
I hope this helps.