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

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)

Related

can a returned reactive expression works in another reactive

I tried to achieve when with a chosen split percentage, it returns the train set and then with a sampling method to resample train set and calculate its class freq and perc.
The error I got: object 'split.df' not found when I choose check box 'over'.
Should I use eventReactive or other syntax to achieve? The final return the table with either freq or perc should be dependent on 'split', 'sample' and dropdown 'freq' or 'perc'.
Here is portion that relates in ui:
sidebarLayout(
sidebarPanel(
h3("Train/test set"),
tags$br(),
selectInput(
"trainset",
"Select train component",
choices = list('freq'='freq', 'percentage'='perc'),
),
sliderInput(
"split",
label = "split percentage",
min = 0,
max = 1,
value = 0,
step = 0.1
),
h3("resampling train set"),
checkboxGroupInput('sample', label = "sampling method",
choices = list('original'='original','over'='over', 'under'='under', 'both'='both','ROSE'='ROSE'),
selected = list('original'='original'))
),
Here is a code relates for server:
split.df <- reactive({
index <- createDataPartition(df$class, p=input$split, list=FALSE)
Training_Data <- df[index,]
return(Training_Data)
})
train_set <- reactive({
if(input$sample == 'original')
Training_Data_class <- data.frame(class = split.df()$class)
return(Training_Data_class)
})
over_train_set <- reactive({
split.df <- split.df()
if(input$sample == 'over'){
over <- ovun.sample(class~., data = split.df, method = 'over')$data
Training_Data_class_over <- data.frame(class = over$class)
return(Training_Data_class_over)}
})
trainset_df <- reactive({
freq.df.train <- data.frame(table(train_set()))
colnames(freq.df.train) <- c('class', 'freq')
perc.df.train.=data.frame(prop.table(table(train_set()))*100)
colnames(perc.df.train) <- c('class','perc')
if(input$trainset == 'freq')
return(freq.df.train)
if(input$trainset == 'perc')
return(perc.df.train)
})
over_trainset_df <- reactive({
freq.df.train.over <- data.frame(table(over_train_set()))
colnames(freq.df.train.over) <- c('class', 'freq')
perc.df.train.over=data.frame(prop.table(table(over_train_set()))*100)
colnames(perc.df.train.over) <- c('class','perc')
if(input$trainset == 'freq')
return(freq.df.train.over)
if(input$trainset == 'perc')
return(perc.df.train.over)
})
output$trainsetdistr <- DT::renderDataTable({
if(input$sample == 'over'){
return(over_trainset_df())
}
if(input$sample == 'original'){
return(trainset_df())
}
}
)

How to solve the error in highcharOutput in shiny tool?

I'm working on cancer data from TCGA.
Im new to shiny and creating web applications (learning it!!)
I'm working on a shiny tool to plot the volcanoplot using highcharter package.
sometimes I'm successfully able to plot the volcanoplot in the UI. but sometimes it fails to plot it and throws an error saying,
"An error has occurred!
could not find function "highchartOutput"
and one warning message is given for the error;
Listening on http://127.0.0.1:5335
Warning: Error in highchartOutput: could not find function "highchartOutput"
83: dots_list
82: div
81: tabPanel
I think there is some problem with the tabset panel.
is this error has anything to do with indentation? (wherever I adjust the brackets it works magically. not sure how it works for sometimes.)
I am attaching the UI and server files with this post.
code is attached for one type of comparison
UI file below:
library(shiny)
# Define UI for application
shinyUI(fluidPage(
# Application title
titlePanel("miR-Gyn-Explorer"),
# Sidebar with a slider input for number of bins
sidebarLayout(
sidebarPanel(
## select the count matrix
selectInput("file", label = h3("Count Matrix"),
choices = list("Stage I - Normal" = list("TCGA-BRCA" = "Data/TCGA-BRCASI_NT.rda", "TCGA-UCEC" = "Data/TCGA-UCECSI_NT.rda"))),
## select the phenodata of samples
selectInput("phenofile", label = h3("Sample Phenodata"),
choices = list("Stage I - Normal" = list("TCGA-BRCA" = "Data/TCGA-BRCA_phenoSI_NT.rda", "TCGA-UCEC" = "Data/TCGA-UCEC_phenoSI_NT.rda"))),
submitButton("Update View")
),
# Show a plot of the generated distribution
mainPanel(
tabsetPanel(
tabPanel("DEmiRNA", DT::dataTableOutput("DEmiRNA"),
"Volcano-Plot", highchartOutput("volcanoPlot", height = "500px"))
#tabPanel("miRNA-Targets", DT::dataTableOutput('miRTarget'),
#plotOutput("GO"))
)
)
)
)
)
server file:
library(shiny)
library(R.utils)
##function to find the DEmiRNA by edgeR method
library(limma)
library(edgeR)
library(DT)
library(dplyr)
library(multiMiR)
library(miRBaseConverter)
library(ggplot2)
#library(ggrepel)
library(tidyverse)
library(highcharter)
library(org.Hs.eg.db)
library(clusterProfiler)
library(purrr)
gdcDEmiRNA <- function(counts, groups, comparison, filter=TRUE) {
## method = edgeR
dge = DGEList(counts = counts, samples = groups)
group <- factor(groups$group)
design <- model.matrix(~0+group)
colnames(design) <- levels(group)
contrast.matrix <- makeContrasts(contrasts=comparison,
levels=design)
keep = filterByExpr(dge,design)
dge <- dge[keep,,keep.lib.sizes = TRUE]
dge <- calcNormFactors(dge)
dge <- estimateDisp(dge, design)
fit <- glmFit(dge, design)
lrt <- glmLRT(fit, contrast=contrast.matrix)
DEGAll <- lrt$table
DEGAll$FDR <- p.adjust(DEGAll$PValue, method = 'fdr')
o <- order(DEGAll$FDR)
DEGAll <- DEGAll[o,]
return (DEGAll)
}
# Define server logic required to perform the DEmiRNA analysis
server <- function(input, output) {
d <- reactive({
#DEmiRNA calculation
file <- load(input$file)
phenofile <- load(input$phenofile)
if(file == "SI_NT"){
if(phenofile == "phenoSI_NT"){
DEmiRNA <- gdcDEmiRNA(counts = SI_NT, groups = phenoSI_NT,
comparison = 'StageI-Normal')
}
}
})
output$DEmiRNA <- DT::renderDataTable({
mir <- d()
#mir <- mir[mir$FDR < input$FDR,]
})
output$volcanoPlot <- renderHighchart({
x <- d()
x$mirna <- rownames(x)
x$sig <- ifelse(x$PValue < 0.05 & abs(x$logFC) > 0.57, "DEmiRNA", "Not Regulated")
hc <- highchart() %>%
hc_add_series(x, "scatter", hcaes(logFC, -log10(PValue), group = sig, value = mirna),
color = c('rgba(67, 67, 72, 0.6)', 'rgba(124, 181, 236, 0.6)'),
enableMouseTracking = c(TRUE, TRUE),
showInLegend = TRUE, marker = list(radius = 4)) %>%
hc_tooltip(pointFormat = "{point.value}", headerFormat = "") %>%
hc_xAxis(title = list(text = "Log fold change"), gridLineWidth = 1,
tickLength = 0, startOnTick = "true", endOnTick = "true", min = -6, max = 6) %>%
hc_yAxis(title = list(text = "-Log10(p-value)")) %>%
hc_chart(zoomType = "xy", width=700) %>%
hc_exporting(enabled = TRUE, filename = "volcano")
hc
})
}
any comment and help from you guys is appreciated
Thank you in advance!
-Ankita

Trying to create a future value calculator with shiny app in R and get error: argument 1 (type 'closure') cannot be handled by 'cat'

This is the code I have on my server file:
shinyServer(function(input, output) {
output$P = renderText(input$Slider1)
output$n = renderText(input$numeric1)
output$r = renderText(input$numeric2/100)
futureValue <- reactive({
principal <- output$P
numberOfPeriods <- output$n
rate <- output$r
fvalue <- principal*(((1+rate)^numberOfPeriods-1)/rate)
return(fvalue)
})
output$fv <- renderText(futureValue)
})
Code for main panel on UI File:
sidebarPanel(
h4("Select Monthly Investment Amount:"),
sliderInput("Slider1","Select Monthly Investment Amount:", 100, 1000,
100),
numericInput("numeric1", "Select Number of Payments:", value = 12, min
= 6, max = 60, step = 1),
numericInput("numeric2", "Select Interest Rate Percentage:", value =
3.0, min = 0.1, max = 5.0, step = 0.1)
mainPanel
(
h4("Monthly Investment Amount:"),
textOutput("P"),
h4("Number of Periods:"),
textOutput("n"),
h4("Interest Rate:"),
textOutput("r"),
h4("Under the given circumstances, the future value of your
investment is:"),
textOutput("fv")
)
Everything works except for the last part where I'm performing the calculations for future value. Would anyone be able to tell me what I'm doing wrong?
Hi reactivs are functions not variables
output$fv <- renderText(futureValue() )
and change the reactive function like this
futureValue <- reactive({
principal <- input$Slider1
numberOfPeriods <- input$numeric1
rate <- input$numric2
fvalue <-principal*(((1+rate)^numberOfPeriods-1)/rate)
return(fvalue) })
should solve it.
Hope this helps!

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)

Connecting Shiny Movie gallery example with my own cvs file

I have read now the stackoverflow Q&A for several hours on various days and have also seen the latest specific Shiny debugging video from the Shiny developer conference (Jonathan McPherson):
Now the problem looks simple to me, but I went through lots of checks, revisions of the naming conventions and thought of various hypotheses: Making column titles starting with capital letters, calling the initial file similar to the template, renaming the column titles, ...
I like the interactive scatter plots from the Movie Gallery and would like to reproduce it with my own records, located in a cvs file, which I uploaded in my RStudio session with the name all_flexitime, which I understand now is not enough.
How do I connect or integrate my cvs file into the given template? I have renamed all necessary fields, I believe. The error I am getting says:
Error in eval(substitute(expr), envir, enclos) :
object 'Flexileave2015' not found
Flexileave2015 is, I believe, the first variable the server file is looking for to produce the scatter plot, but since the file needs to be found somewhere in the server file, it cannot find it there. I can see it in my Studio.
Can somebody confirm my understanding and possibly help, please.
My all_flexitime data frame is made of the following columns titles:
"Number", "First", "Last", "Contract", "Grade", "Flexileave2015", "Certifiedsickleave2015", "Uncertifiedsickleave2015", "Daysnotrecorded2015", "Excess2015".
My server.R is:
library(ggvis)
library(dplyr)
if (FALSE) library(RSQLite)
shinyServer(function(input, output, session) {
# Filter staff, returning a data frame
flexitimes <- reactive({
# Due to dplyr issue #318, we need temp variables for input values
flexileave2015 <- input$flexileave2015
certifiedsickleave2015 <- input$certifiedsickleave2015
uncertifiedsickleave2015 <- input$uncertifiedsickleave2015
daysnotrecorded2015 <- input$daysnotrecorded2015
excess2015 <- input$excess2015
# Apply filters
m <- all_flexitimes %>%
filter(
Flexileave2015 >= flexileave2015,
Excess2015 >= excess2015,
Certifiedsickleave2015 >= certifiedsickleave2015,
Uncertifiedsickleave2015 >= uncertifiedsickleave2015,
Daysnotrecorded2015 >= daysnotrecorded2015
) %>%
arrange(Flexileave2015)
# Optional: filter by Contract
if (input$contract != "All") {
contract <- paste0("%", input$contract, "%")
m <- m %>% filter(Contract %like% contract)
}
# Optional: filter by Grade
if (input$grade != "All") {
grade <- paste0("%", input$grade, "%")
m <- m %>% filter(Grade %like% grade)
}
# Optional: filter by Number
if (!is.null(input$number) && input$number != "") {
number <- paste0("%", input$number, "%")
m <- m %>% filter(Number %like% number)
}
# Optional: filter by Last Name
if (!is.null(input$last) && input$last != "") {
last <- paste0("%", input$last, "%")
m <- m %>% filter(Last %like% last)
}
m <- as.data.frame(m)
m
})
# Function for generating tooltip text
flexitime_tooltip <- function(x) {
if (is.null(x)) return(NULL)
if (is.null(x$Number)) return(NULL)
# Pick out the staff with this Number
all_flexitimes <- isolate(flexitimes())
flexitime <- all_flexitimes[all_flexitimes$Number == x$Number, ]
paste0("<b>", flexitime$First, flexitime$Last, "</b><br>",
flexitime$Grade, "<br>",
flexitime$Contract
)
}
# A reactive expression with the ggvis plot
vis <- reactive({
# Lables for axes
xvar_name <- names(axis_vars)[axis_vars == input$xvar]
yvar_name <- names(axis_vars)[axis_vars == input$yvar]
# Normally we could do something like props(x = ~BoxOffice, y = ~Reviews),
# but since the inputs are strings, we need to do a little more work.
xvar <- prop("x", as.symbol(input$xvar))
yvar <- prop("y", as.symbol(input$yvar))
flexitimes %>%
ggvis(x = xvar, y = yvar) %>%
layer_points(size := 50, size.hover := 200,
fillOpacity := 0.2, fillOpacity.hover := 0.5,
key := ~ Number) %>%
add_tooltip(flexitime_tooltip, "hover") %>%
add_axis("x", title = xvar_name) %>%
add_axis("y", title = yvar_name) %>%
set_options(width = 500, height = 500)
})
vis %>% bind_shiny("plot1")
output$n_flexitimes <- renderText({ nrow(flexitimes()) })
})
The ui.R file is the following:
library(ggvis)
# For dropdown menu
actionLink <- function(inputId, ...) {
tags$a(href='javascript:void',
id=inputId,
class='action-button',
...)
}
shinyUI(fluidPage(
titlePanel("Overview of Flexitime usage"),
fluidRow(
column(3,
wellPanel(
h4("Filter"),
sliderInput("flexileave2015", "Flexileave 2015", 0, 14, 0, step = 1),
sliderInput("certifiedsickleave2015", "Certified sickleave 2015", 0, 230, 0, step = 1),
sliderInput("uncertifiedsickleave2015", "Uncertified sickleave 2015", 0, 13, 0, step = 1),
sliderInput("daysnotrecorded2015", "Days not recorded 2015", 0, 110, 0, step = 10),
sliderInput("excess2015", "Excess 2015", -100, 1500, 0, step = 50),
selectInput("contract", "Contract",
c("All", "Temporary Agent", "Contract Agent", "National Expert", "Interim")),
selectInput("grade", "Grade",
c("All", "AD05","AD06","AD07","AD08","AD09", "AD10","AD11", "AD12","AD13", "AD14","AD15","AST01","AST02","AST03","AST04","AST05","AST06","AST07",
"AST08","AST09","AST10","FGII.04","FGII.05","FGII.06","FGIII.08","FGIII.09","FGIII.10",
"FGIV.13","FGIV.14","FGIV.16","FGIV.18","SNE")),
textInput("number", "SAP Personnelnumber"),
textInput("last", "Initial of Last Name")
),
wellPanel(
selectInput("xvar", "X-axis variable", axis_vars, selected = "Flexileave2015"),
selectInput("yvar", "Y-axis variable", axis_vars, selected = "Uncertifiedsickleave2015"),
tags$small(paste0(
"Note: AD and AST are Temporary agent grades.",
" FG are Contract agent grades.",
" SNE is the only National expert grade.",
" Interims should not have an FG grade."
))
)
),
column(9,
ggvisOutput("plot1"),
wellPanel(
span("Number of staff members selected:",
textOutput("n_flexitimes")
)
)
)
)
))
I got external help for my shiny app, so I am posting how I sorted the problems in the end:
There was a spelling mistake for the all_flexitime data set, I changed it to be all_flexitimes.
In the preparatory work file (the one where I created the original database), I have made sure that the variables are read as characters and not as factors:
all_flexitimes$Grade <- as.character(all_flexitimes$Grade)
all_flexitimes$Contract <- as.character(all_flexitimes$Contract)
all_flexitimes$First <- as.character(all_flexitimes$First)
all_flexitimes$Last <- as.character(all_flexitimes$Last)
I have saved the all_flexitimes file into an .RData file via the following command, while I was in the RStudio working environment:
saveRDS(all_flexitimes, "all_flexitimes.RData")
In the global.R file I have added at the end the following line, so that the database can be read:
all_flexitimes <- readRDS("all_flexitimes.Rdata")
In the ui.file I used the following, as this was the safer option, as it avoids any misspelling:
selectInput("contract", "Contract",
c("All", sort(unique(all_flexitimes$Contract)))),
selectInput("grade", "Grade",
c("All", sort(unique(all_flexitimes$Grade)))),
In the server file, I have changed the manual filters to:
Optional: filter by Contract
if (input$contract != "All") {
contract <- paste0("%", input$contract, "%")
m <- m %>% filter(Contract == input$contract)
}
Optional: filter by Grade
if (input$grade != "All") {
grade <- paste0("%", input$grade, "%")
m <- m %>% filter(Grade == input$grade)
}
Optional: filter by Number
if (!is.null(input$number) && input$number != "") {
number <- paste0("%", input$number, "%")
m <- m %>% filter(Number == input$number)
}
Optional: filter by Last Name
if (!is.null(input$last) && input$last != "") {
last <- paste0("%", input$last, "%")
m <- m %>% filter(Last == input$last)

Resources