R shiny async error later: exception occured while executing callback - r

I am trying to built an async app using shiny and ran into a problem. Sometimes when starting the app, an error message appears in the console: "later: exception occured while executing callback: Evaluation error: object of type 'closure' is not subsettable.". The app runs as expected even when the message appears. My best guess is that it is some sort of race problem since it only appears about 50% of the times I start the app.
Thank you very much for your help and insights! Also, if you detect any other problems with my shiny implementation, feel free to let me know!
```
library(shiny)
library(promises)
library(future)
library(tidyverse)
library(glue)
plan(multisession) # plan(multicore) -> forking (not Windows/RStudio)
scopes_ui <- c('a', 'b', 'c')
ui <- function(){
tagList(
# numeric input for the first promise
numericInput(inputId = 'num1',
label = 'Choose your first number: ',
value = 0,
min = 0,
max = 10),
# numeric input for the second promise which relies on the first promise
numericInput(inputId = 'num2',
label = 'Choose your second number: ',
value = 3,
min = 0,
max = 10),
# input to test additional filter options
selectInput('ui_scope',
label = 'Choose scope: ',
scopes_ui,
selected = 'a'),
# this will receive the output of the future
h2('1. Table'),
tableOutput('res1'),
h2('2. Table'),
tableOutput('res2'),
# this plot will be drawn before the future is resolved
plotOutput('plot_inst'),
)
}
server <- function(input, output, session) {
# empty list sufficient (no need to actually initiate with NULLs)
rv <- reactiveValues(
last_id1 = NULL,
res1 = NULL,
res1_id = NULL,
value1 = NULL,
scope = NULL,
last_id2 = NULL,
value2 = NULL,
res2 = NULL
)
# ~~~~~~~~~~~~~~~~~~~~ #
# First promise #
# ~~~~~~~~~~~~~~~~~~~~ #
observe({
# initiate reactive variables BEFORE the promise
rv$last_id1 <- glue('ID_{input$num1}')
last_id1 <- rv$last_id1
rv$value1 <- input$num1
value1 <- rv$value1
rv$scope <- input$ui_scope
scope <- rv$scope
# promise
future_promise({
# make computation expensive
if(value1 %% 2 == 0) {
Sys.sleep(10)
}
data <- data.frame(treat = c('a', 'b', 'c'), outcome = c(value1, 1.9, 3.2))
data <- data %>% filter(treat == scope)
# return id and data from the future
list(
id = last_id1,
res = data
)
}) %...>%
(function(result){
# change value1 of `rv$res1` only if the current id is the same as the last_id
if (result$id == rv$last_id1){
rv$res1_id <- result$id
rv$res1 <- result$res
}
})
# this must return something (including "empty") to execute asynchronously
return()
}) %>%
bindEvent(input$num1, input$ui_scope)
# ~~~~~~~~~~~~~~~~~~~~ #
# Second promise #
# ~~~~~~~~~~~~~~~~~~~~ #
observe({
# initiate reactive variables BEFORE the promise
rv$last_id2 <- glue('ID_{input$num1}_{input$num2}')
last_id2 <- rv$last_id2
rv$value2 <- input$num2
value2 <- rv$value2
# ensure that rv$res1 is available
data <- req(rv$res1)
# promise
future_promise({
# make computation expensive
Sys.sleep(5)
data[1,2] <- value2
# return id and data from the future
list(
id = last_id2,
res = data
)
}) %...>%
(function(result){
# change value of `rv$res2` only if the current id is the same as last_id2
if (result$id == rv$last_id2){
rv$res2 <- result$res
}
})
# this must return something (including "empty") to execute asynchronously
return()
}) %>%
bindEvent(rv$res1, input$num2)
# output$res1 will be printed whenever rv$res1
# is available, i.e. returned from the future,
# and corresponds to the last input sent.
output$res1 <- renderTable({
req(rv$res1)
})
output$res2 <- renderTable({
req(rv$res2)
})
# output$plot_inst will be drawn immediately
my_plt <- reactive({
data <- data.frame(treat = c('a', 'b', 'c'), outcome = c(1, 2, 3)) %>%
filter(treat == input$ui_scope)
ggplot(data, aes(treat, outcome)) +
geom_col() +
theme(text = element_text(size = 20))
})
output$plot_inst <- renderPlot({
req(my_plt())
})
}
shinyApp(ui, server)
```

Related

Getting variable data from a data set in Shiny R

I need to be able to access each variable's data in my data frame, after the user has selected and uploaded a local csv file. This code is the part of my Shiny script where I create and modify the csv file read in by the user. "rv" is the data, which is a reactiveValues dataframe, so it can be modified.
Variable names are chosen by the user through a radio button group (shown here, but defined in the ui part of the script). The other code is in the server portion of the script.
radioButtons('radiovarGroup1',label = h5("Choose a Variable to Analyze:"),
choices = list('TA' = 'TA','PP' = 'PP', 'US' = 'us', 'UD' = 'ud', 'UE' = 'ue',
'UG' = 'ug', 'UH' = 'uh', 'XR' = 'xr', 'RW' = 'rw', 'PA' = 'pa', 'TB4' = 'tb4',
'TV2' = 'tv2', 'TV4' = 'tv4', 'TV8' = 'tv8', 'TV20' = 'tv20', 'TV40' = 'tv40',
'MV2' = 'mv2', 'MV4' = 'mv4', 'MV8' = 'mv8', 'MV20' = 'mv20', 'MV40' = 'mv40',
'VB' = 'vb', 'TA40' = 'ta40', 'TA120' = 'ta120', 'SD' = 'sd'),inline = TRUE, selected = NULL),
var_names = c('TA','PP','US','UD','UE','UG','UH','XR','RW','PA','TB4','TV2','TV4',
'TV8','TV20','TV40','MV2','MV4','MV8','MV20','MV40','VB','TA40','TA120','SD')
rv <- reactiveValues(df = NULL)
#This function is responsible for loading in the selected file
observe({
req(input$file_selector)
rv$df <- read.csv(paste0(parseDirPath(c(home = 'C:\\Users\\Ruben\\Desktop\\Test_QC_Program\\FiveMin'), file_dir()),'\\',input$file_selector),skip=1) # Simplified for testing
})
# This previews the CSV data file
output$filetable <- renderDataTable({
rv$df
})
observeEvent(input$qc_final_cols, {
if (input$qc_final_cols){
for (v in 1:length(var_names)){
ind <- which(colnames(rv$df) == var_names[v])
rv$df <- rv$df %>%
add_column(z = NA,.after = ind)
colnames(rv$df)[ind+1] <- paste0(var_names[v],'_QC')
rv$df <- rv$df %>%
add_column(y = NA,.after = ind+1)
colnames(rv$df)[ind+2] <- paste0(var_names[v],'_Final')
}
}
})
output$checked_var <- renderPrint({
input$radiovarGroup1})
variable_data <- reactive({get(rv$df[,which(colnames(rv$df) == input$radiovarGroup1)])})
Why do I keep getting an "object of type closure is not subsettable' error returned for variable_data? I can render the rv$df data table just fine, but I can't extract data from it for some reason.

Invoke function within RShiny server call and render result as print output

I have written a script which makes use of 2 functions in order to calculate the duration required for a test to run, eg power analysis.
Inputs and code as follows;
## RUN POWER CALCULATION
average_daily_traffic <- 3515/30
control <- 0.47
uplift <- 0.02
num_vars <- 2
sample_size_calculator <- function(control, uplift){
variant <- (uplift + 1) * control
baseline <- ES.h(control, variant)
sample_size_output <- pwr.p.test(h = baseline,
n = ,
sig.level = 0.05,
power = 0.8)
if(variant >= 0)
{return(sample_size_output)}
else
{paste("N/A")}
}
## RUN DAYS CALCULATOR FUNCTION
days_calculator <- function(sample_size_output, average_daily_traffic){
days_required <- c((sample_size_output)*num_vars)/(average_daily_traffic)
if(days_required >= 0)
{paste0("It will take ", round(days_required, digits = 0)*num_vars, " days for this test to reach significance, with a daily average of " , round(average_daily_traffic, digits = 0), " visitors to this page over a 30 day period.")}
else
{paste("N/A")}
}
## RUN FUNCTIONS AND OUTPUT ANSWER
sample_size_calculator <- sample_size_calculator(control, uplift)
sample_size_output <- sample_size_calculator$n
answer <- days_calculator(sample_size_output, average_daily_traffic)
answer
This code is performant and is fit for my purpose in a standalone R script.
However, I need to make these functions executable from within a Shiny app. My attempt is as follows;
library(shiny)
ui <- fluidPage(
actionButton("exe", "Run",
style="color: #fff; background-color: #337ab7; border-color: #2e6da4"),
mainPanel(
textOutput("answer")
))
server <- function(input, output, session) {
sample_size_calculator <- eventReactive(input$exe,{
average_daily_traffic <- 3515/30
control <- 0.47
uplift <- 0.02
num_vars <- 2
variant <- (uplift + 1) * control
baseline <- ES.h(control, variant)
sample_size_output <- pwr.p.test(h = baseline,
n = ,
sig.level = 0.05,
power = 0.8)
if(variant >= 0)
{return(sample_size_output)}
else
{paste("N/A")}
})
days_calculator <- eventReactive (input$exe,{
days_required <- c((sample_size_output)*num_vars)/(average_daily_traffic)
if(days_required >= 0)
{paste0("It will take approximately ", round(days_required, digits = 0)*num_vars, " days or ", round((round(days_required, digits = 0)*num_vars)/365, digits = 1) ," years for this test to reach significance, based on a daily average of " , round(average_daily_traffic, digits = 0), " users to this page in the last 30 days.")}
else
{paste("N/A")}
})
outputs_ <- eventReactive( input$exe, {
req(sample_size_calculator())
req(days_calculator())
sample_size_calculator <- sample_size_calculator(control, uplift)
sample_size_output <- sample_size_calculator$n
answer <- days_calculator(sample_size_output, average_daily_traffic)
output$answer <- renderText(outputs_$answer)
})
}
shinyApp(ui = ui, server = server)
When I run this code, I see the execute button but no output is displayed.
This is very likely due to a limitation in my understanding of how Shiny invokes functions so if there is a better way I would be very grateful to hear it.
Thanks in advance.
* EDITING TO INCLUDE FULL FUNCTIONALITY CODE *
The objective of the code is to use Mark Edmonson's googleAnalyticsR and googleAuthR to enable retrieval of web visit data to a particular URL/page from the Google Analytics account for last 30days and show a trend of this data. This works fine, once the user enters the URL and hits 'Run'.
There is an additional GA call which retrieves additional data for a particular conversion action (see other_data). This is required in order to derive the conversion rate that is used later in the power calculation.
The calculation is cvr <- aeng$users/totalusers
#options(shiny.port = 1221)
## REQUIRED LIBS
library(shiny)
library(googleAnalyticsR)
library(plotly)
library(googleAuthR)
library(markdown)
library(pwr)
gar_set_client(scopes = c("https://www.googleapis.com/auth/analytics.readonly"))
daterange <- function(x) {
as.Date(format(x, "%Y-%m-01"))
}
## DATE PARAMETERS
date_start <- as.Date(Sys.Date(),format='%d-%B-%Y')-31
date_end <- as.Date(Sys.Date(),format='%d-%B-%Y')-1
date_range <- c(date_start, date_end)
## UI SECTION
ui <- fluidPage(
googleAuth_jsUI("auth"),
tags$head(
tags$link(rel = "stylesheet", type = "text/css", href = "dur_calc.css")
),
tags$br(),
sidebarLayout(
sidebarPanel(
code("To begin, select from 'Accounts' and enter URL of page to be tested:"),
tags$p(),
column(width = 12, authDropdownUI("auth_dropdown",
inColumns = FALSE)),
textInput("url", label = h5(strong("Page to be tested")), value = "Enter full page URL..."),
hr(),
fluidRow(column(3, verbatimTextOutput("value")
)
),
actionButton("exe", "Run Calculator",
style="color: #fff; background-color: #337ab7; border-color: #2e6da4"),
),
mainPanel(
plotlyOutput("trend_plot"),
textOutput("page"),
textOutput("answer")
)
)
)
## SERVER SECTION
server <- function(input, output, session) {
auth <- callModule(googleAuth_js, "auth")
## GET GA ACCOUNTS
ga_accounts <- reactive({
req(auth()
)
with_shiny(
ga_account_list,
shiny_access_token = auth()
)
})
view_id <- callModule(authDropdown, "auth_dropdown",
ga.table = ga_accounts)
ga_data <- eventReactive( input$exe, {
x <- input$url
#reactive expression
output$page <- renderText({
paste("You have selected the page:", input$url) })
filterPageurl <- dim_filter("dimension97" , "REGEX", x ,not = FALSE)
filts <- filter_clause_ga4(list( filterPageurl))
req(view_id())
req(date_range)
with_shiny(
google_analytics,
view_id(),
date_range = date_range,
dimensions = "date",
metrics = "users",
dim_filters = filts,
max = -1,
shiny_access_token = auth()
)
})
other_data <- eventReactive( input$exe, {
x <- input$url
filterPageurl <- dim_filter("dimension97" , "REGEX", x ,not = FALSE)
filts <- filter_clause_ga4(list( filterPageurl))
seg_id <- "gaid::uzKGvjpFS_Oa2IRh6m3ACg" #AEUs
seg_obj <- segment_ga4("AEUs", segment_id = seg_id)
req(view_id())
req(date_range)
#req(filts)
with_shiny(
google_analytics,
view_id(),
date_range = date_range,
dimensions = "date",
metrics = "users",
dim_filters = filts,
segments = seg_obj,
max = -1,
shiny_access_token = auth()
)
})
outputly <- eventReactive( input$exe, {
req(other_data())
req(ga_data())
aeng <- other_data()
ga_data <- ga_data()
totalusers <<- sum(ga_data$users)
cvr <- aeng$users/totalusers
average_daily_traffic <- totalusers/30
control <- cvr
uplift <- 0.02
num_vars <- 2
})
sample_size_calculator <- eventReactive(input$exe,{
variant <- (uplift + 1) * control
baseline <- ES.h(control, variant)
sample_size_output <- pwr.p.test(h = baseline,
n = ,
sig.level = 0.05,
power = 0.8)
if(variant >= 0)
{return(sample_size_output)}
else
{paste("N/A")}
})
days_calculator <- eventReactive (input$exe,{
days_required <- c((sample_size_output)*num_vars)/(average_daily_traffic)
if(days_required >= 0)
{paste0("It will take approximately ", round(days_required, digits = 0)*num_vars, " days or ", round((round(days_required, digits = 0)*num_vars)/365, digits = 1) ," years for this test to reach significance, based on a daily average of " , round(average_daily_traffic, digits = 0), " users to this page in the last 30 days.")}
else
{paste("N/A")}
})
output$trend_plot <- renderPlotly({
req(ga_data())
ga_data <- ga_data()
plot_ly(
x = ga_data$date,
y = ga_data$users,
type = 'scatter',
mode = 'lines') %>%
layout(title = "Page Visitors by Day (last 30 days)",
xaxis=list(title="Date", tickformat='%Y-%m-%d', showgrid=FALSE, showline=TRUE),
yaxis=list(title = "Users", showgrid=FALSE, showline=TRUE)
)
})
calc_answer <- eventReactive(input$exe, {
req(outputly)
outputly <- outputly()
sample_size_calculator <- sample_size_calculator()
sample_size_output <- sample_size_calculator$n
days_calculator(sample_size_output, average_daily_traffic)
})
output$answer <- renderText(calc_answer())
}
shinyApp(ui = ui, server = server)
A few suggestions that may help.
Would start with a simplified shiny app before adding all of the calculations, may be easier to work with for now
Would avoid putting output statements inside of eventReactive. See below for example.
Consider having only one observeEvent or eventReactive for the button press instead of multiple, especially since some function results depend on others.
Right now there are no inputs, so don't need additional reactive expressions. When you add inputs, though, you probably will.
If you haven't already, review the R Studio Shiny tutorial on Action Buttons and Reactivity.
Hope this is helpful in moving forward.
library(shiny)
library(pwr)
ui <- fluidPage(
actionButton("exe", "Run", style="color: #fff; background-color: #337ab7; border-color: #2e6da4"),
mainPanel(
textOutput("answer")
)
)
server <- function(input, output, session) {
average_daily_traffic <- 3515/30
control <- 0.47
uplift <- 0.02
num_vars <- 2
sample_size_calculator <- function() {
variant <- (uplift + 1) * control
baseline <- ES.h(control, variant)
sample_size_output <- pwr.p.test(h = baseline,
n = ,
sig.level = 0.05,
power = 0.8)
if(variant >= 0)
{return(sample_size_output)}
else
{return(NA)}
}
days_calculator <- function (sample_size_output, average_daily_traffic) {
days_required <- c((sample_size_output)*num_vars)/(average_daily_traffic)
if(days_required >= 0)
{paste0("It will take approximately ", round(days_required, digits = 0)*num_vars, " days or ", round((round(days_required, digits = 0)*num_vars)/365, digits = 1) ," years for this test to reach significance, based on a daily average of " , round(average_daily_traffic, digits = 0), " users to this page in the last 30 days.")}
else
{paste("N/A")}
}
calc_answer <- eventReactive(input$exe, {
sample_size_calculator <- sample_size_calculator()
sample_size_output <- sample_size_calculator$n
days_calculator(sample_size_output, average_daily_traffic)
})
output$answer <- renderText(calc_answer())
}
shinyApp(ui = ui, server = server)

R Shiny update datatable from DT package

I made a shiny dashboard that connects to a postegreDB and get a value from a table, then subset it, and then transform it to a wide format using reshape2. I want to update the value directly from the dashboard, and then push them into the database.
I used this link for inspiration: https://github.com/MangoTheCat/dtdbshiny
This is the code I made:
server <- function(input, output, session) {
# Generate reactive values
rvs <- reactiveValues(
data = NA,
dataWide = NA,
dataSub = NA,
cdfilTmp = NA,
cdfilTmp2 = NA,
dataWideTmp = NA,
dbdata = NA,
dataSame = TRUE,
req = NA,
tabId = NA,
listeSeuil = NA,
dataMod = NA
)
# Generate source via reactive expression
mysource <- reactive({
dbGetQuery(pool, "SELECT * from bilanmasse.v_export_r_scen_seuil")
})
# Observe the source, update reactive values accordingly
observeEvent(mysource(), {
# Lightly format data by arranging id
# Not sure why disordered after sending UPDATE query in db
data <- mysource() %>% arrange(idscenar)
data <- dbGetQuery(pool, "SELECT * from bilanmasse.v_export_r_scen_seuil")
rvs$cdfilTmp <- paste(data$ordreseuil, data$nomfiliere, sep="-")
data$cdfiliere <- rvs$cdfilTmp
data <- data[c("idscenar", "nomscenar", "codeparam", "cdusage", "cdlithoprof", "cdfiliere", "valseuil")]
rvs$data <- data
rvs$dbdata <- data
rvs$listeSeuil <- unique(rvs$data[,1])
rvs$tabId <- dbGetQuery(pool, "SELECT * from bilanmasse.scenar_testr")
updateSelectInput(session, "listScen",
label = "Choix du scenario",
choices = isolate(rvs$listeSeuil)
)
})
rvs$dataSub <- reactive({ subset(rvs$data, rvs$data[,1] == input$listScen) })
rvs$dataWide <- reactive({ dcast(rvs$dataSub(), idscenar+nomscenar+codeparam+cdusage+cdlithoprof~cdfiliere, value.var="valseuil") })
rvs$dataWideTmp <- reactive({ rvs$dataWide() })
ScenBase <- reactive({ subset(rvs$data, rvs$data[,1] == 2) })
listeParam <- reactive({ unique(ScenBase()[,3]) })
listeUsage <- reactive({ unique(ScenBase()[,4]) })
listeLithoProf <- reactive({ unique(ScenBase()[,5]) })
listeTraitement <- reactive({ unique(ScenBase()[,6]) })
#
# render the table
output$tabScSeuil <- renderDataTable(
rvs$dataWide(), rownames = FALSE, editable = TRUE, selection = 'none', filter= "top", options = list(
columnDefs = list(list(className = 'dt-center', targets = "_all")))
)
proxy3 = dataTableProxy('tabScSeuil')
observeEvent(input$tabScSeuil_cell_edit, {
info = input$tabScSeuil_cell_edit
i = info$row
j = info$col = info$col + 1 # column index offset by 1
v = as.numeric(info$value)
rvs$dataWideTmp[i,j] <- v
output$test <- renderPrint(rvs$dataWideTmp[i,j])
})
}
Everything work perfectly expect when I want to update the new value into the table: I got this error:
Error in [: object of type 'closure' is not subsettable
So I tried to use an SQL request instead of a subset:
observeEvent(input$listScen, {
val <- as.character(input$listScen)
req <- paste0("SELECT * from bilanmasse.v_export_r_scen_seuil WHERE idscenar = ", val)
observeEvent(input$listScen, { dataSub <- dbGetQuery(pool, req) })
#cdfilTmp2 <- paste(dataSub[,6], dataSub[,7], sep="-")
#dataSub[,9] <- cdfilTmp2
#dataSub <- dataSub[c("idscenar", "nomscenar", "codeparam", "cdusage", "cdlithoprof", "V9", "valseuil")]
#colnames(dataSub) <- c("idscenar", "nomscenar", "codeparam", "cdusage", "cdlithoprof", "cdfiliere", "valseuil")
#dataWide <- dcast(dataSub, idscenar+nomscenar+codeparam+cdusage+cdlithoprof~cdfiliere, value.var="valseuil")
#dataWideTmp <-dataWide
output$test <- renderPrint(req)
})
But I got a weird error, when I print req, the request is OK:
[1] "SELECT * from bilanmasse.v_export_r_scen_seuil WHERE idscenar =
2"
But in the R console, I got an error:
Warning in postgresqlQuickSQL(conn, statement, ...) : Could not
create execute: SELECT * from bilanmasse.v_export_r_scen_seuil WHERE
idscenar =
Does someone know a solution to make this?

Nesting two observeEvents duplicates the reactive event

This question is related to another one I somewhat solved a few days ago.
My intention:
To upload a csv with several columns.
Plot each column in a line and points plot.
Allow the user to select two different points from the plot, called first/last. The program always get the last two points clicked, order them to find first/last (first<=last).
Since the columns may differ from one dataset to another I have to create dynamically the structure of the app, and the problem is that I nest a observeEvent for the click in each plot inside a observeEvent (when the user changes the input dataset). The problem is that the observeEvent for the click depends on the dataset loaded (different columns).
What I do in the app is to create a pool with all the clicks in all the plots and extract the lastest two ones from each plot when needed, and I use this information to modify the plot with colors green and red.
To create two sample datasets:
inputdata<-data.frame(weekno=1:20, weekna=letters[1:20])
inputdata$normal<-dnorm(inputdata$weekno,10)
inputdata$beta<-dbeta(inputdata$weekno, 1, 1)
inputdata$gamma<-dgamma(inputdata$weekno, 1, 1)
inputdata$logistic<-dlogis(inputdata$weekno,10)
inputdata$poisson<-dpois(inputdata$weekno, 2)
test1<-inputdata[c("normal","gamma")]
row.names(test1)<-inputdata$weekna
test2<-inputdata[c("normal","logistic")]
row.names(test2)<-inputdata$weekna
write.csv(test1, file="test1.csv")
write.csv(test2, file="test2.csv")
The app:
library(ggplot2)
library(shiny)
library(shinydashboard)
tail.order<-function(i.data, i.n, i.order){
res<-tail(i.data, n=i.n)
res<-res[order(res[i.order]),]
res$id.tail<-1:NROW(res)
res
}
extract.two<-function(i.data, i.order, i.column){
#data<-unique(i.data, fromLast=T)
data<-i.data
results <- do.call("rbind", by(data, data[i.column], tail.order, i.n=2, i.order=i.order))
return(results)
}
ui <- fluidPage(
fluidRow(
column(4,fileInput('file', "Load file")),
column(8,uiOutput("maintab"))
)
)
server <- function(input, output) {
values <- reactiveValues(origdata = NULL, plotdata = NULL, clickdata=NULL, dummy = TRUE)
read_data <- reactive({
infile <- input$file
inpath <- infile$datapath
inname <- infile$name
if(is.null(infile)) readdata<-NULL else readdata<-read.csv(inpath, row.names=1)
readdata
})
observeEvent(input$file, {
datfile <- read_data()
seasons<-names(datfile)
plotdata<-cbind(data.frame(weekno=1:NROW(datfile),weekna=rownames(datfile), stringsAsFactors = F), datfile)
origdata<-plotdata
for (s in seasons) eval(parse(text=paste0("plotdata$'",as.character(s),"_color'<-'1'")))
values$origdata <- origdata
values$plotdata <- plotdata
values$clickdata <- data.frame()
rm("origdata", "plotdata")
lapply(seasons, function(s){output[[paste0("plot_",as.character(s))]] <- renderPlot({
ggplot(values$plotdata, aes_(x=as.name("weekno"), y=as.name(s))) +
geom_point(aes_(as.name("weekno"), as.name(s), colour=as.name(paste0(s,"_color")), size=as.name(paste0(s,"_color")))) +
scale_color_manual(values = c("1" = "grey", "2" = "red", "3" = "green")) +
scale_size_manual(values = c("1" = 4, "2" = 6, "3" = 6)) +
geom_line(aes_(x=as.name("weekno"), y=as.name(s)), color="#000000") +
ggthemes::theme_few() +
guides(color=FALSE, size=FALSE)
})})
lapply(seasons,function(s){
observeEvent(input[[paste0("plot_",as.character(s),"_click")]], {
np <- nearPoints(values$origdata, input[[paste0("plot_",as.character(s),"_click")]], maxpoints=1 , threshold = 10000)
values$clickdata<-rbind(values$clickdata,cbind(data.frame(variable=as.character(s), stringsAsFactors = F), np))
if (NROW(values$clickdata)>0){
p0<-extract.two(values$clickdata,"weekno","variable")
p1<-subset(p0, variable==as.character(s) & id.tail==1)
p2<-subset(p0, variable==as.character(s) & id.tail==2)
if (NROW(p1)>0) {
values$plotdata[values$plotdata[,paste0(as.character(s),"_color")]=="2", paste0(as.character(s),"_color")]<-"1"
values$plotdata[values$origdata$weekno==p1$weekno,paste0(as.character(s),"_color")]<-"2"
}
if (NROW(p2)>0){
values$plotdata[values$plotdata[,paste0(as.character(s),"_color")]=="3",paste0(as.character(s),"_color")]<-"1"
values$plotdata[values$origdata$weekno==p2$weekno,paste0(as.character(s),"_color")]<-"3"
}
}
})
})
})
output$maintab <- renderUI({
datfile <- read_data()
seasons<-names(datfile)
do.call(tabsetPanel,
c(
lapply(seasons,function(s){
call("tabPanel",s,call("plotOutput", outputId=paste0("plot_",as.character(s)),
click = paste0("plot_",as.character(s),"_click")))
}),
list(
tabPanel("First & last",tableOutput("results")),
tabPanel("Clicks",tableOutput("resultsfull"))
)
)
)
})
output$results<-renderTable({
if (NROW(values$clickdata)>0) extract.two(values$clickdata,"weekno","variable")
})
output$resultsfull<-renderTable({
values$clickdata
})
}
shinyApp(ui, server)
To reproduce the bug:
Open test1.csv, a observeEvent for each column is created ("_click").
Open test2.csv, a observeEvent for each column is created ("_click").
Since test1.csv and test2.csv first column is called "normal" then the observeEvent$normal_click is created two times, so when I click the plot it writes two times the point clicked to the "clicks pool" (because there are two observeEvent related to that "normal_click".
When I extract the lastest two points from the "clicks pool", it retrieves the same point two times (the point I clicked and was stored two times because there was two observeEvents_click to the same plot).
I know to to circumvent the problem by uncommenting:
#data<-unique(i.data, fromLast=T)
This way it removes duplicates, but also denies the chance of telling the app to use the same point for first and last (first can be equal to last). And also this solution is not elegant since the structural problem is still there.
Any hints on how to fix this?
I found another post talking about another problem that did lead me to the solution.
I have created a list of observeEvent that have been created not to allow duplicate the same observeEvent (called idscreated).
library(ggplot2)
library(shiny)
library(shinydashboard)
tail.order<-function(i.data, i.n, i.order){
res<-tail(i.data, n=i.n)
res<-res[order(res[i.order]),]
res$id.tail<-1:NROW(res)
res
}
extract.two<-function(i.data, i.order, i.column){
data<-i.data
results <- do.call("rbind", by(data, data[i.column], tail.order, i.n=2, i.order=i.order))
return(results)
}
ui <- fluidPage(
fluidRow(
column(4,fileInput('file', "Load file")),
column(8,uiOutput("maintab"))
)
)
server <- function(input, output) {
values <- reactiveValues(origdata = NULL, plotdata = NULL, clickdata=NULL, idscreated = character())
read_data <- reactive({
infile <- input$file
inpath <- infile$datapath
inname <- infile$name
if(is.null(infile)) readdata<-NULL else readdata<-read.csv(inpath, row.names=1)
readdata
})
observeEvent(read_data(), {
datfile <- read_data()
seasons<-names(datfile)
plotdata<-cbind(data.frame(weekno=1:NROW(datfile),weekna=rownames(datfile), stringsAsFactors = F), datfile)
origdata<-plotdata
for (s in seasons) eval(parse(text=paste0("plotdata$'",as.character(s),"_color'<-'1'")))
values$origdata <- origdata
values$plotdata <- plotdata
values$clickdata <- data.frame()
rm("origdata", "plotdata")
lapply(seasons, function(s){output[[paste0("plot_",as.character(s))]] <- renderPlot({
ggplot(values$plotdata, aes_(x=as.name("weekno"), y=as.name(s))) +
geom_point(aes_(as.name("weekno"), as.name(s), colour=as.name(paste0(s,"_color")), size=as.name(paste0(s,"_color")))) +
scale_color_manual(values = c("1" = "grey", "2" = "red", "3" = "green", "4" = "purple")) +
scale_size_manual(values = c("1" = 4, "2" = 6, "3" = 6, "4" = 8)) +
geom_line(aes_(x=as.name("weekno"), y=as.name(s)), color="#000000") +
ggthemes::theme_few() +
guides(color=FALSE, size=FALSE)
})})
lapply(seasons,function(s){
nameid<-paste0("plot_",as.character(s),"_click")
if (!(nameid %in% values$idscreated)){
values$idscreated<-c(values$idscreated,nameid)
observeEvent(input[[nameid]], {
np <- nearPoints(values$origdata, input[[nameid]], maxpoints=1 , threshold = 10000)
values$clickdata<-rbind(values$clickdata,cbind(data.frame(variable=as.character(s), stringsAsFactors = F), np))
if (NROW(values$clickdata)>0){
p0<-extract.two(values$clickdata,"weekno","variable")
p1<-subset(p0, variable==as.character(s) & id.tail==1)
p2<-subset(p0, variable==as.character(s) & id.tail==2)
if (NROW(p1)>0) {
values$plotdata[values$plotdata[,paste0(as.character(s),"_color")]!="3", paste0(as.character(s),"_color")]<-"1"
values$plotdata[values$origdata$weekno==p1$weekno,paste0(as.character(s),"_color")]<-"2"
}
if (NROW(p2)>0){
values$plotdata[values$plotdata[,paste0(as.character(s),"_color")]!="2", paste0(as.character(s),"_color")]<-"1"
values$plotdata[values$origdata$weekno==p2$weekno,paste0(as.character(s),"_color")]<-"3"
}
if (NROW(p1)>0 & NROW(p2)>0){
if (p1$weekno==p2$weekno){
values$plotdata[, paste0(as.character(s),"_color")]<-"1"
values$plotdata[values$origdata$weekno==p1$weekno,paste0(as.character(s),"_color")]<-"4"
}
}
}
})
}
})
})
output$maintab <- renderUI({
datfile <- read_data()
seasons<-names(datfile)
do.call(tabsetPanel,
c(
lapply(seasons,function(s){
call("tabPanel",s,call("plotOutput", outputId=paste0("plot_",as.character(s)),
click = paste0("plot_",as.character(s),"_click")))
}),
list(
tabPanel("First & last",tableOutput("results")),
tabPanel("Clicks",tableOutput("resultsfull"))
)
)
)
})
output$results<-renderTable({
if (NROW(values$clickdata)>0) extract.two(values$clickdata,"weekno","variable")
})
output$resultsfull<-renderTable({
values$clickdata
})
}
shinyApp(ui, server)

Shiny - Web Framework for R › how to use an input switch to conditionally group

asked this on the shiny google group, w no help yet: I'm struggling with how to pass an input switch to dplyr's group_by_ in the code below.
I bolded the two parts of relevant code in the not-so-MRE below (ie, lines 9:11, and 24).
effectively, if the user selects "daily" in the UI, the resultant grouping should be group_by(year = year(my_date), month = month(my_date), day = day(my_date) in line 24, or remove ANY grouping as the data is already daily.
selecting "monthly", should yield group_by(year = year(my_date), month = month(my_date))
"yearly", should yield group_by(year = year(my_date))
I welcome meta-suggestions/ criticism about how my code/ structures are organized.
Thank you
library(shiny)
library(dplyr)
library(lubridate)
ui <- fluidPage(
dateInput("start", label = "start date", value = "2010-01-01"),
dateInput("end", label = "end date", value = "2020-01-01"),
selectInput("grouping_freq", label = "Granularity",
choices = list("daily" = 1,"monthly" = 2, "Yearly" = 3),
selected = 2),
tableOutput("my_table")
)
server <- function(input, output) {
df <- reactive({ data_frame(my_date = seq(input$start, input$end, by = 'day')) }) ## 10 years of daily data
df2 <- reactive({ df() %>% mutate(dummy_data = cumsum(rnorm( nrow( df() ) ))) })
output$my_table <- renderTable({
df2() %>% group_by(year = year(my_date), month = month(my_date)) %>%
summarise(dummy_data = sum(dummy_data), my_date = as.Date(min(my_date)))
})
}
shinyApp(ui = ui, server = server)
You can use the value chosen in selectInput to create a list of formulas that are passed into group_by_, the version of dplyr::group_by that uses standard evaluation.
group_list <- switch(input$grouping_freq,
list(yr=~year(my_date), mn=~month(my_date), dy=~day(my_date)),
list(yr=~year(my_date), mn=~month(my_date))
list(yr=~year(my_date)))
or if you prefer if statements,
group_list <- if (input$grouping_freq == 1) {
list(yr=~year(my_date), mn=~month(my_date), dy=~day(my_date))
} else if (input$grouping_freq == 2) {
list(yr=~year(my_date), mn=~month(my_date))
} else if (input$grouping_freq == 3) {
list(yr=~year(my_date))
} else {
list()
}
and then you can pass group_list into the renderTable expression
output$my_table <- renderTable({
df2() %>%
group_by_(.dots=group_list) %>%
summarise(dummy_data = sum(dummy_data), my_date = as.Date(min(my_date)))
})
I am not sure what you meant by "remove ANY grouping as the data is already daily." but if the data might already be grouped you can use the ungroup function to remove any groups before applying the groupings in group_list.
Edit: Forgot to include ~ in the list elements so that they evaluate correctly.

Resources