I have set up a shiny app that knitr's markdown PDF's based on selceted data. The generated report needs to have some sort of unique ID to be referenced in meetings.
I understand that I can use the session ID but I need a way to count the downloads per session.
Is there a way of counting events outside sessions or counting the number of session ID's since first deployment?
I needed to do that once, so I had some code lying around. It basically kept track of everything in a csv that I appended to. Here I built it into a shiny test platform.
it uses the session$token for the id (maybe there is something better)
it uses write.table and read.table because they behave better with the append option.
it increments the count by calling out to writetolog in the shiny download handler but you can also increment the count manually with an extra button (which is only for test purposes obviously)
It has two output, one is a summary of the log, the other is a dump of what is in the log. These are for debugging as the downloadHandler can be a bit "challenging" at times when interacting with all this reactivity.
Here is that code modified to be an example like about what you need:
library(shiny)
logfname <- "log.csv"
writetolog <- function(newcount,newsessionid,operation){
time <- format(Sys.time(), "%Y-%m-%d %H:%M:%S %Z")
df <- data.frame(time=time,count=newcount,sessionid=newsessionid,operation=operation)
doappend <- file.exists(logfname)
if (doappend){
write.table(df,logfname,append=T,quote=F,col.names=F,sep=",",row.names=F)
} else {
write.table(df,logfname,append=F,quote=F,sep=",",row.names=F)
}
}
getcounts <- function(){
if (!file.exists(logfname)){
return(list(count=0,sessioncount=0))
}
df <- read.table(logfname,header=T,sep=",")
nr <- nrow(df)
rlst <- list(count=sum(df$count),sessioncount=length(unique(df$sessionid)),
lastop=df$operation[nr],lasttime=df$time[nr])
return(rlst)
}
ui <- fluidPage(
titlePanel("Keep a download log"),
sidebarLayout(
sidebarPanel(
actionButton("inccount","Increment Count"),
actionButton("getcount","Refresh Summary"),
actionButton("showlog","Show Log"),
downloadButton("dodownload", "Save to .csv")
),
mainPanel(
h2("Summary of Download Log"),
verbatimTextOutput("showcount"),
h2("Dump of Download Log"),
verbatimTextOutput("loglog")
)
)
)
server <- function(input, output,session) {
observeEvent(input$inccount,{
print("writetolog")
writetolog(1,session$token,"inc count")
})
output$showcount <- renderPrint({
input$getcount
rv <- getcounts()
time <- format(Sys.time(), "%Y-%m-%d %H:%M:%S %Z")
print(sprintf("%s - count:%d sessioncount:%d",time,rv$count,rv$sessioncount))
})
output$loglog <- renderPrint({
input$showlog
if (!file.exists(logfname)) return(NULL)
ldf <- read.csv(logfname)
print(ldf)
})
output$dodownload<-downloadHandler(
filename = function() {
paste(input$table_name, '.csv', sep='')
},
content = function(file) {
write.csv(mtcars, file)
writetolog(1,session$token,"save file")
}
)
}
shinyApp(ui = ui, server = server)
Screen shot:
Related
I am trying to call(source) a code based on user input date(to decide path), but can't get to execute this. There's no error, but the called(sourced) code doesn't work(I know this since no file is output). I think I am not able to use eventReactive correctly to get the code executed in following -
ui = fluidPage(
sidebarLayout(
sidebarPanel(
titlePanel("MY Outputs")
,dateInput("ME_DATE_output",label=h2("Execution Date"), value="2020-05-29")
,textOutput('dateSelectionStatement')
,hr()
,actionButton("calculate", "Calculate Again" )
,textOutput("success")
)))
server = function(input, output) {
ME_DATE_GUI <- reactive({input$ME_DATE_output})
output$dateSelectionStatement <- renderText({paste0('You have selected: ', ME_DATE_GUI()) })
Code_loc <- "K:/Codes/"
code_execution <- eventReactive(input$calculate, {source(paste0(Code_loc,"GUI_trials.r"))})
# Print a message for refresh
output$success <- renderText({paste0('Output refreshed for date - ', ME_DATE_GUI())})
}
shinyApp(ui, server)
GUI_trials look like -
# Use GUI Reactive to get the date
ME_DATE <- as.Date(ME_DATE_GUI(), 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"))
The 2 problems are -
ME_DATE_GUI is not identified in sourced code(GUI_trials.r). Eeven if I use ME_DATE <<- renderText({input$ME_DATE_output}) in server part and place ME_DATE <- as.Date(ME_DATE, format="%Y-%m-%d") in GUI_trials.r, it's not working. The error is Error in as.Date.default: do not know how to convert 'ME_DATE' to class “Date”
eventReactive doesn't seem to do anything, i.e., actionButton part is inactive for me.
Any help is deeply appreciated!
server function as -
server = function(input, output) {
ME_DATE_GUI <- reactive({input$ME_DATE_output})
output$dateSelectionStatement <- renderText({paste0('You have selected: ', ME_DATE_GUI()) })
Code_loc <- "K:/Codes/"
observeEvent(input$calculate, {
ME_DATE <- ME_DATE_GUI()
source(paste0(Code_loc,"GUI_trials2.r"), local = TRUE)
# Print a message for refresh
output$success <- renderText({paste0('Output refreshed for date - ', ME_DATE_GUI())})
})
}
followed by change in GUI_trials2.R code as -
# Use ME_DATE from Shiny
ME_DATE <- as.Date(ME_DATE, format="%Y-%m-%d")
solved this issue!
Key was to use local=TRUE in source statement.
I would like a user to be able to answer the form multiple times before downloading the file, with each subsequent form added into the excel file.
I've considered a loop with the user able to input how many times through the loop, but I would prefer the user to be able to calculate multiple times, but only need to download the file once. I am not sure where to begin with this. I've also considered shiny modules, but I am not sure that would be the most effective way to complete this. I've included a simplified version:
library(shiny)
library(lubridate)
library(openxlsx)
ui <- fluidPage(
textInput("name","Name"),
dateInput("date","Birthdate"),
textInput("title","Title"),
fileInput("excelfile","Excel File"),
actionButton("calculate","Calculate"),
downloadButton("download","Download")
)
server <- function(input, output) {
createcolumns<-observeEvent(input$calculate,{
age<-year(Sys.Date())-year(input$date)
df<-data.frame("Name"=input$name,"Age"=age,"Title"=input$title)
wb<-loadWorkbook(input$excelfile$datapath)
writeData(wb,"Sheet1",df)
saveWorkbook(wb,input$excelfile$datapath,overwrite = TRUE)
})
output$download<-downloadHandler(
file = function(){
filename<-strsplit(input$excelfile$name,"\\.")
filename<-filename[[1]][1]
filename<-paste0(filename,"_",Sys.Date())
paste(filename,"xlsx",sep=".")
},
content = function(file){
file.rename(input$excelfile$datapath,file)
},
contentType = "application/xlsx"
)
}
# Run the app ----
shinyApp(ui = ui, server = server)
Ideally, the user could input multiple people at once visit, then once everyone was entered, download the completed excel file.
I was able to do this by adding a few two variables in the server function (globaldf, x) and moving the bulk of the work into an if statement that checks if the calculate button has increased since the last time.
library(shiny)
library(lubridate)
library(openxlsx)
ui <- fluidPage(
fluidRow(
column(6,
textInput("name","Name",value = 1),
dateInput("date","Birthdate"),
textInput("title","Title"),
fileInput("excelfile","Excel File"),
actionButton("calculate","Calculate"),
downloadButton("download","Download")
),
column(6,
h1("Output"),
tableOutput("data")
)
)
)
server <- function(input, output) {
globaldf<-data.frame("Name"=NULL,"Age"=NULL,"Title"=NULL)
x<-0
createcolumns<-reactive({
req(input$name,input$date,input$title,input$excelfile,input$calculate)
y<-input$calculate
if(x<y){
age<-year(Sys.Date())-year(input$date)
df<-data.frame("Name"=input$name,"Age"=age,"Title"=input$title)
globaldf<<-rbind(globaldf,df)
wb<-loadWorkbook(input$excelfile$datapath)
writeData(wb,"Sheet1",globaldf)
saveWorkbook(wb,input$excelfile$datapath,overwrite = TRUE)
x<<-y
globaldf
} else {return()}
})
output$data<-renderTable({
outputtable<-data.frame(createcolumns())
outputtable
})
output$download<-downloadHandler(
file = function(){
filename<-strsplit(input$excelfile$name,"\\.")
filename<-filename[[1]][1]
filename<-paste0(filename,"_",Sys.Date())
paste(filename,"xlsx",sep=".")
},
content = function(file){
file.rename(input$excelfile$datapath,file)
},
contentType = "application/xlsx"
)
}
Is it possible to set reactiveValues inside the content part of the downloadHandler? I tried it and don't understand the behavior.
A simple example could be a counter showing how often the download button has been clicked:
library(shiny)
ui <- fluidPage(
downloadButton("downloadData", "Download"),
textOutput("nDownloads"),
actionButton("trig", "get number")
)
server <- function(input, output) {
# Our dataset
data <- mtcars
r.nDownloads <- reactiveValues(n=0)
output$nDownloads <- renderText({
input$trig
paste("number of downloads:", r.nDownloads$n)
})
output$downloadData <- downloadHandler(
filename = function() {
paste("data-", Sys.Date(), ".csv", sep="")
},
content = function(file) {
r.nDownloads$n <- r.nDownloads$n + 1
write.csv(data, file)
}
)
}
shinyApp(ui, server)
If the download button is clicked, the textOutput is grayed out, but not updated. I added an action button as a trigger to force the renderText to be updated. Surprisingly (at least to me) that works: the correct number is shown.
So, somehow the reactiveValue is changed by the downloadHandler, but its dependencies are only invalidated, not updated.
Of course, the proper way to do it would be making the "data"-object reactive and doing the counting there. But I'm curious how the described behavior can be explained.
EDIT:
OK, now I get really confused: I tried what I mentioned above: making "data" reactive and doing the counting there. This could not be simple counting of downloads anymore, because the data-reactive gets only recalculated if it's invalid.
Here is an example with an additional input for the invalidation of "data":
library(shiny)
ui <- fluidPage(
numericInput("nRows", label = "nRows", min=1, max=32, value=15),
downloadButton("downloadData", "Download"),
textOutput("nDownloads")
)
server <- function(input, output) {
r.nDownloads <- reactiveValues(n=0)
# Our dataset
data <- reactive({
isolate({
r.nDownloads$n <- r.nDownloads$n + 1
})
mtcars[1:input$nRows,]
})
output$nDownloads <- renderText({
paste("number of downloads:", r.nDownloads$n)
})
output$downloadData <- downloadHandler(
filename = function() {
paste("data-", Sys.Date(), ".csv", sep="")
},
content = function(file) {
write.csv(data(), file)
}
)
}
shinyApp(ui, server)
But still, I see a similar behavior: Clicking the download button grays the text out, changing "nRows" makes the expected number of downloads (which is now downloads after a change in nRows ;-)) to show up.
Now it gets an actual problem for me: In my real app, a rather complex Excel file can be downloaded. While preparing and formatting the Excel file there can occur events that should lead to some reaction of the app. That's why the download should trigger something. The alternative I can see is, to prepare the Excel file before the user clicks on download (what I would like to avoid, because this can take a few seconds depending on the complexity of the file/formatting).
Am I missing something obvious? If not, I'd appreciate any ideas, how the download event can trigger something in the rest of the app.
The solution is to remove the isolation of the reactiveValues as this prevents the counter from being updated until the numericInput is triggered. This is because data() is dependent on input$nrows.
library(shiny)
ui <- fluidPage(
numericInput("nRows", label = "nRows", min = 1, max = 32, value = 15),
downloadButton("downloadData", "Download"),
textOutput("nDownloads")
)
server <- function(input, output) {
r.nDownloads <- reactiveValues(n = 0)
# Our dataset
data <- reactive({
r.nDownloads$n <- r.nDownloads$n + 1
mtcars[1:input$nRows,]
})
output$nDownloads <- renderText({
paste("number of downloads:", r.nDownloads$n)
})
output$downloadData <- downloadHandler(
filename = function() {
paste("data-", Sys.Date(), ".csv", sep = "")
},
content = function(file) {
write.csv(data(), file)
}
)
}
shinyApp(ui, server)
With regards to the deeper problem, it would be inefficient to constantly prepare a complex Excel file if there is no guarantee that the user would download the file. What you can try to do is:
Keep your data in a reactive method (e.g. data()).
Write a method to prep your data for downloading (e.g. prepExcel(data)) which returns your prepped data.
Pass (1) and (2) into the content of the downloadHandler() like this: write_xx(prepExcel(data())) or pipe the data into the write_xx function like this data() %>% prepExcel() %>% write_xx() where xx is the method used to output your final file e.g. write_xlsx or write_csv etc.
I hope this helps.
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 work on a long Shiny App where I want to give te possibility for the user to save the input in a Rdata file in order to load it later.
I manage to do that with downloadhandler, fileInput and renderUI,
But I have more than 200 input, I am sure there is a simple way.
All idea are welcome, Thanks in advance
Dimitri
shiny::runApp(list(
ui = pageWithSidebar(
headerPanel("Save Input"),
sidebarPanel(
downloadButton("download.input","Download Input"),
## Bolean to read or not the old input of the file load bellow
checkboxInput("use.list.input","Use Rdata for input",F),
fileInput('file.Rdata','Reload the input of a last session')
),
mainPanel(
## All the input will become uiOUtput
uiOutput("num1"),
uiOutput("num2")
)
),
server = function(input,output){
## The downloadHandler to write the current input
output$download.input <- downloadHandler(
filename = function() { paste0("input", '.csv') },
content = function(name) {
write.table(save.input(), file=name)
}
)
### Two object, one for write the current input, one for read the old input
save.input<-reactive({
data<-cbind(c("number1","number2"),c(input$number1,input$number2))
return(data)
})
table.input<-reactive({
inFile<-input$file.Rdata
table.input<-read.table(inFile$datapath)
return(table.input)
})
### RenderUI ###
output$num1<-renderUI({
if(input$use.list.input==T){
default<-table.input()[1,2]
}else{default<-1}
numericInput("number1","number1",default)
})
output$num2<-renderUI({
if(input$use.list.input==T){
default<-table.input()[2,2]
}else{default<-2}
numericInput("number2","number2",default)
})
}
))
Perhaps this entry on GitHub from "aagarw30/R-Shinyapp-Tutorial" would be useful. Storing a Visitor Counter in a separate file is similar to your dilemma.
https://github.com/aagarw30/R-Shinyapp-Tutorial/tree/master/ShinyAppVisitorHitCounter
The server.R code loads number updates to a separate counter.Rdata file using this code:
output$counter <-
renderText({
if (!file.exists("counter.Rdata"))
counter <- 0
else
load(file="counter.Rdata")
counter <- counter + 1
save(counter, file="counter.Rdata")
paste("Hits: ", counter)
})