Run R script after input in Shiny - r

Good morning everyone,
I have a Shiny application that collects 5 inputs from the users and stores them into variables.
Then, I would be able to use another R script that would run based on the information provided by the user.
Here is a sample of my Shiny App :
jscode <- "shinyjs.closeWindow = function() { window.close(); }"
#Define UI for application
ui <- pageWithSidebar(
#App title
headerPanel("Filters applied for Powerpoints"),
#Panel to display the filters
sidebarPanel(
#Select dates
dateInput(inputId = "startDate", label = "Start date : ", value = "2018-12-01", format = "yyyy/mm/dd"),
dateInput(inputId = "endDate", label = "End date : ", value = "2018-12-31", format = "yyyy/mm/dd"),
#Select brand template
selectInput("Brand", label = "Select brand : ", choices = list("Carat" = "Carat", "Amplifi" = "Amplifi", "iProspect" = "iProspect", "Isobar" = "Isobar")),
#Select medium type
selectInput("Medium", label = "Select medium type : ", choices = list("Social Post" = "Social Post", "Display" = "Display", "Programmatic" = "Programmatic", "SEA" = "SEA")),
#Enter the plan ID of your campaign
textInput("Camp", label = "Enter the plan ID of your campaign : ", value = ""),
#Button to close the window, then run script
useShinyjs(),
extendShinyjs(text = jscode, functions = c("closeWindow")),
actionButton("close", "Close and run")
),
mainPanel()
)
#Define server logic
server <- function(input, output, session){
observe({
startDate <<- input$startDate
endDate <<- input$endDate
brand <<- input$Brand
medium <<- input$Medium
campaign <<- input$Camp
})
observeEvent(input$close, {
js$closeWindow()
stopApp()
})
source("C:/Users/RPeete01/Desktop/Automated powerpoints/Datorama R/Datorama reporting R/DatoramaSocial.R")
}
#Run the application
shinyApp(ui = ui, server = server)
I've used the source function but it doesn't work.
If someone has an idea, please let me know.
Thanks a lot,
RĂ©mi

You should take advantage of built in onStop functions in shiny to execute some functions before the stopApp() call
library(shiny)
if (interactive()) {
# Open this application in multiple browsers, then close the browsers.
shinyApp(
ui = basicPage("onStop demo",actionButton("close", "Close and run")),
server = function(input, output, session) {
onStop(function() cat("Session stopped\n"))
observeEvent(input$close, {
stopApp()
})
},
onStart = function() {
cat("Doing application setup\n")
onStop(function() {
cat("Doing application cleanup, your functions go here\n")
})
}
)
}

Instead of creating a function to replace your script, you can source your script by supplying an environment to the local option. This environment must contain the objects needed by your script. Something like that:
mylist <- reactiveVal() # we will store the inputs in a reactive list
observe({ # create the list
mylist(list(
startDate = input$startDate,
endDate = input$endDate,
brand = input$Brand,
medium = input$Medium,
campaign = input$Camp))
})
observeEvent(input$runScript, { # "runScript" is an action button
source("myscript.R", local = list2env(mylist()))
})
EDIT
Here is a full example.
library(shiny)
ui <- fluidPage(
textInput("text", "Enter text", value = "test"),
actionButton("runScript", "Run")
)
server <- function(input, output, session) {
mylist <- reactiveVal() # we will store the inputs in a reactive list
observe({ # create the list
mylist(list(
text = input$text))
})
observeEvent(input$runScript, { # "runScript" is an action button
source("myscript.R", local = list2env(mylist()))
})
}
shinyApp(ui, server)
File myscript.R:
writeLines(text, "output.txt")
When I run the app and click on the button, the file output.txt is correctly created (i.e. the script is correctly sourced).

Your script DatoramaSocial.R should be formulated as a function that takes your 5 input values as arguments. As to the return value, well you haven't told us what you want to do with it. By formulating it as a function I mean wrap everything in DatoramaSocial.R in a function (or several subfunctions). The code for that function can easily reside in the external script file or be pasted before the ui and server statements in your shiny app. If the former, simply include the definitions by calling source('DatoramaSocial.R') before your ui and server statements.
Now, in your server function, you can simply call it as a reaction to changes in the input:
observe({
DatoramaSocial(input$startDate, input$endDate, input$Brand, input$Medium, input$Camp)
})
Although in this case, I recommend inserting an actionbuttonInput and having the user click that when they have selected all their inputs. In which case, update to:
observeEvent(input$actionbutton, ignoreInit=TRUE, {
DatoramaSocial(input$startDate, input$endDate, input$Brand, input$Medium, input$Camp)
})
where actionbutton is the actionbutton's inputId.

Related

Testing of shiny modules containing other modules

In a large Shiny App, I have a lot of modules within other modules. These nested modules also sometimes have input controls, e.g. textInput() or actionButton, which trigger certain events also in the parent module.
The following MWE shows the problem.
The module summaryServer prints a summary of a value, but waits for the reactive from rangeServer, which is triggered by a button. I want a Testing specific for summaryServer with testServer() function from Shiny, but how can I "click" the Button in the contained rangeServer module to continue? Is that something about the Mock Shiny Session?
### TESTING ###
x <- reactiveVal(1:10)
testServer(summaryServer, args = list(var = x), {
cat("var active?", d_act(),"\n")
# -----------------------------
# How to click "go" here?
# -----------------------------
cat("var active?", d_act(), "\n")
})
### The app ###
summaryUI <- function(id) {
tagList(
textOutput(NS(id, "min")),
textOutput(NS(id, "mean")),
textOutput(NS(id, "max")),
rangeUI(NS(id, "range"))
)
}
summaryServer <- function(id, var) {
stopifnot(is.reactive(var))
moduleServer(id, function(input, output, session) {
d_act = reactiveVal("Haha nope")
range_val = rangeServer("range", var = var)
# waits to range_val
observeEvent(range_val(),{
d_act("TRUE")
message(range_val())
output$min <- renderText(range_val()[[1]])
output$max <- renderText(range_val()[[2]])
output$mean <- renderText(mean(var()))
})
})
}
rangeUI = function(id) {
textInput(inputId = NS(id, "go"), label = "Go")
}
rangeServer = function(id, var){
moduleServer(id, function(input, output, session){
# when button gets clicked
eventReactive(input$go,{
range(var(), na.rm = TRUE)
}, ignoreInit = TRUE, ignoreNULL = TRUE)
})
}
library(shiny)
ui <- fluidPage(
summaryUI("sum")
)
server <- function(input, output, session) {
x = reactiveVal(1:10)
summaryServer("sum", x)
}
# shinyApp(ui, server)
That is a tricky one. It works if you set both ignoreInit and ignoreNULL to FALSE but just because then you are not initially dependent on a change of go anymore, which is undesirable.
I do not think it is possible to change go inside of rangeServer when running testServer with summaryServer. You can however use {shinytest} to achieve this. Note that here you invoke and test the entire app. Therefore, when using modules, you have to call elements by their complete id, including namespaces.
(I changed go to an actionButton, everything else stays the same)
rangeUI <- function(id) {
actionButton(inputId = NS(id, "go"),label = "Go")
}
test_that("output updates when reactive input changes", {
# invoke app
app <- shinytest::ShinyDriver$new("app.R")
# initially, the button has`nt been clicked and the outputs are empty
testthat::expect_equal(app$getValue("summary-range-go"), 0)
testthat::expect_equal(app$getValue("summary-min"), "")
# click the button
app$click("summary-range-go")
testthat::expect_equal(app$getValue("summary-range-go"), 1)
# testthat::expect_equal(app$getValue("summary-min"), "1")
# for some reason, the button value increased, hence is clicked,
# but the outputs have not been triggered yet.
# another click fixes that
app$click("summary-range-go")
testthat::expect_equal(app$getValue("summary-min"), "1")
})

How to block or restrict access when a user is already using a Shiny app

I have a Shiny app that uses the Ace editor. Now I would like to have it so that when a first user is using this editor, other users cannot edit the document, but only view the document.
How can this be realized?
The code is:
library(shiny)
library(shinyAce)
library(stringi)
ui <- fluidPage(
br(),
uiOutput("aceEditor1"),
downloadButton('save1', 'Save editor content')
)
server <- function(input, output, session)
{
output$aceEditor1 <- renderUI(
{
aceEditor(outputId = "ace1",
value = paste(stri_rand_lipsum(3), collapse="\n\n"),
mode = "r",
height = "500px",
fontSize = 17,
theme = "chrome",
wordWrap = TRUE)
})
output$save1 <- downloadHandler (
filename = function()
{
"result.txt"
},
content = function(file)
{
write.table(x = input$ace1, file = file, sep = "", row.names = FALSE, col.names = FALSE, quote = FALSE)
}
)
}
shinyApp(ui = ui, server = server)
You can implement this by introducing keys. Essentially, we create a global key variable which is visible to all sessions. When a session starts it takes the key and sets the global variable to be unavailable.
When a new session connects, and attempts to get the key, but it is unavailable.
Within the server function we can check before executing a "critical section" piece of code.
This is essentially the basics of how semiphore flag work.
Finally, when the session ends for the first session, it returns the key to the global variable.
We can also go a step further and use invalidateLater() to periodically check if the key is available.
To run the dummy example below first run this,
write_csv(mtcars,"~/Desktop/data.csv")
And the app is the following:
library(shiny)
key_available <- TRUE
ui <- fluidPage(
br(),
textInput(inputId = "text_input","Text Input"),
actionButton(inputId = "add_col","Add Column"),
dataTableOutput("table_output"),
downloadButton('save1', 'Save editor content')
)
server <- function(input, output, session){
onSessionEnded(function() key_available <<- TRUE)
# Session starts, Read data in
have_key <- FALSE
observe({
invalidateLater(1000)
if(key_available){
key_available <<- FALSE
have_key <<- TRUE
}
})
data_reactive <- eventReactive(c(input$add_col),{
data <- read_csv("~/Desktop/data.csv")
if(have_key){
data[[input$text_input]] <- NA
write_csv(data,"~/Desktop/data.csv")
}
return(data)
})
output$table_output <- renderDataTable({
req(data_reactive())
data_reactive()
})
}
shinyApp(ui = ui, server = server)
Open the first browser window, add a column name in the text box and click on Add Column.
You will notice the column is added. You can continue to do this as this session has the key.
Opening a new browser window simultaneously, and trying to do the above will be unsuccessful. However, if you close the first browser window, you will be able to now edit on the second browser window.

Make an eventReactive execute within a Shiny module

I have a selectInput UI object and I would like, once that is used to select an entry from the drop-down choices, to read an RDS file. The selectInput's choices are paths to different RDS files. The UI module works fine but the server one doesn't. I get input$study and hence input$dataset1, and then once I select an entry from input$datasets1 the app should start reading the RDS file but it doesn't.
How do I trigger the eventReactive expression inside the module to run and then make that RDS file available to the whole app for other modules to use?
load_sce <- function(input, output, session) {
output$sce_objects <- renderUI({
validate(need(input$study, message = FALSE))
withProgress(message = "Getting SCE objects...", {
objects <- FIND SOME FILES
ns <- session$ns
selectInput(inputId = ns("dataset1"),
label = "Select a specifc analysis",
width = "100%",
choices = c("", objects),
selected = "")
})
})
sce1 <- eventReactive(input$dataset1, {
validate(need(input$dataset1, message = FALSE))
withProgress(message = "Reading data...", { readRDS(input$dataset1) })
})
return( reactive({ sce1 }) )
}
I would review the documentation for withProgress and Progress. withProgress is for tasks operating inside of a loop. https://shiny.rstudio.com/reference/shiny/1.2.0/Progress.html
Also, see this example of a module: https://shiny.rstudio.com/articles/modules.html. In order for the dataframe to be returned as a reactive value outside the module, it should be created as a reactive object inside the module and then returned as such. Also, because input$dataset1 is the only reactive value that sce1 is dependent upon, reactive can be used instead of eventReactive. eventReactive is better suited for inputs such as buttons that are not actually used within the reactive expression, but simply server as the trigger for the expression to execute.
load_sce <- function(input, output, session) {
output$sce_objects <- renderUI({
validate(need(input$study, message = FALSE))
objects <- FIND SOME FILES
ns <- session$ns
selectInput(inputId = ns("dataset1"),
label = "Select a specifc analysis",
width = "100%",
choices = c("", objects),
selected = "")
})
sce1 <- reactive({
validate(need(input$dataset1, message = FALSE))
progress <- Progress$new(session, min=0, max=1)
on.exit(progress$close())
progress$set(message = 'Reading data...')
dataset1 <- readRDS(input$dataset1)
progress$set(value = 1)
return(df)
})
return(sce1)
}
SOLVED
I used the following in the module function:
sce1 <- reactive({
validate(need(input$dataset1, message = FALSE))
withProgress(message = "Reading data...", {
dataset1 <- readRDS(input$dataset1)
}) # withProgress
return(dataset1)
}) # reactive
return(sce1)
and called the module in the main app using:
sce1 <- callModule(load_sce, "load_sce_explore")
Now I can pass sce1 to other modules as a function argument (use sce1 not sce1()) or use it in other pieces of code in the main app (but in this case use sce1()).
Thanks

Is there a way to run arbitrary code on objects created in a R Shiny app?

My users would like to run some R scripts using the objects that my Shiny App creates. E.g. if my app creates a new data frame, they would like to run their own analysis using the new data frame.
Is there a way to do that?
Maybe some console-like (interactive) feature in R Shiny?
I found this Access/use R console when running a shiny app, but wondering if there is any other way to do it besides building your own server.
Any input is great appreciated. Thank you!
Here is an example of a very basic console on Shiny. It is based on Dean Attali's code here. The idea is to execute arbitrary code from a textInput with the eval function using the same environment that shiny is using. To test the idea, the variable myDat was created inside the server function and can be used by the user. It should also work with other objects created later. I also enabled the "Enter" key to press the [Run] button using JavaScript, so you don't need click on the button.
It is recommended to enable this console only to trusted users, it is a complete open access to any R command and can be potentially a serious security issue.
library(shiny)
ui <- fluidPage(
# enable the <enter> key to press the [Run] button
tags$script(HTML(
'$(document).keyup(function(event) {
if (event.keyCode == 13) {
$("#run").click();
}
});'
)),
textInput("expr", label = "Enter an R expression",
value = "myDat"),
actionButton("run", "Run", class = "btn-success"),
div( style = "margin-top: 2em;",
uiOutput('result')
)
)
server <- function(input, output, session) {
shinyEnv <- environment()
myDat <- head(iris)
r <- reactiveValues(done = 0, ok = TRUE, output = "")
observeEvent(input$run, {
shinyjs::hide("error")
r$ok <- FALSE
tryCatch(
{
r$output <- isolate(
paste(
capture.output(
eval(parse(text = input$expr), envir = shinyEnv)
),
collapse = '\n'
)
)
r$ok <- TRUE
}
,
error = function(err) {
r$output <- err$message
}
)
r$done <- r$done + 1
})
output$result <- renderUI({
if (r$done > 0 ) {
content <- paste(paste(">", isolate(input$expr)), r$output, sep = '\n')
if (r$ok) {
pre(content)
} else {
pre( style = "color: red; font-weight: bold;", content)
}
}
})
}
shinyApp(ui = ui, server = server)
If you want to make a data frame available to the user in the global environment after running the app, you can use assign(). The following example uses the logic of a shiny widget that can be added as an add-in to RStudio:
shinyApp(
ui = fluidPage(
textInput("name","Name of data set"),
numericInput("n","Number observations", value = 10),
actionButton("done","Done")
),
server = function(input, output, session){
thedata <- reactive({
data.frame(V1 = rnorm(input$n),
V2 = rep("A",input$n))
})
observeEvent(input$done,{
assign(input$name, thedata(), .GlobalEnv)
stopApp()
})
}
)
Keep in mind though that your R thread is continuously executing when a shiny app is running, so you only get access to the global environment after the app stopped running. This is how packages with a shiny interface deal with it.
If you want users to be able to use that data frame while the app is running, you can add a code editor using eg shinyAce. A short example of a shiny App using shinyAce to execute arbitrary code:
library(shinyAce)
shinyApp(
ui = fluidPage(
numericInput("n","Number observations", value = 10),
aceEditor("code","# Example Code.\n str(thedata())\n#Use reactive expr!"),
actionButton("eval","Evaluate code"),
verbatimTextOutput("output")
),
server = function(input, output, session){
thedata <- reactive({
data.frame(V1 = rnorm(input$n),
V2 = rep("A",input$n))
})
output$output <- renderPrint({
input$eval
return(isolate(eval(parse(text=input$code))))
})
}
)
But the package comes with some nice examples, so take a look at those as well.

Saving state of Shiny app to be restored later

I have a shiny application with many tabs and many widgets on each tab. It is a data-driven application so the data is tied to every tab.
I can save the application using image.save() and create a .RData file for later use.
The issue I am having how can I get the state restored for the widgets?
If the user has checked boxes, selected radio buttons and specified base line values in list boxes can I set those within a load() step?
I have found libraries such as shinyURL and shinystore but is there a direct way to set the environment back to when the write.image was done?
I am not sure where to even start so I can't post code.
edit: this is a cross-post from the Shiny Google Group where other solutions have been suggested
This is a bit hacky, but it works. It uses an "internal" function (session$sendInputMessage) which is not meant to be called explicitly, so there is no guarantee this will always work.
You want to save all the values of the input object. I'm getting all the widgets using reactiveValuesToList(input) (note that this will also save the state of buttons, which doesn't entirely make sense). An alternative approach would be to enumerate exactly which widgets to save, but that solution would be less generic and you'd have to update it every time you add/remove an input. In the code below I simply save the values to a list called values, you can save that to file however you'd like (RDS/text file/whatever). Then the load button looks at that list and updates every input based on the value in the list.
There is a similar idea in this thread
library(shiny)
shinyApp(
ui = fluidPage(
textInput("text", "text", ""),
selectInput("select", "select", 1:5),
uiOutput("ui"),
actionButton("save", "Save"),
actionButton("load", "Load")
),
server = function(input, output, session) {
output$ui <- renderUI({
tagList(
numericInput("num", "num", 7),
checkboxGroupInput("chk", "chk", 1:5, c(2,4))
)
})
observeEvent(input$save, {
values <<- lapply(reactiveValuesToList(input), unclass)
})
observeEvent(input$load, {
if (exists("values")) {
lapply(names(values),
function(x) session$sendInputMessage(x, list(value = values[[x]]))
)
}
})
}
)
Now with bookmarking is possible to save the state of your shinyapp. You have to put the bookmarkButton on your app and also the enableBookmarking.
The above example may not work if shiny UI involves date. Here is a minor change for date handling.
library(shiny)
shinyApp(
ui = fluidPage(
dateInput("date", "date", "2012-01-01"),
selectInput("select", "select", 1:5),
uiOutput("ui"),
actionButton("save", "Save"),
actionButton("load", "Load")
),
server = function(input, output, session) {
output$ui <- renderUI({
tagList(
numericInput("num", "num", 7),
checkboxGroupInput("chk", "chk", 1:5, c(2,4))
)
})
observeEvent(input$save, {
values <<- lapply(reactiveValuesToList(input), unclass)
})
observeEvent(input$load, {
if (exists("values")) {
lapply(names(values),
function(x) session$sendInputMessage(x, list(value = values[[x]]))
)
temp=as.character(as.Date(values$date, origin = "1970-01-01"))
updateDateInput(session, inputId="date", label ="date", value = temp)
}
})
}
)

Resources