A secure way of saving shiny sessions? - r

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.

Related

Use parallel processes for API Call use future

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

Fundamental understanding of reactive lists

I wrote a little standard application in R that is running pretty fine.
It scans the *.png files in a folder and extracts some statistics on pixel granularity and colours.
Now it is my idea to transfer this to shiny. Although I once wrote some smaller Shiny-Apps, i never used reactivity intensely.
The basic idea of the here presented code is:
to choose png files from a folder
show the number of chosen images
initiate some calculations on the chosen files after clicking a button
displaying the extracted parameters
I now have critical problems with the basic design of the reactive variables, obviously as my construct in mind is not suitable.
Is there someone who could advise me the basic outline of the shiny construct?
I tried to reduce the code to the bare minimum. I hope one can follow my thoughts.
library (shiny)
options (shiny.maxRequestSize = 250 * 1024^2)
# increase maximum data upload to 250MB
const_Number_of_Variables = 5
# just to keep the number of extracted parameters
# up to date when new parameters will be included
ui <- fluidPage(
# just a simple UI with some basic elements
fileInput ("ui_IMGfiles",
"Choose PNG files",
multiple = TRUE,
accept = c ("image/png",
".png")
),
tag$hr,
tableOutput ("ui_IMGfilelistcontents"),
tag$hr,
textOutput ("imagecount"),
tag$hr,
actionButton ("ui_btn_CalcFeatures", "Calculate image features", class = "btn-warn"),
tag$hr,
tableOutput('IMG_featuretable')
)
IMG_filelist <- reactiveValues (data = NULL)
IMG_features <- reactiveValues (val1 = NULL, val2 = NULL, val3 = NULL, val4= NULL, val5 = NULL, val6 = NULL)
IMG_data <- reactiveValues (data = NULL)
server <- function(input, output) {
observeEvent (input$ui_IMGfiles, {
# input$ui_IMGfiles will be NULL initially. After the user selects
# and uploads files, it will be a data frame with 'name',
# 'size', 'type', and 'datapath' columns. The 'datapath'
# column will contain the local filenames where the data can
# be found.
IMG_filelist$data <- input$ui_IMGfiles
})
output$ui_IMGfilelistcontents <- renderTable({
# if file list is not initialised, return NULL
if (is.null (IMG_filelist$data () ))
return(NULL)
#finally display the list of images
IMG_filelist$data ()
})
output$imagecount <- renderText({
# whenever the file list changes, identify
# the number of elements from the length of list entries
paste0 ("# of files: ", length (IMG_filelist$data () ))
}
)
IMG_data <- observeEvent (input$ui_btn_CalcFeatures, {
# check whether some images are loaded
if (is.null (IMG_filelist)) {IMG_data = NULL}
IMG_files_count = length (IMG_filelist)
# prepare the feature list that will be
# overwritten every time the button is pressed
IMG_data$data = matrix (NaN, nrow = 1, ncol = const_Number_of_Variables)
for (i in 1:IMG_files_count) {
# now read the i'th image from the list and pass it to the evaluation function
aSourceImage = readPNG (IMG_filelist$data [i]$datapath, native = FALSE, info = TRUE)
# extract the desired parameters and attach them to the list
IMG_data$data = rbind ( c ("val1", "Val2", "val3", "Val4", "etc"),
#fn_ExtractTileInformation (aSourceImage, aFileFullPath, aFileName, 128),
IMG_data$data ())
}
})
output$IMG_featuretable <- renderDataTable (img_data$data ())
}
shinyApp (ui, server)

Problem when using Shiny app to save the data

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.

Save/download multiple objects from the app with one save button

Context: I have an app transforming data according to user's choices. It creates a few tables and plots in the process.
Objective: to save some objects created in the process into one new folder with one click on a button.
Previous researches: the code below saves objects using downloadHandler() and some functions as presented here. It does not seems to allow multiple objects to be passed into downloadHandler(). I am aware it is possible to stack these objects in a list and then save it but if possible I would like to avoid doing it and instead get multiple files (like .txt or .png, ...)
Here is a reproductible example with very little data using datasets included in R (mtcars and iris).
library(shiny)
ui <- fluidPage(
downloadButton("save", "Save") # one click on this button to save df1 AND df2 tables in a new folder
)
server <- function(input, output) {
# my real app does multiple changes on datasets based on user choices
df1 = mtcars[1:10,]
df2 = iris[1:10,]
# Now I want to save df1 and df2 objects with 1 click on the "Save" button
output$save = downloadHandler(
filename = function(){ paste("example", ".txt", sep = " ") },
content = function(file) { write.table(df1, file) }
)
}
# Run the application
shinyApp(ui = ui, server = server)
Many thanks for your help and suggestions!
As noted in the comments of the linked post, it's not typically a good idea to change the working directory (and unnecessary in this case). While inconsequential with a small number of files, the paste0 call to create the path doesn't need to be in the for loop as it is vectorized. This also eliminates the need to dynamically grow the fs vector (also generally a bad practice). Lastly, my zip utility wasn't on my path which caused the utils::zip to fail (you can specify the path in the function call, otherwise it checks for the environment variable R_ZIPCMD and defaults to 'zip' assuming it to be on the path).
I generally agree with the accepted answer, but here's an alternative solution using the zip::zipr function instead (also walk instead of the for loop)
library(shiny)
library(purrr)
library(zip)
ui <- fluidPage(
downloadButton("save", "Save") # one click on this button to save df1 AND df2 tables in a new folder
)
server <- function(input, output) {
# my real app does multiple changes on datasets based on user choices
df1 <- mtcars[1:10,]
df2 <- iris[1:10,]
# need to names these as user won't be able to specify
fileNames <- paste0("sample_", 1:2, ".txt")
output$save = downloadHandler(
filename = function(){ paste0("example", ".zip") },
content = function(file) {
newTmpDir <- tempfile()
if(dir.create(newTmpDir)){
# write data files
walk2(list(df1, df2), fileNames,
~write.table(.x, file.path(newTmpDir, .y))
)
# create archive file
zipr(file, files = list.files(newTmpDir, full.names = TRUE))
}
},
contentType = "application/zip"
)
}

Passing reactive data to global environment

I want to use Shiny within RMarkdown for users to upload data (xlsx file).
Then I want to pass all the worksheets as R data frames (w/o reactivity) to run rest of the RMarkdown file.
I mainly want to convert them into data frames so I can use reticulate to run Python code as well.
I've tried this, and it doesn't seem to quite work:
library(dplyr)
library(miniUI)
library(shiny)
library(XLConnect)
launch_shiny <- function() {
ui <- miniPage(
gadgetTitleBar("Input Data"),
miniContentPanel(
fileInput(inputId = "my.file", label = NULL, multiple = FALSE)
)
)
server <- function(input, output, session) {
wb <- reactive({
new.file <- input$my.file
loadWorkbook(
filename = new.file$datapath,
create = FALSE,
password = NULL
)
})
observeEvent(input$done, {
stopApp(c(wb()))
})
}
runGadget(ui, server)
}
test <- launch_shiny()
df1 <- readWorksheet(object = test, sheet = "sheet1")
df2 <- readWorksheet(object = test, sheet = "sheet2")
It throws this error:
Error in (function (classes, fdef, mtable) :
unable to find an inherited method for function ‘readWorksheet’ for signature ‘"list", "character"’
I can return one sheet at a time using stopApp(readWorksheet(object = wb(), sheet = "sheet1")), but I can't seem to return an entire workbook or multiple data frames at the same time.
I don't really want to read in xlsx, save each sheet as csv in working directory, then read those files in again.
Would anyone have a good suggestion on how to get around this?
The documentation of fileInput() states in the details:
datapath
The path to a temp file that contains the data that was
uploaded. This file may be deleted if the user performs another upload
operation.
Meaning that the datapath given in the input variable is a temporary file that is no longer accessible after you close the App, which is what the function readWorksheet will try to do.
So you'll have to read the sheets in the server and return the dataframes somehow.
I did that by defining a second reactive value which is basically a list of dataframes returned by applying lapply on all the sheets in wb, in this case test will be this list of data frames.
There might be other ways (more efficient, or suits your purpose better) to do this, but here it is:
library(dplyr)
library(miniUI)
library(shiny)
library(XLConnect)
launch_shiny <- function() {
ui <- miniPage(
gadgetTitleBar("Input Data"),
miniContentPanel(
fileInput(inputId = "my.file", label = NULL,
multiple = FALSE)
)
)
server <- function(input, output, session) {
wb <- reactive({
new.file <- input$my.file
loadWorkbook(
filename = new.file$datapath,
create = FALSE,
password = NULL
)
})
# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
df_lst <- reactive({
# read all sheets into a list
lapply(getSheets(wb()),
function(sheet){
readWorksheet(object = wb(),
sheet = sheet)
})
})
# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
observeEvent(input$done, {
# get the list of dfs from the app
stopApp(c(df_lst()))
})
}
runGadget(ui, server)
}
test <- launch_shiny()

Resources