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.
Related
I've created a dynamic fileInput in shiny using lapply. When I want to read the file, I've also used lapply in an observer.
The problem of using lapply here is, it is triggered every time I upload a new file and thus, reads all files again and again if a new file is uploaded.
Here I provide a Hello World app. The lapply function depends on an input paramter which I abtracted from for simplicity.
library(shiny)
ui <- fluidPage(
titlePanel("Hello World"),
sidebarLayout(
sidebarPanel(),
mainPanel(
lapply(1:2, function(i) {
fileInput(
paste0("file", i),
label = NULL,
multiple = F,
accept = c(
"text/csv",
"text/comma-separated-values,text/plain",
".csv"
),
buttonLabel = paste("File", i)
)
}),
verbatimTextOutput("list")
)
)
)
server <- function(input, output) {
r <- reactiveValues()
observe({
lapply(1:2, function(i) {
file <- input[[paste0("file",i)]]
if(is.null(file)) return()
isolate({
r$file[[paste(i)]] <- readr::read_csv2(file = file$datapath)
})
})
})
output$list <- renderPrint(reactiveValuesToList(r))
}
shinyApp(ui = ui, server = server)
How to replace the loop or add a requirement to lapply?
While I started down the road of cache-invalidation in the comments, I think something else may work better for you since you have a fixed number of fileInput fields: swap the lapply and observe lines in your code (plus a couple of other tweaks).
server <- function(input, output) {
lapply(paste0("file", 1:2), function(nm) {
observeEvent(input[[ nm ]], {
req(input[[nm]], file.exists(input[[nm]]$datapath))
readr::read_csv2(file = input[[nm]]$datapath)
})
})
}
Explanation:
I'm creating a list of reactive blocks instead of a reactive block operating on a list. This means "file1" won't react to "file2".
I short-cutted the definition of the input names by putting paste0(...) in the data of the lapply instead of in the function, though it'd be just as easy to do
lapply(1:2, function(i) {
nm <- paste0("file", i)
# ...
})
It's important to have nm defined outside of the observeEvent, and it has to do with delayed evaluation and namespace search order. I fell prey to this a few years ago and was straightened out by Joe Cheng: you can't use a for loop, it must be some environment-preserving operation like this.
N.B.: this is a stub of code, and it is far from complete: having an observe or observeEvent read the data and then discard it is wrong ... it's missing something. Ideally, this should really be a reactive or eventReactive block, or the processed data should be stored in a reactiveValues or reactiveVal. For example:
server <- function(input, output) {
mydata <- lapply(paste0("file", 1:2), function(nm) {
observeEvent(input[[ nm ]], {
req(input[[nm]], file.exists(input[[nm]]$datapath))
readr::read_csv2(file = input[[nm]]$datapath)
})
})
observe({
# the following are identical, the latter more declarative
mydata[[1]]
mydata[["file1"]]
})
}
(And another note about defensive programming: you cannot control perfectly how readr::read_csv2 reacts to that file ... it may error out for some reason. One further step would be to wrap it in tryCatch(..., error = function(e) { errfun(e); NULL; }) where errfun(e) does something meaningful with the error message (logs it and/or gives it to the user in a modal popup) and then returns NULL so that reactive blocks downstream can use req(mydata[[1]]) and will not try to process the NULL.
server <- function(input, output) {
mydata <- lapply(paste0("file", 1:2), function(nm) {
observeEvent(input[[ nm ]], {
req(input[[nm]])
file <- input[[nm]]
tryCatch(
readr::read_csv2(file = input[[nm]]$datapath),
error = function(e) { errfun(e); NULL; })
})
})
observe({
# the following are identical, the latter more declarative
mydata[[1]]
mydata[["file1"]]
})
}
I'm trying to get a reactiveValue that is depending on a reactive. In the real code (this is a very simplified version), I load a dataset interactively. It changes when pushing the buttons (prevBtn/nextBtn). I need to know the number of rows in the dataset, using this to plot the datapoints with different colors.
The question: Why can't I use the reactive ro() in the reactiveValues function?
For understanding: Why is the error saying "You tried to do something that can only be done from inside a reactive expression or observer.", although ro() is used inside a reactive context.
The error is definitely due to vals(), I already checked the rest.
The code :
library(shiny)
datasets <- list(mtcars, iris, PlantGrowth)
ui <- fluidPage(
mainPanel(
titlePanel("Simplified example"),
tableOutput("cars"),
actionButton("prevBtn", icon = icon("arrow-left"), ""),
actionButton("nextBtn", icon = icon("arrow-right"), ""),
verbatimTextOutput("rows")
)
)
server <- function(input, output) {
output$cars <- renderTable({
head(dat())
})
dat <- reactive({
if (is.null(rv$nr)) {
d <- mtcars
}
else{
d <- datasets[[rv$nr]]
}
})
rv <- reactiveValues(nr = 1)
set_nr <- function(direction) {
rv$nr <- rv$nr + direction
}
observeEvent(input$nextBtn, {
set_nr(1)
})
observeEvent(input$prevBtn, {
set_nr(-1)
})
ro <- reactive({
nrow(dat())
})
output$rows <- renderPrint({
print(paste(as.character(ro()), "rows"))
})
vals <- reactiveValues(needThisForLater = 30 * ro())
}
shinyApp(ui = ui, server = server)
Error in .getReactiveEnvironment()$currentContext() :
Operation not allowed without an active reactive context. (You tried to do something that can only be done from inside a reactive expression or observer.)
I think you want
vals <- reactiveValues(needThisForLater = reactive(30 * ro()))
Not everything in a reactiveValues list is assumed to be reactive. It's also a good place to store constant values. So since it's trying to evaluate the parameter you are passing at run time and you are not calling that line in a reactive environment, you get that error. So by just wrapping it in a call to reactive(), you provide a reactive environment for ro() to be called in.
I am trying to return a character vector created in a reactive expression in Shiny. However, when I run the app, I get the following:
Error: could not find function "check_case"
check_case is a reactive expression, not a function.
I can see a number of questions from people with similar issues, but the answers don't seem to fit this (for e.g., missing parentheses when calling reactive expression; calling something that hasn't been returned in the reactive expression).
I've tried immediately translating check_case() into a character vector in the output before using paste. I have also tried adding more arguments to paste so it includes sep = and collapse =, in case this is part of the issue, but this doesn't change the result I'm getting.
I currently have two theories:
There is an issue in the way I am using a reactive expression to return a character vector. Normally I use them to return dataframes so there might be something I'm missing here.
There is an issue in the way I am using paste to refer to a character vector.
Code:
library(shiny)
library(shinydashboard)
sidebar <- dashboardSidebar(
selectInput(
"case_select", label = "Select case",
choices = c("Upper", "Lower")
)
)
body <- dashboardBody(
fluidRow(
htmlOutput("text"))
)
ui <- dashboardPage(dashboardHeader(title = "Example"),
sidebar,
body
)
server <- function(input, output) {
output$check_case <- reactive({
if (input$case_select == "Upper") {
case_list <- c("A", "B", "C")
} else {
case_list <- c("a", "b", "c")
}
return(case_list)
})
output$text <- renderUI({
check_case <- check_case()
HTML(paste(check_case, sep = "", collapse = ""))
})
}
The issue is regarding the fact you are trying to output a reactive variable while also creating it. It is also important to note that you need to output to an existing UI element when rendering.
This can simply be solved by creating the reactive varaible, and then subsequently rendering it with renderUI as you are doing with ouput$text
server <- function(input, output) {
check_case <- reactive({
if (input$case_select == "Upper") {
case_list <- c("A", "B", "C")
} else {
case_list <- c("a", "b", "c")
}
return(case_list)
})
output$text <- renderUI({
check_case <- check_case()
HTML(paste(check_case, sep = "", collapse = ""))
})
}
Just a simple error
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.
I have a big shiny app with about 60 different inputs and it's still growing. Since I use this program a lot, I wanted the settings to be stored until next time I run the app. I made a csv-file that looks something like this:
input,value
input_a,10
input_b,#FFF000
input_c,hide
input_d,65400
I load the csv-file in ui.R and server.R with (not sure why I have to load it two times...)
config <- data.frame(lapply(read.csv(".//config.csv"), as.character), stringsAsFactors = FALSE)
and have inputs like this
sliderInput(
"input_a",
"Number of cats:",
min = 1,max = 50,
value = config[config$input %in% "input_a", "value"]
)
In server.R, I let input changes replace the value in the table and also save the table to the file
observe({
config[config$input %in% "input_a", "value"] <- input$input_a
config[config$input %in% "input_b", "value"] <- input$input_b
config[config$input %in% "input_c", "value"] <- input$input_c
config[config$input %in% "input_d", "value"] <- input$input_d
write.table(config, file = ".//config.csv", col.names = TRUE, row.names = FALSE, quote = FALSE, sep = ",")
})
I'm sure there is a better way to do this, I searched and checked the other similar questions, I started with dget and dput, but then decided to have all relevant settings in one simple file. Sorry if I missed the most relevant question when I searched.
What I don't like about this is that the program also saves the table when it loads the program, before I make any input changes.
How can I get rid of that unnecessary save every time I run the program?
I don't understand all the "reactivity" in shiny, it's still a bit to complicated for me, I don't really know anything about R or programming, just trying to optimize my program since it gets slower with every new "feature" I add.
I don't see any problem with keeping settings like that, but there might be a better way, and in anycase I would wrap it in a function like I did here.
And here is how you implement writing only "on exit" though (also please note the session parameter which is often not used):
library(shiny)
settingsdf <- data.frame(input=c("input_a","input_b","input_c"),
value=c(10,"#FF000","hide"),
stringsAsFactors=F)
setSetting <- function(pname,pval){
idx <- which(settingsdf$input==pname)
if (length(idx)==1){
print(pval)
settingsdf[ idx,2] <<- pval
}
}
shinyApp(
ui = fluidPage(
selectInput("region", "Region:", choices = colnames(WorldPhones)),
plotOutput("phonePlot")
),
server = function(input, output, session) {
output$phonePlot <- renderPlot({
if (length(input$region)>0){
setSetting("input_a",input$region)
barplot(WorldPhones[,input$region]*1000,
ylab = "Number of Telephones", xlab = "Year")
}
})
session$onSessionEnded(function() {
write.csv(settingsdf,"settings.csv")
})
},
options = list(height = 500)
)
Note that I am compressing the ui.R and server.R files into a single file which is not normally done but is nicer for these little examples.
This is not perfect code, I don't read the settings in and initialize the variables, and I use the <<- operator, which some people frown on. But it should help you along.
Update
Here is a more complex version that loads and saves the parameters, and encapsulates them for use. It is better, although it probably should use S3 objects...
library(shiny)
# Settings code
settingsdf <- data.frame(input=c("input_a","region"),
value=c(10,"Asia"),stringsAsFactors=F)
setfname <- "settings.csv"
setSetting <- function(pname,pval){
idx <- which(settingsdf$input==pname)
if (length(idx)==1){
settingsdf[ idx,"value"] <<- pval
}
}
getSetting <- function(pname){
idx <- which(settingsdf$input==pname)
if (length(idx)==1){
rv <- settingsdf[ idx,"value"]
return(rv)
} else {
return("")
}
}
readSettings <- function(){
if (file.exists(setfname)){
settingsdf <<- read.csv(setfname,stringsAsFactors=F)
}
}
writeSettings <- function(){
write.csv(settingsdf,setfname,row.names=F)
}
# ShinyApp
shinyApp(
ui = fluidPage(
selectInput("region","Region:", choices = colnames(WorldPhones)),
plotOutput("phonePlot")
),
server = function(input, output, session) {
readSettings()
vlastinput <- getSetting("region")
if (vlastinput!=""){
updateSelectInput(session, "region", selected = vlastinput )
}
output$phonePlot <- renderPlot({
if (length(input$region)>0){
vlastinput <- input$region
setSetting("region",vlastinput)
barplot(WorldPhones[,input$region]*1000,
ylab = "Number of Telephones", xlab = "Year")
}
})
session$onSessionEnded(function() {
writeSettings()
})
},
options = list(height = 500)
)
Yielding: