An R shiny app that displays both ggplot plots and plotly plots - r

I'm trying to set up an R shiny app that will enable viewing three types of plots relating to gene expression data.
The data are comprised of:
A data.frame which has the output of the differential expression analysis (each row is a gene and the columns are the effect sizes and their p-values):
set.seed(1)
model.df <- data.frame(id = paste0("g",1:30),symbol = sample(LETTERS[1:5],30,replace=T),
group.effect.size = rnorm(30), group.p.value = runif(30,0,1),
sex.effect.size = rnorm(30), sex.p.value = runif(30,0,1),
stringsAsFactors = F)
A data.frame which has the design of the study (each row is a sample and the columns are the factors that the sample is associated with):
set.seed(1)
design.df <- data.frame(group = c(rep("A",6),rep("B",6)), sex = rep(c(rep("F",3),rep("M",3)),2), replicate = rep(1:6,2)) %>%
dplyr::mutate(sample = paste0(group,".",sex,"_",replicate))
design.df$group <- factor(design.df$group, levels = c("A","B"))
design.df$sex <- factor(design.df$sex, levels = c("F","M"))
A matrix which has the abundance (each row is a gene and each column is a sample):
set.seed(1)
abundance.mat <- matrix(rnorm(30*12), nrow=30, ncol=12, dimnames=list(model.df$id,design.df$sample))
A data.frame which has the results of a gene set enrichment analysis (each row is a set name and the columns are the enrichment test p-values for each factor in design.df):
set.seed(1)
gsea.df <- data.frame(set.name = paste0("S",1:4), group.p.value = format(round(runif(4,0,1),2),scientific = T), sex.p.value = format(round(runif(4,0,1),2),scientific = T), stringsAsFactors = F)
And finally, a data.frame which associates the genes with each set.name in gsea.df:
set.seed(1)
gene.sets.df <- do.call(rbind,lapply(1:4,function(s) data.frame(set.name = paste0("S",s), id = sample(model.df$id,10,replace = F),stringsAsFactors = F)))
I would like the shiny app to enable viewing these types of plots:
Feature Plot - plotting expression level of a single user-selected gene on the y-axis and sample on the x-axis, and that would be combined with an inset of a caterpillar plot showing the estimated effects:
Feature User-Defined Sets Plot - same as Feature Plot, however rather than showing a single -selected gene this will show a set of user-selected-genes and hence rather than points it will show violins of the distributions:
Feature Sets GSEA Plot - a combined list of volcano plots, where in each one the x-axis is the effect size of the factor, the y-axis is the -log10(p-value) of the effect, and the genes are colored red if they belong to the selected gene set:
Here are the three functions for generating these figures given the user selection:
featurePlot <- function(selected.id)
{
replicate.df <- reshape2::melt(abundance.mat[which(rownames(abundance.mat) == selected.id),,drop=F], varnames=c("id","sample")) %>%
dplyr::left_join(design.df)
effects.df <- data.frame(factor.name = c("group","sex"),
effect.size = c(dplyr::filter(model.df,id == selected.id)$group.effect.size,dplyr::filter(model.df,id == selected.id)$sex.effect.size),
p.value = c(dplyr::filter(model.df,id == selected.id)$group.p.value,dplyr::filter(model.df,id == selected.id)$sex.p.value),
stringsAsFactors = F)
effects.df$factor.name <- factor(effects.df$factor.name, levels = c("group","sex"))
main.plot <- ggplot(replicate.df,aes(x=replicate,y=value,color=group,shape=sex))+
geom_point(size=3)+facet_grid(~group,scales="free_x")+
labs(x="Replicate",y="TPM")+theme_minimal()
xlims <- c(-1*max(abs(effects.df$effect.size))-0.1*max(abs(effects.df$effect.size)),max(abs(effects.df$effect.size))+0.1*max(abs(effects.df$effect.size)))
effects.plot <- ggplot(effects.df,aes(x=effect.size,y=factor.name,color=factor.name))+
geom_point()+
geom_vline(xintercept=0,linetype="longdash",colour="black",size=0.25)+theme_minimal()+xlim(xlims)+
theme(legend.position="none")+ylab("")+xlab("Effect Size")
null.plot <- ggplot(data.frame())+geom_point()+geom_blank()+theme_minimal()
combined.plot <- gridExtra::arrangeGrob(main.plot,gridExtra::arrangeGrob(null.plot,effects.plot,ncol=1),nrow=1,ncol=2,widths=c(5,2.5))
return(combined.plot)
}
featureSetPlot <- function(selected.ids)
{
replicate.df <- reshape2::melt(abundance.mat[which(rownames(abundance.mat) %in% selected.ids),,drop=F], varnames=c("id","sample")) %>%
dplyr::left_join(design.df)
replicate.df$replicate <- as.factor(replicate.df$replicate)
effects.df <- data.frame(factor.name = c("group","sex"),
effect.size = c(dplyr::filter(model.df,id %in% selected.ids)$group.effect.size,dplyr::filter(model.df,id %in% selected.ids)$sex.effect.size),
p.value = c(dplyr::filter(model.df,id %in% selected.ids)$group.p.value,dplyr::filter(model.df,id %in% selected.ids)$sex.p.value),
stringsAsFactors = F)
effects.df$factor.name <- factor(effects.df$factor.name, levels = c("group","sex"))
main.plot <- ggplot(replicate.df,aes(x=replicate,y=value,color=group,fill=sex))+
geom_violin(trim=F,draw_quantiles=c(0.25,0.5,0.75),alpha=0.25)+facet_grid(~group,scales="free_x")+
labs(x="Replicate",y="TPM")+theme_minimal()
effects.plot <- ggplot(effects.df,aes(y=effect.size,x=factor.name,color=factor.name,fill=factor.name))+
geom_violin(trim=F,draw_quantiles=c(0.25,0.5,0.75),alpha=0.25)+coord_flip()+
geom_hline(yintercept=0,linetype="longdash",colour="black",size=0.25)+theme_minimal()+
theme(legend.position="none")+xlab("")+ylab("Effect Size Distribution")
null.plot <- ggplot(data.frame())+geom_point()+geom_blank()+theme_minimal()
combined.plot <- gridExtra::arrangeGrob(main.plot,gridExtra::arrangeGrob(null.plot,effects.plot,ncol=1),nrow=1,ncol=2,widths=c(5,2.5))
return(combined.plot)
}
gseaPlot <- function(selected.set)
{
plot.df <- model.df %>%
dplyr::left_join(gene.sets.df %>% dplyr::filter(set.name == selected.set))
plot.df$set.name[which(is.na(plot.df$set.name))] <- "non.selected"
plot.df$set.name <- factor(plot.df$set.name, levels = c("non.selected",selected.set))
factor.names <- c("group","sex")
gsea.volcano.plot <- lapply(factor.names,function(f)
plotly::plot_ly(type='scatter',mode="markers",marker=list(size=5),color=plot.df$set.name,colors=c("lightgray","darkred"),x=plot.df[,paste0(f,".effect.size")],y=-log10(plot.df[,paste0(f,".p.value")]),showlegend=F) %>%
plotly::layout(annotations=list(showarrow=F,x=0.5,y=0.95,align="center",xref="paper",xanchor="center",yref="paper",yanchor="bottom",font=list(size=12,color="darkred"),text=paste0(f," (",dplyr::filter(gsea.df,set.name == selected.set)[,paste0(f,".p.value")],")")),
xaxis=list(title=paste0(f," Effect"),zeroline=F),yaxis=list(title="-log10(p-value)",zeroline=F))
) %>% plotly::subplot(nrows=1,shareX=F,shareY=T,titleX=T,titleY=T) %>%
plotly::layout(title=selected.set)
return(gsea.volcano.plot)
}
Thus:
plot.type.choices <- c('Feature User-Defined Set Plot','Feature Sets GSEA Plot','Feature Plot')
So the first two use ggplot2 for generating each of the two figures they combine, which is then achieved using gridExtra::arrangeGrob. The last one uses plotly.
Here's the shiny code part I've been trying out, but with no luck:
server <- function(input, output)
{
out.plot <- reactive({
if(input$plotType == "Feature Plot"){
out.plot <- featurePlot(selected.id=dplyr::filter(model.df,symbol == input$symbol)$id[1])
} else if(input$plotType == "Feature User-Defined Set Plot"){
out.plot <- featureSetPlot(selected.ids=unique(dplyr::filter(model.df,symbol == input$set.symbols)$id))
} else if(input$plotType == "Feature Sets GSEA Plot"){
out.plot <- gseaVolcanoPlot(selected.set=input$set.name)
}
})
output$out.plot <- renderPlot({
if(input$plotType != "Feature Sets GSEA Plot"){
grid::grid.draw(out.plot())
} else{
out.plot()
}
})
output$save <- downloadHandler(
filename = function() {
paste0("./plot.pdf")
},
content = function(file) {
ggsave(out.plot(),filename=file,width=10,height=5)
}
)
}
ui <- fluidPage(
tags$style(type="text/css",".shiny-output-error { visibility: hidden; }",".shiny-output-error:before { visibility: hidden; }"),
titlePanel("Results Explorer"),
sidebarLayout(
sidebarPanel(
# select plot type
selectInput("plotType","Plot Type",choices=plot.type.choices),
#in case Feature User-Defined Set Plot was chosen select the genes
conditionalPanel(condition="input.plotType=='Feature User-Defined Set Plot'",
selectizeInput(inputId="set.symbols",label="Features Set Symbols",choices=unique(model.df$symbol),selected=model.df$symbol[1],multiple=T)),
#in case Feature Sets GSEA Plot was chosen select the databses
conditionalPanel(condition="input.plotType=='Feature Sets GSEA Plot'",
selectizeInput(inputId="set.name",label="Set Name",choices=unique(gene.sets.df$set.name),selected=gene.sets.df$set.name[1],multiple=F)),
#in case Feature Plot was chosen select the gene
conditionalPanel(condition="input.plotType=='Feature Plot'",
selectizeInput(inputId="symbol",label="Feature Symbol",choices=unique(model.df$symbol),selected=unique(model.df$symbol)[1],multiple=F)),
downloadButton('save', 'Save to File')
),
mainPanel(
plotOutput("output.plot")
)
)
)
shinyApp(ui = ui, server = server)
I'm suspecting that the renderPlot here may be the issue since I probably have to use plotly::renderPlotly for the Feature Sets GSEA Plot option but I'm not really sure how to tie it all up in the shiny server part.
Another complication that exists and it would be nice to have a solution for is the fact that the gene symbols are not unique WRT gene IDs (as shown in model.df). So it would be nice to have a list that's added if the user selected the Feature Plot option, and that list will show the subset of gene IDs which the selected symbol maps to (dplyr::filter(model.df == input$symbol)$id)
Thanks!

I also guess the problem is "renderPlot".
One, not so very elegant way that should solve this problem would be to instead of one output, split it in two, but only ever display one of both using "req()".
This piece of code would become:
output$out.plot <- renderPlot({
....
})
This:
output$out.plot1 <- renderPlot({
req(input$plotType != "Feature Sets GSEA Plot")
grid::grid.draw(out.plot())
})
output$out.plot2 <- renderPlotly({
req(input$plotType == "Feature Sets GSEA Plot")
out.plot()
})
You can now just add the the plots below each other in you UI.
"req()" makes sure absolultely nothing is plotted when the statement inside it is not "truthy" (see ?req), in this case "TRUE". The user would not see a difference between this and replacing one output like you tried.

Here's my solution from start to end:
Packages to load:
suppressPackageStartupMessages(library(dplyr))
suppressPackageStartupMessages(library(ggplot2))
suppressPackageStartupMessages(library(plotly))
suppressPackageStartupMessages(library(shiny))
Generate example data:
set.seed(1)
model.df <- data.frame(id = paste0("g",1:30),symbol = sample(LETTERS[1:5],30,replace=T),
group.effect.size = rnorm(30), group.p.value = runif(30,0,1),
sex.effect.size = rnorm(30), sex.p.value = runif(30,0,1),
stringsAsFactors = F)
set.seed(1)
design.df <- data.frame(group = c(rep("A",6),rep("B",6)), sex = rep(c(rep("F",3),rep("M",3)),2), replicate = rep(1:6,2)) %>%
dplyr::mutate(sample = paste0(group,".",sex,"_",replicate))
design.df$group <- factor(design.df$group, levels = c("A","B"))
design.df$sex <- factor(design.df$sex, levels = c("F","M"))
set.seed(1)
abundance.mat <- matrix(rnorm(30*12), nrow=30, ncol=12, dimnames=list(model.df$id,design.df$sample))
set.seed(1)
gsea.df <- data.frame(set.name = paste0("S",1:4), group.p.value = format(round(runif(4,0,1),2),scientific = T), sex.p.value = format(round(runif(4,0,1),2),scientific = T), stringsAsFactors = F)
set.seed(1)
gene.sets.df <- do.call(rbind,lapply(1:4,function(s) data.frame(set.name = paste0("S",s), id = sample(model.df$id,10,replace = F),stringsAsFactors = F)))
plot.type.choices <- c("Feature Plot","User-Defined Feature Set Plot","Feature Sets GSEA Plot")
Plotting functions:
featurePlot <- function(selected.id)
{
replicate.df <- reshape2::melt(abundance.mat[which(rownames(abundance.mat) == selected.id),,drop=F], varnames=c("id","sample")) %>%
dplyr::left_join(design.df)
effects.df <- data.frame(factor.name = c("group","sex"),
effect.size = c(dplyr::filter(model.df,id == selected.id)$group.effect.size,dplyr::filter(model.df,id == selected.id)$sex.effect.size),
p.value = c(dplyr::filter(model.df,id == selected.id)$group.p.value,dplyr::filter(model.df,id == selected.id)$sex.p.value),
stringsAsFactors = F)
effects.df$factor.name <- factor(effects.df$factor.name, levels = c("group","sex"))
main.plot <- ggplot(replicate.df,aes(x=replicate,y=value,color=group,shape=sex))+
geom_point(size=3)+facet_grid(~group,scales="free_x")+
labs(x="Replicate",y="TPM")+theme_minimal()
xlims <- c(-1*max(abs(effects.df$effect.size))-0.1*max(abs(effects.df$effect.size)),max(abs(effects.df$effect.size))+0.1*max(abs(effects.df$effect.size)))
effects.plot <- ggplot(effects.df,aes(x=effect.size,y=factor.name,color=factor.name))+
geom_point()+
geom_vline(xintercept=0,linetype="longdash",colour="black",size=0.25)+theme_minimal()+xlim(xlims)+
theme(legend.position="none")+ylab("")+xlab("Effect Size")
null.plot <- ggplot(data.frame())+geom_point()+geom_blank()+theme_minimal()
combined.plot <- gridExtra::arrangeGrob(main.plot,gridExtra::arrangeGrob(null.plot,effects.plot,ncol=1),nrow=1,ncol=2,widths=c(5,2.5))
return(combined.plot)
}
featureSetPlot <- function(selected.ids)
{
replicate.df <- reshape2::melt(abundance.mat[which(rownames(abundance.mat) %in% selected.ids),,drop=F], varnames=c("id","sample")) %>%
dplyr::left_join(design.df)
replicate.df$replicate <- as.factor(replicate.df$replicate)
effects.df <- data.frame(factor.name = c("group","sex"),
effect.size = c(dplyr::filter(model.df,id %in% selected.ids)$group.effect.size,dplyr::filter(model.df,id %in% selected.ids)$sex.effect.size),
p.value = c(dplyr::filter(model.df,id %in% selected.ids)$group.p.value,dplyr::filter(model.df,id %in% selected.ids)$sex.p.value),
stringsAsFactors = F)
effects.df$factor.name <- factor(effects.df$factor.name, levels = c("group","sex"))
main.plot <- ggplot(replicate.df,aes(x=replicate,y=value,color=group,fill=sex))+
geom_violin(trim=F,draw_quantiles=c(0.25,0.5,0.75),alpha=0.25)+facet_grid(~group,scales="free_x")+
labs(x="Replicate",y="TPM")+theme_minimal()
effects.plot <- ggplot(effects.df,aes(y=effect.size,x=factor.name,color=factor.name,fill=factor.name))+
geom_violin(trim=F,draw_quantiles=c(0.25,0.5,0.75),alpha=0.25)+coord_flip()+
geom_hline(yintercept=0,linetype="longdash",colour="black",size=0.25)+theme_minimal()+
theme(legend.position="none")+xlab("")+ylab("Effect Size Distribution")
null.plot <- ggplot(data.frame())+geom_point()+geom_blank()+theme_minimal()
combined.plot <- gridExtra::arrangeGrob(main.plot,gridExtra::arrangeGrob(null.plot,effects.plot,ncol=1),nrow=1,ncol=2,widths=c(5,2.5))
return(combined.plot)
}
gseaPlot <- function(selected.set)
{
plot.df <- model.df %>%
dplyr::left_join(gene.sets.df %>% dplyr::filter(set.name == selected.set))
plot.df$set.name[which(is.na(plot.df$set.name))] <- "non.selected"
plot.df$set.name <- factor(plot.df$set.name, levels = c("non.selected",selected.set))
factor.names <- c("group","sex")
gsea.plot <- lapply(factor.names,function(f)
plotly::plot_ly(type='scatter',mode="markers",marker=list(size=5),color=plot.df$set.name,colors=c("lightgray","darkred"),x=plot.df[,paste0(f,".effect.size")],y=-log10(plot.df[,paste0(f,".p.value")]),showlegend=F) %>%
plotly::layout(annotations=list(showarrow=F,x=0.5,y=0.95,align="center",xref="paper",xanchor="center",yref="paper",yanchor="bottom",font=list(size=12,color="darkred"),text=paste0(f," (",dplyr::filter(gsea.df,set.name == selected.set)[,paste0(f,".p.value")],")")),
xaxis=list(title=paste0(f," Effect"),zeroline=F),yaxis=list(title="-log10(p-value)",zeroline=F))
) %>% plotly::subplot(nrows=1,shareX=F,shareY=T,titleX=T,titleY=T) %>%
plotly::layout(title=selected.set)
return(gsea.plot)
}
Server:
server <- function(input, output)
{
out.plot <- reactive({
if(input$plotType == "Feature Plot"){
out.plot <- featurePlot(selected.id=dplyr::filter(model.df,symbol == input$symbol)$id[1])
} else if(input$plotType == "User-Defined Feature Set Plot"){
out.plot <- featureSetPlot(selected.ids=unique(dplyr::filter(model.df,symbol == input$set.symbols)$id))
} else if(input$plotType == "Feature Sets GSEA Plot"){
out.plot <- gseaPlot(selected.set=input$set.name)
}
})
output$feature.plot <- renderPlot({
req(input$plotType == "Feature Plot")
grid::grid.draw(out.plot())
})
output$user.defined.feature.set.plot <- renderPlot({
req(input$plotType == "User-Defined Feature Set Plot")
grid::grid.draw(out.plot())
})
output$feature.set.gsea.plot <- renderPlotly({
req(input$plotType == "Feature Sets GSEA Plot")
out.plot()
})
output$save <- downloadHandler(
filename = function() {
paste0("./plot.pdf")
},
content = function(file) {
if(input$plotType != "Feature Sets GSEA Plot"){
ggsave(out.plot(),filename=file,width=10,height=5)
} else{
plotly::export(out.plot(),file=file)
}
}
)
}
UI:
ui <- fluidPage(
tags$style(type="text/css",".shiny-output-error { visibility: hidden; }",".shiny-output-error:before { visibility: hidden; }"),
titlePanel("Results Explorer"),
sidebarLayout(
sidebarPanel(
# select plot type
selectInput("plotType","Plot Type",choices=plot.type.choices),
#in case User-Defined Feature Set Plot was chosen select the genes
conditionalPanel(condition="input.plotType == 'User-Defined Feature Set Plot'",
selectizeInput(inputId="set.symbols",label="Features Set Symbols",choices=unique(model.df$symbol),selected=model.df$symbol[1],multiple=T)),
#in case Feature Sets GSEA Plot was chosen select the databses
conditionalPanel(condition="input.plotType == 'Feature Sets GSEA Plot'",
selectizeInput(inputId="set.name",label="Set Name",choices=unique(gene.sets.df$set.name),selected=gene.sets.df$set.name[1],multiple=F)),
#in case Feature Plot was chosen select the gene
conditionalPanel(condition="input.plotType == 'Feature Plot'",
selectizeInput(inputId="symbol",label="Feature Symbol",choices=unique(model.df$symbol),selected=unique(model.df$symbol)[1],multiple=F)),
downloadButton('save', 'Save to File')
),
mainPanel(
conditionalPanel(
condition = "input.plotType == 'User-Defined Feature Set Plot'",
plotOutput("user.defined.feature.set.plot")
),
conditionalPanel(
condition = "input.plotType == 'Feature Sets GSEA Plot'",
plotly::plotlyOutput("feature.set.gsea.plot")
),
conditionalPanel(
condition = "input.plotType == 'Feature Plot'",
plotOutput("feature.plot")
)
)
)
)
Call:
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())
}
}
)

I can't get get the DT package to work correctly on Rshiny

I'm currently working on an Rshiny webapp to use for some simple classification. Currently, I've been working on creating a table that contains the CCR and MCR of both the CART and LDA methods on the data. My aim is then to highlight the column of the MCR and CCR of the best method (the method with the highest CCR... or lowest MCR). I have ran the code and viewed that it works correctly using the Viewer Pane. However, when I load the app, I obtain the error 'data' must be 2-dimensional (e.g. data frame or matrix).
Here is my code:
data <- read.csv("Fatality-task2.csv")
data$Rate <- as.factor(data$Rate)
library(shiny)
library(dplyr)
library(ggplot2)
library(markdown)
library(gtsummary)
library(ggdendro)
library(factoextra)
library(mclust)
library(cluster)
library(rpart)
library(rpart.plot)
library(DT)
#library(MASS)
glimpse(data)
#################################################################
ui <- fluidPage(
navbarPage("",
tabPanel("Data Exploration",
sidebarLayout(
sidebarPanel(
selectInput("variable",
"Variable",
colnames(data)),
selectInput("rate",
"Rate",
levels(data$Rate))
),
mainPanel(
tableOutput("table"),
plotOutput("plot")
)
)
),
tabPanel("Classification tools",
sidebarLayout(
sidebarPanel(
sliderInput("train.prop",
"Training data proportion",
min = 0.4,
max = 0.8,
step = 0.1,
value = 0.6),
radioButtons("prune",
"Pruning option",
choices = c("view pruned tree",
"view unpruned tree"))
),
mainPanel(
DTOutput("table2"),
plotOutput("plot2")
)
)
)
)
)
#################################################################
server <- function(input, output) {
output$table <- renderTable({
req(input$variable,input$rate)
data <- data %>%
filter(Rate == input$rate) %>%
dplyr::select(input$variable) %>%
summary() %>%
as.data.frame() %>%
tidyr::separate(Freq, c("Stat", "Value"), sep=":") %>%
tidyr::pivot_wider(names_from =Stat, values_from = Value)
data <- data[, -c(1,2)]
})
output$plot <- renderPlot({
req(input$variable)
if (input$variable == "jaild" | input$variable == "Rate"){
ggplot(data, aes(x = Rate, fill = .data[[as.name(input$variable)]])) +
geom_bar(position = "dodge", width = 0.7) +
if (input$variable == "Rate"){
theme(legend.position = "none")
}
} else {
ggplot(data, aes(x = Rate, y = .data[[as.name(input$variable)]], fill = Rate)) +
geom_boxplot() +
theme(legend.position = "none")
}
})
output$plot2 <- renderPlot({
req(input$train.prop,input$prune)
set.seed(1234)
n <- nrow(data)
ind1 <- sample(c(1:n), round(n*as.numeric(input$train.prop)))
ind2 <- sample(c(1:n)[-ind1], length(c(1:n)[-ind1]))
train.data <- data[ind1,]
valid.data <- data[ind2,]
fit.tree <- rpart(Rate~., data = train.data, method = "class")
ptree <- prune(fit.tree, cp = fit.tree$cptable[which.min(fit.tree$cptable[,"xerror"]),"CP"])
if (input$prune == "view pruned tree"){
rpart.plot(ptree, uniform =TRUE)
} else {
rpart.plot(fit.tree)
}
})
output$table2 <- DT::renderDT({
library(MASS)
set.seed(1234)
n <- nrow(data)
ind1 <- sample(c(1:n), round(n*0.6))
#ind2 <- sample(c(1:n)[-ind1], length(c(1:n)[-ind1]))
ind2 <- setdiff(c(1:n), ind1)
train.data <- data[ind1,]
valid.data <- data[ind2,]
#################################
### fit cart model
fit.tree <- rpart(Rate~., data = train.data, method = "class")
### prune the tree
ptree <- prune(fit.tree, cp = fit.tree$cptable[which.min(fit.tree$cptable[,"xerror"]),"CP"])
### predict using the validation data on the pruned tree
pred <- predict(ptree, newdata = valid.data[,-6], type = "class")
### lda
#lda.model <- lda(train.data[,-6], train.data[,6])
lda.model <- lda(Rate~., data = train.data)
lda.pred <- predict(lda.model, newdata = valid.data[,-6])
### create a classification table
length(lda.model)
x <- pred == valid.data[,6]
CCR <- length(x[x == TRUE])/nrow(valid.data)
MCR <- 1 - CCR
CR <- c(CCR, MCR)
z <- lda.pred$class == valid.data[,6]
lda.CCR <- length(z[z == TRUE])/nrow(valid.data)
lda.MCR <- 1 - lda.CCR
lda.CR <- c(lda.CCR, lda.MCR)
y <- cbind(CR, lda.CR)
y <- as.data.frame(y)
colnames(y) <- c("CART", "LDA")
rownames(y) <- c("CCR", "MCR")
#y
DT::datatable(y, options=list(dom = "t")) %>%
formatRound(columns = c(1,2), digits = 6) %>%
formatStyle(columns = colnames(y[which.max(y[1,])]), background = "green")
#colnames(y[1])
#colnames(y[which.max(y[1,])])
},
rownames = TRUE)
}
?formatStyle
?formatRound()
#################################################################
shinyApp(ui, server)
and here is some of my data:
"beertax","jaild","vmiles","unrate","perinc","Rate"
1.53937947750092,"no",7.23388720703125,14.3999996185303,10544.15234375,1
1.78899073600769,"no",7.83634765625,13.6999998092651,10732.7978515625,1
1.71428561210632,"no",8.262990234375,11.1000003814697,11108.791015625,1
1.65254235267639,"no",8.7269169921875,8.89999961853027,11332.626953125,1
1.60990703105927,"no",8.952853515625,9.80000019073486,11661.5068359375,1
1.55999994277954,"no",9.1663017578125,7.80000019073486,11944,1
1.50144362449646,"no",9.6743232421875,7.19999980926514,12368.6240234375,1
0.214797139167786,"yes",6.81015673828125,9.89999961853027,12309.0693359375,1
0.206422030925751,"yes",6.58749462890625,9.10000038146973,12693.8076171875,1
0.296703308820724,"yes",6.70997021484375,5,13265.93359375,1
0.381355941295624,"yes",6.7712626953125,6.5,13726.6953125,1
0.371517032384872,"yes",8.1290078125,6.90000009536743,14107.3271484375,1
0.360000014305115,"yes",9.370654296875,6.19999980926514,14241,1
0.346487015485764,"yes",9.815720703125,6.30000019073486,14408.0849609375,1
0.650358021259308,"no",7.20850048828125,9.80000019073486,10267.302734375,1
0.67545872926712,"no",7.1759169921875,10.1000003814697,10433.486328125,1
0.598901093006134,"no",7.08481982421875,8.89999961853027,10916.4833984375,1
0.577330529689789,"no",7.25391796875,8.69999980926514,11149.3642578125,1
0.562435507774353,"no",7.4689990234375,8.69999980926514,11399.380859375,1
0.545000016689301,"no",7.66583056640625,8.10000038146973,11537,1
0.52454286813736,"no",8.02462548828125,7.69999980926514,11760.3466796875,1
0.107398569583893,"no",6.8586767578125,9.89999961853027,15797.1357421875,0
0.103211015462875,"no",7.21629150390625,9.69999980926514,15970.18359375,0
0.0989011004567146,"no",7.61917578125,7.80000019073486,16590.109375,0
0.0953389853239059,"no",7.87406689453125,7.19999980926514,16985.169921875,0
0.0928792580962181,"no",8.03491015625,6.69999980926514,17356.037109375,0
0.0900000035762787,"no",8.18063330078125,5.80000019073486,17846,0
0.0866217538714409,"no",8.531990234375,5.30000019073486,18049.0859375,0
0.214797139167786,"no",7.742841796875,7.69999980926514,15082.3388671875,1
0.206422030925751,"no",7.65606298828125,6.59999990463257,15131.880859375,1
0.197802200913429,"no",7.7078525390625,5.59999990463257,15486.8134765625,0
0.190677970647812,"no",8.09220947265625,5.90000009536743,15569.9150390625,0
0.185758516192436,"no",8.13137451171875,7.40000009536743,15616.0986328125,0
0.180000007152557,"no",8.18202783203125,7.69999980926514,15605,0
0.173243507742882,"no",8.3807685546875,6.40000009536743,15845.04296875,0
0.224343672394753,"no",6.4400537109375,6.90000009536743,17255.369140625,0
0.233563080430031,"no",6.57004296875,6,17744.265625,0
0.248010993003845,"no",6.68019287109375,4.59999990463257,18760.439453125,0
0.239078402519226,"yes",6.97921484375,4.90000009536743,19312.5,0
I know the code works properly - I just want it to be able to run properly on the app. Please help!

Use the data rendered in output through DT::renderDataTable for further plotting

I have developed a shiny app, in which I am uploading a number of CSV files in each tab. After performing some mathematical operations on the uploaded data, I am getting N number of data tables as an output. I am rendering those data tables using DT::renderDataTable.
Now, let say I have 3 different datatables rendered using DT::renderDataTable I want to use the output rendered in those datatables to plot a combined graph. (3 geom_line() on top of each other)
This is how I am rendering the data in the datatable:
output$Data_FSC <- DT::renderDataTable({
x1 <- data2()[, c(input$xcol2, input$ycol2)]
M <- x1
#calculate rotation angle
alpha <- -atan((M[1,2]-tail(M,1)[,2])/(M[1,1]-tail(M,1)[,1]))
#rotation matrix
rotm <- matrix(c(cos(alpha),sin(alpha),-sin(alpha),cos(alpha)),ncol=2)
#shift, rotate, shift back
M2 <- t(rotm %*% (t(M)-c(M[1,1],M[1,2]))+c(M[1,1],M[1,2]))
M2[nrow(M2),2] <- M2[1,2]
M2
d_f3 <- data.frame(x = M2[,1], y = (M2[,2]-min(M2[1,2])))
v_f1 <- subset(d_f3, y > ((input$below2)/1000) & y < ((input$above2)/1000), select = c(x,y))
fla_upper2 <- lm(formula = y+((input$Upper_Poly_Limit2)/1000000) ~ poly(x,input$degree2, raw = TRUE), v_f1)
fla_lower2 <- lm(formula = y-((input$Lower_Poly_Limit2)/1000000) ~ poly(x,input$degree2, raw = TRUE), v_f1)
v_f1$upper2 <- predict(fla_upper2, newdata=v_f1)
v_f1$lower2 <- predict(fla_lower2, newdata=v_f1)
v_f1$region2 <- ifelse(v_f1[,2] <= v_f1$upper2 & v_f1[,2] >= v_f1$lower2, 'inside', 'outside')
kl <- subset(v_f1, region2 =='inside')
g <- ggplot() + theme_bw() +
geom_smooth(data = kl, aes_string(kl[,1], kl[,2]), formula = y ~ poly(x,input$degree_2, raw = TRUE), method = "lm", color = "green3", level = 1, size = 0.5)
r <- ggplot_build(g)$data[[1]]
q <- data.frame(x = r[,1], y = r[,2])
#calculate rotation angle
beta <- -atan((q[1,2]-tail(q,1)[,2])/(q[1,1]-tail(q,1)[,1]))
#rotation matrix
rot_m <- matrix(c(cos(beta),sin(beta),-sin(beta),cos(beta)),ncol=2)
#shift, rotate, shift back
M_2 <- t(rot_m %*% (t(q)-c(q[1,1],q[1,2]))+c(q[1,1],q[1,2]))
M_2[nrow(M_2),2] <- M_2[1,2]
M_2
M_3 <- data.frame(x= (M_2[,1]-median(M_2[,1])), y= (M_2[,2]-min(M_2[,2])))
the_data <- reactive(M_3)
the_data()
})
I tried feeding the output of the DT::renderDataTable as input for ggplot but my shiny app is showing me an error saying that
Reading from shinyoutput object is not allowed.
I already knew that 'Reading from shinyoutput object is not allowed'.
I just want to know whether there is any way I can use the output rendered in datatable for further plotting in a shiny app.
Here's a MWE demonstrating what I think you want to do.
Notice the separation of data from presentation: t1, t2 and t3 are reactives representing your CSV files. Each is rendered in a different data table. allData is a reactive containing union of the CSV data. This is used as the source data for the plot.
library(shiny)
library(DT)
library(tidyverse)
ui <- fluidPage(
numericInput("n", "Number of points:", min=2, max=20, value=10),
plotOutput("plot"),
dataTableOutput("table1"),
dataTableOutput("table2"),
dataTableOutput("table3")
)
server <- function(input, output) {
t1 <- reactive({ tibble(x=1:input$n, y=rnorm(input$n), key="Table 1") })
t2 <- reactive({ tibble(x=1:input$n, y=rnorm(input$n), key="Table 2") })
t3 <- reactive({ tibble(x=1:input$n, y=rnorm(input$n), key="Table 3") })
allData <- reactive({ bind_rows(t1(), t2(), t3()) })
output$table1 <- renderDT({ t1() })
output$table2 <- renderDT({ t2() })
output$table3 <- renderDT({ t3() })
output$plot <-renderPlot({ allData() %>% ggplot() + geom_line(aes(x=x, y=y, colour=key)) })
}
shinyApp(ui = ui, server = server)
It might be worth looking at using modules to manage and present the CSV files.

simplify the subset of a table using multiple conditions in R shiny

I am writing a shiny app (shinydashboard) that looks like the figure (the app run on my company private network,so I can't share the link to it).
The dataset consists of a table containing the expression values of different genes (rows) for different samples (columns).
The app should return a subset of that table based on the search criteria selected by the user. Information about the samples are stored in a different table (B38.Metadata in the code), that looks like this:
SampleID,RNA.ID,RNAseq.ID,Name,Description,Tissue Type,...
CP3027,CP3027,74,Hs514,Aortic_Endothelial,Vascular system,Endothelial,...
CP3028,CP3028,76,HEr1,Aortic_Endothelial,Vascular system,Endothelial,...
At every search, the metadata are checked and the main table is subset accordingly.
My approach has been to write a function for each search types (SearchByGene,SearchByTissue,...), and
use if-else statements to account for all the possible combinations.
For example, filter by GeneName, Tissue type, and Name, but not for the other options.
This led to a massive 14 if-else block, spanning almost 50 lines of code (see below).
everything works, but the code is dreadful to read and debug.
Furthermore the idea of adding additional search possibilities (e.g. search by sequencing technique)
made me shiver.
I considered using a switch construct, but, having multiple conditions to test I'm not sure it will clean the code too much.
Is there a way of simplify the if-else block with something easier to read and, especially, maintain?
Searchfunction <- function(dataSet2){
selectedTable <- reactive({
# Create a DF with only the gene names
DFgeneLevel <- DummyDFgeneLevel(dataSet2) # not used for now
# Subset by Columns first
if(is.null(input$tissues) && is.null(input$samples) && is.null(input$Name)){
TableByColumns <- dataSet2
} else if(!is.null(input$tissues) && !is.null(input$samples) && !is.null(input$Name)){
TableByTissue <- SearchByTissue(input$tissues,B38.metadata,dataSet2)
TableBySample <- SearchBySample(input$samples,TableByTissue)
TableByColumns <- SearchByName(input$Name,B38.metadata,TableBySample)
} else if(!is.null(input$tissues)){
if(is.null(input$samples) && is.null(input$Name)){
TableByColumns <- SearchByTissue(input$tissues,B38.metadata,dataSet2)
} else if(is.null(input$samples) && !is.null(input$Name)){
TableByTissue <- SearchByTissue(input$tissues,B38.metadata,dataSet2)
TableByColumns <- SearchByName(input$Name,B38.metadata,TableByTissue)
} else if(!is.null(input$samples) && is.null(input$Name)){
TableByTissue <- SearchByTissue(input$tissues,B38.metadata,dataSet2)
TableByColumns <- SearchBySample(input$samples,TableByTissue)
}
} else if(is.null(input$tissues)){
if(is.null(input$samples) && !is.null(input$Name)){
TableByColumns <- SearchByName(input$Name,B38.metadata,dataSet2)
} else if(!is.null(input$samples) && is.null(input$Name)){
TableByColumns <- SearchBySample(input$samples,dataSet2)
} else if(!is.null(input$samples) && !is.null(input$Name)){
TableByName <- SearchBySample(input$samples,dataSet2)
TableByColumns <- SearchByName(input$Name,B38.metadata,TableByName)
}
}
# Collect all the inputs & subset by Rows
#genes.Selected <- toupper(genes.Selected) # can't use it as some genes contains lowerletters
genesFromList <- unlist(strsplit(input$genesLists,","))
genes.Selected <- unlist(strsplit(input$SearchCrit," "))
if(input$SearchCrit == '' && input$genesLists == 0){
TableByRow <- TableByColumns
} else if(input$SearchCrit != '' && input$genesLists != 0){
TableByList <- subset(TableByColumns, TableByColumns$GeneName %in% genesFromList)
TableByRow <- subset(TableByList, TableByList$GeneName %in% genes.Selected)
} else if(input$SearchCrit != '' && input$genesLists == 0){
TableByRow <- subset(TableByColumns, TableByColumns$GeneName %in% genes.Selected)
} else if(input$SearchCrit == '' && input$genesLists != 0) {
TableByRow <- subset(TableByColumns, TableByColumns$GeneName %in% genesFromList)
}
return(TableByRow)
})
}
Is that what you are trying to achieve ?
Filter samples that match your attributes based on your metadata and display gene expressions only for these samples ?
library(shiny)
library(dplyr)
ui <- fluidPage(
titlePanel("mtcars"),
sidebarLayout(
sidebarPanel(
selectInput("vs",
label = "vs",
choices = c(0, 1),
selected = NULL,
multiple = TRUE),
selectInput("carb",
label = "carb",
choices = c(1, 2, 3, 4, 6, 8),
selected = NULL,
multiple = TRUE),
selectInput("gear",
label = "gear",
choices = c(3, 4, 5),
selected = NULL,
multiple = TRUE)
),
mainPanel(
tabsetPanel(
tabPanel("Expression values", tableOutput("mainTable")),
tabPanel("ID filtering", tableOutput("table"))
)
)
)
)
server <- function(input, output) {
samples.df <- data.frame(ID = paste0("ID", as.character(round(runif(nrow(mtcars),
min = 0,
max = 100 * nrow(mtcars))))),
gear = as.factor(mtcars$gear),
carb = as.factor(mtcars$carb),
vs = as.factor(mtcars$vs))
values.df <- cbind(paste0("Feature", 1:20),
as.data.frame(matrix(runif(20 * nrow(samples.df)), nrow = 20)))
colnames(values.df) <- c("Feature", as.character(samples.df$ID))
vs.values <- reactive({
if (is.null(input$vs)) {
return(c(0, 1))
} else {
return(input$vs)
}
})
carb.values <- reactive({
if (is.null(input$carb)) {
return(c(1, 2, 3, 4, 6, 8))
} else {
return(input$carb)
}
})
gear.values <- reactive({
if (is.null(input$gear)) {
return(c(3, 4, 5))
} else {
return(input$gear)
}
})
filtered.samples.df <- reactive({
return(samples.df %>% filter(gear %in% gear.values(),
vs %in% vs.values(),
carb %in% carb.values()))
})
filtered.values.df <- reactive({
selected.samples <- c("Feature", names(values.df)[names(values.df) %in% filtered.samples.df()$ID])
return(values.df %>% select(selected.samples))
})
output$mainTable <- renderTable({
filtered.values.df()
})
output$table <- renderTable({
filtered.samples.df()
})
}
shinyApp(ui = ui, server = server)
You can try something like this, where we loop over the inputs and subset on the according column if the input is not null.
Hope this helps!
library(shiny)
ui <- fluidPage(
selectizeInput('mpg','mpg:',unique(mtcars$mpg),multiple=T),
selectizeInput('cyl','cyl:',unique(mtcars$cyl),multiple=T),
selectizeInput('gear','gear:',unique(mtcars$gear),multiple=T),
selectizeInput('carb','carb:',unique(mtcars$carb),multiple=T),
tableOutput('mytable')
)
server <- function(input,output)
{
output$mytable <- renderTable({
df = mtcars
select_inputs = c('mpg','cyl','gear','carb')
for (inp in select_inputs)
{
if(!is.null(input[[inp]]))
{
df = df[df[[inp]] %in% input[[inp]],]
}
}
df
})
}
shinyApp(ui,server)

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)

Resources