Select current plot and download to file - r

How can I save the current plot that is displayed on the mainPanel? I am having trouble pointing the correct graphic to the download Handler. This is what I have:
library(shiny)
library(ggplot2)
library(tidyverse)
library(shinythemes)
library(plotly)
library(scales)
library(shinyWidgets)
library(shinydashboard)
library(shinyjs)
# Define input choices
type <- c("first", "second")
#Data for lambda
table <- structure(list(year = 1991:2010, lambda = c(0.68854, 0.75545,
1.63359, 1.22282, 1.70744, 1.09692, 0.51159, 1.3904, 1.09132,
0.59846, 0.43055, 0.80135, 0.69027, 0.65646, 0.95485, 1.04818,
0.67859, 1.00461, 1.16665, 1.28203)), row.names = c(NA, -20L), class = "data.frame")
ui <- fluidPage(
useShinyjs(), # to initialise shinyjs
navbarPage("Test",
windowTitle = "A Test",
sidebarPanel(
h3(""),
#Dropdown to select the desired kind of graphic
selectInput(inputId = "graphtype",
label = "Graphic",
choices = type,
selected = "first"),
disabled( #start as disabled
checkboxInput("Fixed","Fixed Y axes", FALSE))),
downloadButton('downloadPlot', 'Download Plot'),
#Graphic Area mainPanel. Graphic on top and table right below it
mainPanel(plotOutput("plot"),
dataTableOutput("mytable"))
))
###################################################################################################
server<- function (input, output, session) {
session$onSessionEnded(function() {
stopApp()
})
#Plot data
output$plot <- renderPlot({
xlabels <- 1991:2011
switch(input$graphtype,
"first" = {
disable("Fixed")
print(ggplot(table,aes(year,lambda)) + geom_line(size=1.5,colour="blue") + geom_point(colour="orange",size=4) +
scale_x_continuous("",breaks = xlabels) +
theme(axis.text.x = element_text(angle = 45, vjust = 0.5)) +
labs(x="",y="test",title= paste0("Population growth rate of Fish ")))
},
{
enable("Fixed")
if(input$Fixed == FALSE){
"second" <- print(ggplot(table,aes(year,lambda)) + geom_line(size=1.5,colour="red") + geom_point(colour="green",size=4) +
scale_x_continuous("",breaks = xlabels) +
theme(axis.text.x = element_text(angle = 45, vjust = 0.5)) +
labs(x="",y="fish test",title= paste0("Population growth")))
}
else{
"second" <- print(ggplot(table,aes(year,lambda)) + geom_line(size=1.5,colour="yellow") + geom_point(colour="green",size=4) +
scale_x_continuous("",breaks = xlabels) +
theme(axis.text.x = element_text(angle = 45, vjust = 0.5)) +
labs(x="",y="fish test",title= paste0("Population growth")))
}
}
)
output$downloadPlot <- downloadHandler(
filename = "plot.png" ,
content = function(file) {
ggsave(plot(), filename = file)
})
})
}
shinyApp(ui = ui, server = server)

One option would be to move your plotting code to a reactive. This way you could print your plot inside renderPlot but also pass the plot to the ggsave inside the downloadHandler. Additionally I cleaned up the code to switch between the plots a little bit.
Note: I moved the download button to the sidebar because otherwise it would not work. Also, I made the code more minimal by removing all the unnecessary packages and code.
library(shiny)
library(ggplot2)
# Define input choices
type <- c("first", "second")
# Data for lambda
table <- structure(list(year = 1991:2010, lambda = c(
0.68854, 0.75545,
1.63359, 1.22282, 1.70744, 1.09692, 0.51159, 1.3904, 1.09132,
0.59846, 0.43055, 0.80135, 0.69027, 0.65646, 0.95485, 1.04818,
0.67859, 1.00461, 1.16665, 1.28203
)), row.names = c(NA, -20L), class = "data.frame")
ui <- fluidPage(
sidebarPanel(
h3(""),
# Dropdown to select the desired kind of graphic
selectInput(
inputId = "graphtype",
label = "Graphic",
choices = type,
selected = "first"
),
checkboxInput("Fixed", "Fixed Y axes", FALSE),
downloadButton("downloadPlot", "Download Plot")
),
# Graphic Area mainPanel. Graphic on top and table right below it
mainPanel(
plotOutput("plot"),
dataTableOutput("mytable")
)
)
###################################################################################################
server <- function(input, output, session) {
session$onSessionEnded(function() {
stopApp()
})
# Plot data
create_plot <- reactive({
xlabels <- 1991:2011
if (input$graphtype == "first") {
ggplot(table, aes(year, lambda)) +
geom_line(size = 1.5, colour = "blue") +
geom_point(colour = "orange", size = 4) +
scale_x_continuous("", breaks = xlabels) +
theme(axis.text.x = element_text(angle = 45, vjust = 0.5)) +
labs(x = "", y = "test", title = paste0("Population growth rate of Fish "))
} else {
if (!input$Fixed) {
ggplot(table, aes(year, lambda)) +
geom_line(size = 1.5, colour = "red") +
geom_point(colour = "green", size = 4) +
scale_x_continuous("", breaks = xlabels) +
theme(axis.text.x = element_text(angle = 45, vjust = 0.5)) +
labs(x = "", y = "fish test", title = paste0("Population growth"))
} else {
ggplot(table, aes(year, lambda)) +
geom_line(size = 1.5, colour = "yellow") +
geom_point(colour = "green", size = 4) +
scale_x_continuous("", breaks = xlabels) +
theme(axis.text.x = element_text(angle = 45, vjust = 0.5)) +
labs(x = "", y = "fish test", title = paste0("Population growth"))
}
}
})
output$plot <- renderPlot({
create_plot()
})
output$downloadPlot <- downloadHandler(
filename = function() "plot.png",
content = function(file) {
ggsave(create_plot(), filename = file)
}
)
}
shinyApp(ui = ui, server = server)

Related

Shiny Error: arguments must have the same length

I am trying to create a shiny app bar plot with dataframe columns (x variables) as input selections. One solution has been posted online already, but it has not worked for me.
My code is the following:
ui <- fluidPage(
sidebarLayout(position = "left",
sidebarPanel(
selectInput('x', "Funding:", choices = c('source_location',
'source_organizationtype','destination_purpose','destination_organizationtype'),
selected = NULL),
theme = shinytheme("cerulean")),
mainPanel(plotOutput("outplot"))
))
server <- function(input, output) {
output$outplot <- renderPlot( {
selected_data <- graph_funds_data %>% select(input$x, funding)
ggplot(selected_data, aes(x= reorder( !! input$x, funding), y = funding,
fill = !! input$x,
color = !! input$x)) +
geom_bar(position="stack", stat= 'identity') +
theme_minimal() + labs(x = as.name(input$x), y = 'Funding in Billions (USD)',
title = 'Total Incoming Ukraine Crisis Funding',
subtitle = 'January-April 2022') +
theme(legend.position="bottom", legend.title=element_blank(),
legend.direction="horizontal", legend.box="vertical")
} )
}
shinyApp(ui = ui, server = server, options = list(height=1000))
And I get 'Error: arguments must have same length'
I have also tried:
ui <- fluidPage(
sidebarLayout(position = "left",
sidebarPanel(
selectInput('x', "Funding:", choices = c('source_location',
'source_organizationtype','destination_purpose','destination_organizationtype'),
selected = NULL),
theme = shinytheme("cerulean")),
mainPanel(plotOutput("outplot"))
))
server <- function(input, output) {
output$outplot <- renderPlot( {
selected_data <- graph_funds_data %>% select(input$x, funding)
ggplot(selected_data(), aes(x= reorder(selected_data()[[input$x]], funding), y = funding,
fill = selected_data()[[input$x]],
color = selected_data()[[input$x]])) +
geom_bar(position="stack", stat= 'identity') +
theme_minimal() + labs(x = as.name(input$x), y = 'Funding in Billions (USD)',
title = 'Total Incoming Ukraine Crisis Funding',
subtitle = 'January-April 2022') +
theme(legend.position="bottom", legend.title=element_blank(),
legend.direction="horizontal", legend.box="vertical")
} )
}
shinyApp(ui = ui, server = server, options = list(height=1000))
And I get 'Error: Could not find function "selected_data"'
Does anyone know how to fix this?

How can I fill my density chart with 2 factors in with shiny

In my first panel, I have plot where I enter data by clicking or double clinking depending on the situation. If it's one click it categorized as a shot and if it's a double click it is categorized as a goal.
Simultaneously, on another Tab, I am creating a heat map of all of those shots. However, in my heat map (produced in my code in output$chart) I would like to have two different colours on the same heat map. One colour representing the shots and the other one representing the goal.
Thank you for your help
library(shiny)
library(ggplot2)
ui <- fluidPage(
titlePanel("Hockey"),
tags$img(height = 100, width = 100,
src = "Logo.png"),
sidebarPanel(
textInput(inputId = "date",
label = "Date",
value = "yyyy/mm/dd"),
textInput(inputId = "team",
label = "Team Name",
value = "Team Name"),
selectInput("shot", "shot type:",
list(`Shot Type` = list("wrist shot", "slap shot", "snap shot", "backhand", "tap in", "deflection", "one timer", "wrap around"))),
actionButton("reset", "Clear")),
mainPanel(tabsetPanel(
tabPanel("Track", plotOutput(outputId = "hockeyplot", click = "plot_click", dblclick = "plot_dblclick")),
tabPanel("Chart", plotOutput(outputId = "chart")),
server <- function(input, output){
rv <- reactiveValues(
df = data.frame(
x = numeric(),
y = numeric(),
Date = as.Date(character()),
Team = character(),
ShotType = character(),
Type = factor()
)
)
output$hockeyplot = renderPlot({
ggplot(rv$df,
aes(x = x, y = y)) + coord_flip() + lims(x = c(0, 100), y = c(42.5, -42.5)) + geom_blank + geom_point( aes(colour = factor(Type)), size = 5 ) + theme(legend.position = "none")})
observeEvent(input$plot_click, {
rv$df <- rbind(rv$df, data.frame(
x = input$plot_click$y,
y = input$plot_click$x,
Date = input$date,
Team = input$team,
ShotType = input$shot,
Type = "Shot"))
})
observeEvent(input$plot_dblclick, {
rv$df <- rbind(rv$df, data.frame(
x = input$plot_dblclick$y,
y = input$plot_dblclick$x,
Date = input$date,
Team = input$team,
ShotType = input$shot,
Type = "Goal"))
})
observeEvent(input$reset,{
rv$df <- rv$df[-nrow(rv$df),]
})
output$chart = renderPlot({
ggplot(rv$df, aes(x = x, y = y)) +
coord_flip()+
lims(x = c(0, 100), y = c(42.5, -42.5)) +
geom_blank+
theme(legend.position = "none") +
stat_density_2d(aes(fill = "shot"), geom = 'polygon', alpha = 0.4)
})
Here is a working example.
I created a vector my_colors to assign colors to "Shot" and "Goal" so they are consistent across figures, and will not change if Type factor has different number of levels.
I also included factor when adding rows to your rv$df. That way, you also won't have a change in color as the number of levels change for Type. When I tried running the app initially, the colors would change after a second Type was added ("Shot" or "Goal").
In stat_2_density, you can change fill to Type. Again, you can specify scale_fill_manual to assign the same colors.
Please let me know if this is what you had in mind.
library(shiny)
library(ggplot2)
my_colours = c("Shot" = "blue", "Goal" = "green")
ui <- fluidPage(
titlePanel("Hockey"),
tags$img(height = 100, width = 100, src = "Logo.png"),
sidebarPanel(
textInput(inputId = "date",
label = "Date",
value = "yyyy/mm/dd"),
textInput(inputId = "team",
label = "Team Name",
value = "Team Name"),
selectInput("shot", "shot type:",
list(`Shot Type` = list("wrist shot", "slap shot", "snap shot", "backhand", "tap in", "deflection", "one timer", "wrap around"))),
actionButton("reset", "Clear")),
mainPanel(tabsetPanel(
tabPanel("Track", plotOutput(outputId = "hockeyplot", click = "plot_click", dblclick = "plot_dblclick")),
tabPanel("Chart", plotOutput(outputId = "chart"))
))
)
server <- function(input, output){
rv <- reactiveValues(
df = data.frame(
x = numeric(),
y = numeric(),
Date = as.Date(character()),
Team = character(),
ShotType = character(),
Type = factor(levels = c("Shot", "Goal"))
)
)
output$hockeyplot = renderPlot({
ggplot(rv$df, aes(x = x, y = y)) +
coord_flip() +
lims(x = c(0, 100), y = c(42.5, -42.5)) +
geom_blank() +
geom_point(aes(color = Type), size = 5 ) +
theme(legend.position = "none") +
scale_color_manual(values = my_colours)
})
observeEvent(input$plot_click, {
rv$df <- rbind(rv$df, data.frame(
x = input$plot_click$y,
y = input$plot_click$x,
Date = input$date,
Team = input$team,
ShotType = input$shot,
Type = factor("Shot", levels = c("Shot", "Goal"))))
})
observeEvent(input$plot_dblclick, {
rv$df <- rbind(rv$df, data.frame(
x = input$plot_dblclick$y,
y = input$plot_dblclick$x,
Date = input$date,
Team = input$team,
ShotType = input$shot,
Type = factor("Goal", levels = c("Shot", "Goal"))))
})
observeEvent(input$reset,{
rv$df <- rv$df[-nrow(rv$df),]
})
output$chart = renderPlot({
ggplot(rv$df, aes(x = x, y = y)) +
coord_flip()+
lims(x = c(0, 100), y = c(42.5, -42.5)) +
geom_blank()+
theme(legend.position = "none") +
stat_density_2d(aes(fill = Type), geom = 'polygon', alpha = .4) +
scale_fill_manual(values = my_colours)
})
}
shinyApp(ui, server)

Existing file not being read/accessed/located by r

I have a shiny app to plot a heatmap of the income and other aspects.
library(shiny)
library(ggplot2)
library(gplots)
ui <- fluidPage(
titlePanel("Creating a database"),
sidebarLayout(
sidebarPanel(
textInput("name", "Company Name"),
numericInput("income", "Income", value = 1),
numericInput("expenditure", "Expenditure", value = 1),
dateInput("date", h3("Date input"),value = Sys.Date() ,min = "0000-01-01",
max = Sys.Date(), format = "dd/mm/yy"),
actionButton("Action", "Submit"),#Submit Button
actionButton("new", "New")),
mainPanel(
tabsetPanel(type = "tabs",
tabPanel("Table", tableOutput("table")),
tabPanel("Download",
textInput("filename", "Enter Filename for download"), #filename
helpText(strong("Warning: Append if want to update existing data.")),
downloadButton('downloadData', 'Download'), #Button to save the file
downloadButton('Appenddata', 'Append')),#Button to update a file )
tabPanel("Plot",
actionButton("filechoose", "Choose File"),
br(),
selectInput("toplot", "To Plot", choices =c("Income" = "inc1",
"Expenditure" = "exp1",
"Compare Income And
Expenditure" = "cmp1",
"Gross Profit" = "gprofit1",
"Net Profit" = "nprofit1",
"Profit Lost" = "plost1",
"Profit Percent" = "pp1",
"Profit Trend" = "proftrend1"
)),
actionButton("plotit", "PLOT"),
plotOutput("Plot")),
tabPanel("Heatmap",
actionButton("combine","Combine"),
selectInput("ploth", "Plot Heatmap Of", choices =c("Income" = "inc1",
"Expenditure" = "exp1",
"Gross Profit" = "gprofit1",
"Net Profit" = "nprofit1")),
actionButton("hplotit","Plot Heatmap"),
plotlyOutput("HeatPlot"),
plotlyOutput("Next")
)
)
)
)
)
# Define server logic required to draw a histogram
server <- function(input, output){
#Global variable to save the data
Data <- data.frame()
Results <- reactive(data.frame(input$name, input$income, input$expenditure,
as.character(input$date),
as.character(Sys.Date())))
#To append the row and display in the table when the submit button is clicked
observeEvent(input$Action,{
Data <<- rbind(Data,Results()) #Append the row in the dataframe
output$table <- renderTable(Data) #Display the output in the table
})
observeEvent(input$new, {
Data <<- NULL
output$table <- renderTable(Data)
})
observeEvent(input$filechoose, {
Data <<- read.csv(file.choose()) #Choose file to plot
output$table <- renderTable(Data) #Display the choosen file details
})
output$downloadData <- downloadHandler(
filename = function() {
paste(input$filename , ".csv", sep="")}, # Create the download file name
content = function(file) {
write.csv(Data, file,row.names = FALSE) # download data
})
output$Appenddata <- downloadHandler(
filename = function() {
paste(input$filename, ".csv", sep="")},
content = function(file) {
write.table( Data, file=file.choose(),append = T, sep=',',
row.names = FALSE, col.names = FALSE) # Append data in existing
})
observeEvent(input$plotit, {
inc <- c(Data[ ,2])
exp <- c(Data[ ,3])
date <- c(Data[,4])
gprofit <- c(Data[ ,2]- Data[ ,3])
nprofit <- c(gprofit - (gprofit*0.06))
z <- as.numeric(nrow(Data))
plost <- gprofit - nprofit
pp <- (gprofit/inc) * 100
proftrend <- c(gprofit[2:z]-gprofit[1:(z-1)])
slope = c(((proftrend[2:(z-1)]-proftrend[1:(z-2)])/1),0)
y = input$toplot
switch(EXPR = y ,
inc = output$Plot <- renderPlot(ggplot(data = Data, aes(x= Data[,4], y= inc))+
geom_bar(stat = "identity",
fill = "blue")+xlab("Dates")+
ylab("Income")+
theme(axis.text.x = element_text(angle = 90))),
exp = output$Plot <- renderPlot(ggplot(data = Data, aes(x= Data[,4], y= exp))+
geom_bar(stat = "identity",
fill = "red")+xlab("Dates")+
ylab("Expenditure")+
theme(axis.text.x = element_text(angle = 90))),
cmp = output$Plot <- renderPlot(ggplot(data = Data, aes(x= Data[,4]))+
geom_line(aes(y= inc,group = 1, colour = "Income"))
+ geom_line(aes(y= exp,group =1, colour = "Expenditure"))+
xlab("Dates")+ ylab("Income (in lakhs)")+
scale_color_manual("",
breaks = c("Income","Expenditure"),
values = c(
"Income"="green", "Expenditure"= "red"
))+
theme(axis.text.x = element_text(angle = 90))),
gprofit = output$Plot <- renderPlot(ggplot(data = Data, aes(x= Data[,4], y= gprofit))+
geom_bar(stat = "identity",
fill = "blue")+xlab("Dates")+
ylab("Gross Profit (in lakhs)")+
theme(axis.text.x = element_text(angle = 90))),
nprofit = output$Plot <- renderPlot(ggplot(data = Data, aes(x= Data[,4], y= nprofit))
+geom_bar(stat = "identity",
fill = "blue")+xlab("Dates")+
ylab("Net Profit (in lakhs)")+
theme(axis.text.x = element_text(angle = 90))),
plost = output$Plot <- renderPlot(ggplot(data = Data, aes(x= Data[,4], y= plost))
+geom_bar(stat = "identity",
fill = "blue")+xlab("Dates")+
ylab("Profit Lost (in lakhs)")+
theme(axis.text.x = element_text(angle = 90))),
pp = output$Plot <- renderPlot(ggplot(data = Data, aes(x= Data[,4], y= pp))+
geom_bar(stat = "identity",
fill = "blue")+xlab("Dates")+
ylab("Profit Percentage")+
theme(axis.text.x = element_text(angle = 90))),
proftrend = output$Plot <- renderPlot(ggplot()+
geom_line(data = as.data.frame(date[2:z]),
aes(x= Data[c(2:z),4] , y= proftrend,
group = 1, color = slope > 0))+
xlab("Dates")+ ylab("Profit Trend")+
theme(axis.text.x = element_text(angle = 90))
))})
observeEvent(input$combine, {
Data <<- cbind(read.csv(file.choose()),read.csv(file.choose()),read.csv(file.choose()),read.csv(file.choose()))
output$table <- renderTable(Data)}) #Display the choosen file details
observeEvent(input$hplotit, {
inc1 <- as.data.frame(cbind(Dummy1 = Data[,2],Dummy2 = Data[,7],Dummy3 = Data[,12], Dummy4 = Data[,17]))
inc1 <- as.matrix(inc1)
exp1 <- as.data.frame(cbind(Dummy1 = Data[,3],Dummy2 = Data[,8],Dummy3 = Data[,13], Dummy4 = Data[,18]))
exp1 <- as.matrix(exp1)
gprofit1 <- as.data.frame(cbind(Dummy1 = Data[,3] - Data[,2],
Dummy2 = Data[,8] - Data[,7],
Dummy3 = Data[,13] - Data[,12],
Dummy4 = Data[,18] - Data[,17]))
gprofit1 <- as.matrix(gprofit1)
nprofit1 <- as.data.frame(cbind(Dummy1 = (Data[,3] - Data[,2]) - ((Data[,3] - Data[,2]) * 0.06),
Dummy2 = (Data[,8] - Data[,7]) - ((Data[,8] - Data[,7]) * 0.10),
Dummy3 = (Data[,13] - Data[,12]) - ((Data[,13] - Data[,12]) * 0.18),
Dummy4 = (Data[,18] - Data[,17]) - ((Data[,18] - Data[,17]) * 0.22)))
nprofit1 <- as.matrix(nprofit1)
date <- as.character(Data[,4])
h = input$ploth
switch(EXPR = h ,
inc1 = output$HeatPlot <- renderPlotly( plot_ly(x = colnames(inc1), y = date, z = inc1, type = "heatmap", colorscale = "Earth")),
exp1 = output$HeatPlot <- renderPlotly( plot_ly(x = colnames(exp1), y = date, z = exp1, type = "heatmap", colors = colorRamp(c("red", "yellow")))),
gprofit1 = output$HeatPlot <- renderPlotly( plot_ly(x = colnames(gprofit1), y = date, z = gprofit1, type = "heatmap", colorscale="Greys")),
nprofit1 = output$HeatPlot <- renderPlotly( plot_ly(x = colnames(nprofit1), y = date, z = nprofit1, type = "heatmap"))
)
})
}
# Run the application
shinyApp(ui = ui, server = server)
With the ui being like
Now when i open the app and try to plot the income the following error is shown
Error in getExportedValue: cannot open file '~/R/x86_64-pc-linux-gnu-library/3.4/viridisLite/data/Rdata.rdb': No such file or directory
But when i try to plot the next item(expenditure) in the selectinput the heatmap appears witout any problem and it is pitch perfect of what is exactly needed.
Moreover when i check the file in the location it appears that the file is present
/home/mrshekar/R/x86_64-pc-linux-gnu-library/3.4/viridisLite/data
What is it that i am missing? Any particular package to extract that folder? Or is that file is supposed to be present somewhere else? Please help.
Delete the viridisLite folder from there and then install the package once more. This seems to work just fine. I had a similar problem. If the problem still persists then also delete the normal viridis package and install that also. This will solve your problem. Also update your packages. That also sometimes gives problems.

shiny checkboxGroupInput ggplots as list

Could anyone suggest me the way to extract shiny checkboxgroupoinput options of different ggplots such as geom_bar(), geom_line() as a list. I tried the following simplified code, it prints only the last plot: Thanks for your help.
library(shiny)
library(ggplot2)
library(easyGgplot2)
patient <- cbind.data.frame(seq(1:14),matrix(sample(1:100, 84), ncol=6))
colnames(patient) <- c('DAYS', 'PHYSICAL_ACTIVITY', 'SMOKING','ALCOHOL_INTAKE', 'HYDRATION', 'SLEEP', 'Total_score')
ui <- fluidPage(
titlePanel("Data Plot"),
sidebarLayout(
sidebarPanel(
fluidRow(column(6,
checkboxGroupInput("checkGroup",
("Parameters"),
list("PHYSICAL ACTIVITY" = 1,
"SLEEP" = 2,
"ALCOHOL INTAKE" = 3,
"SELECT ALL" = 4
)))
),
fluidRow(column(10, actionButton("goButton", label = "Analysis Report"))
)
), #Sidebarpanel
mainPanel(
plotOutput("plot1", height='800px')
)#Mainpanel
) #Sidebar layout
)#fluidpage
server <- function(input, output) {
output$plot1 <- renderPlot({
input$goButton
p1 <- reactive({
if(!(1 %in% input$checkGroup)) return(NULL)
ggplot(data=patient, aes(x=DAYS, y=PHYSICAL_ACTIVITY))+geom_bar(stat="identity", aes(fill=PHYSICAL_ACTIVITY<=median(PHYSICAL_ACTIVITY)), show.legend=F)+scale_fill_manual(values = c('steelblue', 'red') )+labs(title = 'PHYSICAL ACTIVITY (STEPS)', x = NULL, y = NULL)+theme_minimal()
})
# Second plot
p2 <- reactive ({
if(!(2 %in% input$checkGroup )) return(NULL)
p2 <- ggplot(data=patient, aes(x=DAYS,y=SLEEP))+geom_line(colour='black', size=1)+geom_point(size=3, aes(colour=cut(SLEEP,c(-Inf,summary(SLEEP)[[2]],summary(SLEEP)[[5]],Inf))), show.legend=F)+scale_color_manual(values = c("red", "orange","green"))+labs(title = 'SLEEP (hrs)', x = NULL, y = NULL) +theme_minimal()
})
ptlist <- list(p1(),p2())
ggplot2.multiplot(ptlist, cols=1)
})
}
shinyApp(ui, server)
Example with reading csv.
library(shiny)
library(ggplot2)
library(easyGgplot2)
patient <- cbind.data.frame(
seq(1:14),
matrix(
sample(1:100, 84),
ncol = 6
)
)
colnames(patient) <- c(
'DAYS',
'PHYSICAL_ACTIVITY',
'SMOKING',
'ALCOHOL_INTAKE',
'HYDRATION',
'SLEEP',
'Total_score'
)
write.csv(patient, file="patient.csv")
ui <- fluidPage(
titlePanel("Data Plot"),
sidebarLayout(
sidebarPanel(
fluidRow(
column(6,
checkboxGroupInput(
"checkGroup",
"Parameters",
list(
"PHYSICAL ACTIVITY",
"SLEEP"),
selected = "PHYSICAL ACTIVITY")
)
),
fluidRow(
fileInput("file1", "Choose Data sheet",
multiple = TRUE,
accept = c("text/csv",
"text/comma-separated-values,text/plain",
".csv"))
)
),
mainPanel(
plotOutput("plots")
)
)
)
server <- function(input, output) {
patient <- reactive({
req(input$file1)
read.csv(input$file1$datapath,
header = T
)
})
plot_one <- function(patient.data) {
ggplot(patient.data, aes(x = DAYS, y = PHYSICAL_ACTIVITY)) +
geom_bar(
stat = "identity",
aes(fill = PHYSICAL_ACTIVITY <= median(PHYSICAL_ACTIVITY)),
show.legend = F) +
scale_fill_manual(
values = c('steelblue', 'red')) +
labs(title = 'PHYSICAL ACTIVITY (STEPS)',
x = NULL,
y = NULL) +
theme_minimal()
}
plot_two <- function(patient.data){
ggplot(patient.data, aes(x = DAYS, y = SLEEP)) +
geom_line(colour = 'black', size = 1) +
geom_point(size = 3,
aes(colour = cut(SLEEP,
c(-Inf,
summary(SLEEP)[[2]],
summary(SLEEP)[[5]],
Inf)
)
),
show.legend = F) +
scale_color_manual(values = c("red", "orange", "green")) +
labs(title = 'SLEEP (hrs)',
x = NULL,
y = NULL) +
theme_minimal()
}
output$plots <- renderPlot({
list.of.plots <- list(
`PHYSICAL ACTIVITY` = plot_one(patient()),
`SLEEP` = plot_two(patient())
)
do.call(ggplot2.multiplot, c(list.of.plots[input$checkGroup], cols=1))
})
}
shinyApp(ui, server)
It will work if replace ggplot2.multiplot(ptlist, cols=1) by do.call(ggplot2.multiplot, c(ptlist, cols=1))
But may be to do this with ggplot function in reactive is not a good way to achieve your goal.
You could to try something like this
library(shiny)
library(ggplot2)
library(easyGgplot2)
patient <- cbind.data.frame(
seq(1:14),
matrix(
sample(1:100, 84),
ncol = 6
)
)
colnames(patient) <- c(
'DAYS',
'PHYSICAL_ACTIVITY',
'SMOKING',
'ALCOHOL_INTAKE',
'HYDRATION',
'SLEEP',
'Total_score'
)
ui <- fluidPage(
titlePanel("Data Plot"),
sidebarLayout(
sidebarPanel(
fluidRow(
column(6,
checkboxGroupInput(
"checkGroup",
"Parameters",
list(
"PHYSICAL ACTIVITY",
"SLEEP"),
selected = "PHYSICAL ACTIVITY")
)
)
),
mainPanel(
plotOutput("plots")
)
)
)
server <- function(input, output) {
plot_one <- ggplot(data = patient, aes(x = DAYS, y = PHYSICAL_ACTIVITY)) +
geom_bar(
stat = "identity",
aes(fill = PHYSICAL_ACTIVITY <= median(PHYSICAL_ACTIVITY)),
show.legend = F) +
scale_fill_manual(
values = c('steelblue', 'red')) +
labs(title = 'PHYSICAL ACTIVITY (STEPS)',
x = NULL,
y = NULL) +
theme_minimal()
plot_two <- ggplot(data = patient, aes(x = DAYS, y = SLEEP)) +
geom_line(colour = 'black', size = 1) +
geom_point(size = 3,
aes(colour = cut(SLEEP,
c(-Inf,
summary(SLEEP)[[2]],
summary(SLEEP)[[5]],
Inf)
)
),
show.legend = F) +
scale_color_manual(values = c("red", "orange", "green")) +
labs(title = 'SLEEP (hrs)',
x = NULL,
y = NULL) +
theme_minimal()
list.of.plots <- list(
`PHYSICAL ACTIVITY` = plot_one,
`SLEEP` = plot_two
)
output$plots <- renderPlot(
do.call(ggplot2.multiplot, c(list.of.plots[input$checkGroup], cols=1))
)
}
shinyApp(ui, server)
library(shiny)
library(ggplot2)
library(easyGgplot2)
patient <- cbind.data.frame(
seq(1:14),
matrix(
sample(1:100, 84),
ncol = 6
)
)
colnames(patient) <- c(
'DAYS',
'PHYSICAL_ACTIVITY',
'SMOKING',
'ALCOHOL_INTAKE',
'HYDRATION',
'SLEEP',
'Total_score'
)
write.csv(patient, file="patient.csv")
ui <- fluidPage(
titlePanel("Data Plot"),
sidebarLayout(
sidebarPanel(
fluidRow(
column(6,
checkboxGroupInput(
"checkGroup",
"Parameters",
list(
"PHYSICAL ACTIVITY",
"SLEEP"),
selected = "PHYSICAL ACTIVITY")
)
),
fluidRow(
fileInput("file1", "Choose Data sheet",
multiple = TRUE,
accept = c("text/csv",
"text/comma-separated-values,text/plain",
".csv"))
)
),
mainPanel(
plotOutput("plots")
)
)
)
server <- function(input, output) {
patient <- reactive({
req(input$file1)
read.csv(input$file1$datapath,
header = T
)
})
plot_one <- ggplot(data = patient(), aes(x = DAYS, y = PHYSICAL_ACTIVITY)) +
geom_bar(
stat = "identity",
aes(fill = PHYSICAL_ACTIVITY <= median(PHYSICAL_ACTIVITY)),
show.legend = F) +
scale_fill_manual(
values = c('steelblue', 'red')) +
labs(title = 'PHYSICAL ACTIVITY (STEPS)',
x = NULL,
y = NULL) +
theme_minimal()
plot_two <- ggplot(data = patient(), aes(x = DAYS, y = SLEEP)) +
geom_line(colour = 'black', size = 1) +
geom_point(size = 3,
aes(colour = cut(SLEEP,
c(-Inf,
summary(SLEEP)[[2]],
summary(SLEEP)[[5]],
Inf)
)
),
show.legend = F) +
scale_color_manual(values = c("red", "orange", "green")) +
labs(title = 'SLEEP (hrs)',
x = NULL,
y = NULL) +
theme_minimal()
list.of.plots <- list(
`PHYSICAL ACTIVITY` = plot_one,
`SLEEP` = plot_two
)
output$plots <- renderPlot(
do.call(ggplot2.multiplot, c(list.of.plots[input$checkGroup], cols=1))
)
}
shinyApp(ui, server)

How to remove text (data labels) from a plot in a shiny app?

Hello I have created a shiny app which creates a scatter plot between selected variables. Then when I click on a data point the name of the point is printed in the plot. The problem is that when I update the plot with other variables the printed are not erased. Generally I would like some ideas on how remove the data labels from my plot.
library(shiny)
library(ggplot2)
library(plotly)
library(dplyr)
library(htmlwidgets)
js <- HTML(
"Shiny.addCustomMessageHandler('resetValue', function(variableName){
Shiny.onInputChange(variableName, null);
}
);"
)
fluidPage(
tags$head(tags$script(js)),
# App title ----
titlePanel(div("CROSS CORRELATION",style = "color:blue")),
# Sidebar layout with input and output definitions ----
sidebarLayout(
# Sidebar panel for inputs ----
sidebarPanel(width = 3
),
# Main panel for displaying outputs ----
mainPanel(
tabsetPanel(type = "tabs",
tabPanel("Table",
shiny::dataTableOutput("contents")),
tabPanel("Correlation Plot",
tags$style(type="text/css", "
#loadmessage {
position: fixed;
top: 0px;
left: 0px;
width: 100%;
padding: 5px 0px 5px 0px;
text-align: center;
font-weight: bold;
font-size: 100%;
color: #000000;
background-color: #CCFF66;
z-index: 105;
}
"),conditionalPanel(condition="$('html').hasClass('shiny-busy')",
tags$div("Loading...",id="loadmessage")
),
fluidRow(
column(3, uiOutput("lx1")),
column(3,uiOutput("lx2"))),
hr(),
fluidRow(
tags$style(type="text/css",
".shiny-output-error { visibility: hidden; }",
".shiny-output-error:before { visibility: hidden; }"
),
column(3,uiOutput("td")),
column(3,uiOutput("an"))
),
fluidRow(
plotlyOutput("sc"))
)
)
)))
#server.r
function(input, output,session) {
output$lx1<-renderUI({
selectInput("lx1", label = h4("Select 1st Expression Profile"),
choices = colnames(mtcars)
)
})
output$lx2<-renderUI({
selectInput("lx2", label = h4("Select 2nd Expression Profile"),
choices = colnames(mtcars)
)
})
output$td<-renderUI({
radioButtons("td", label = h4("Trendline"),
choices = list("Add Trendline" = "lm", "Remove Trendline" = ""),
selected = "")
})
output$an<-renderUI({
radioButtons("an", label = h4("Correlation Coefficient"),
choices = list("Add Cor.Coef" = cor(subset(mtcars, select=c(input$lx1)),subset(mtcars, select=c(input$lx2))), "Remove Cor.Coef" = ""),
selected = "")
})
# 1. create reactive values
vals <- reactiveValues()
# 2. create df to store clicks
vals$click_all <- data.frame(x = numeric(),
y = numeric(),
label = character())
# 3. add points upon plot click
observeEvent({event_data("plotly_click", source = "select")}, {
# get clicked point
click_data <- event_data("plotly_click", source = "select")
# check if from correct curve
if(!is.null(click_data) && click_data[["curveNumber"]] == 2) {
# get data for current point
label_data <- data.frame(x = click_data[["x"]],
y = click_data[["y"]],
label = click_data[["key"]],
stringsAsFactors = FALSE)
# add current point to df of all clicks
vals$click_all <- merge(vals$click_all,
label_data,
all = TRUE)
}
})
output$sc<-renderPlotly({
mtcars$model <- row.names(mtcars)
if(input$td=="lm"){
p1 <- ggplot(mtcars, aes_string(x = input$lx1, y = input$lx2,key = "model",group = 1))+
# Change the point options in geom_point
geom_point(color = "darkblue") +
# Change the title of the plot (can change axis titles
# in this option as well and add subtitle)
labs(title = "Cross Correlation") +
# Change where the tick marks are
scale_x_continuous(breaks = seq(0, 35, 5)) +
scale_y_continuous(breaks = seq(0, 35, 5)) +
# Change how the text looks for each element
theme(title = element_text(family = "Calibri",
size = 10,
face = "bold"),
axis.title = element_text(family = "Calibri Light",
size = 16,
face = "bold",
color = "darkgrey"),
axis.text = element_text(family = "Calibri",
size = 11))+
theme_bw()+
annotate("text", x = 5, y = 5, label = as.character(input$an))+
geom_smooth(aes(group = 1))+
# 4. add labels for clicked points
geom_text(data = vals$click_all,
aes(x = x, y = y, label = label),
inherit.aes = FALSE, nudge_y = -1,5)
}
else{
mtcars$model <- row.names(mtcars)
p1 <- ggplot(mtcars, aes_string(x = input$lx1, y = input$lx2,key = "model",group = 1))+
# Change the point options in geom_point
geom_point(color = "darkblue") +
# Change the title of the plot (can change axis titles
# in this option as well and add subtitle)
labs(title = "Cross Correlation") +
# Change where the tick marks are
scale_x_continuous(breaks = seq(0, 35, 5)) +
scale_y_continuous(breaks = seq(0, 35, 5)) +
# Change how the text looks for each element
theme(title = element_text(family = "Calibri",
size = 10,
face = "bold"),
axis.title = element_text(family = "Calibri Light",
size = 16,
face = "bold",
color = "darkgrey"),
axis.text = element_text(family = "Calibri",
size = 11))+
theme_bw()+
annotate("text", x = 5, y = 5, label = as.character(input$an))+
# 4. add labels for clicked points
geom_text(data = vals$click_all,
aes(x = x, y = y, label = label),
inherit.aes = FALSE, nudge_y = -1,5)
}
ggplotly(p1,source = "select", tooltip = c("key")) %>%
layout(hoverlabel = list(bgcolor = "white",
font = list(family = "Calibri",
size = 9,
color = "black")))
})
# 5a. reset plotly click event and vals$click_all upon changing plot inputs
observeEvent(c(
input$lx1,
input$lx2
), {
session$sendCustomMessage("resetValue", ".clientValue-plotly_click-select")
vals$click_all <- data.frame(x = numeric(),
y = numeric(),
label = character())
})
}
1. Reset the plotly event input
First, add this to the ui:
js <- HTML(
"Shiny.addCustomMessageHandler('resetValue', function(variableName){
Shiny.onInputChange(variableName, null);
}
);"
)
ui <- fluidPage(
tags$head(tags$script(js)),
...
)
Then, use the message handler in the server:
session$sendCustomMessage("resetValue", ".clientValue-plotly_click-select")
Note, the plotly event data follows this format: '.clientValue-event-source', where event is the type of event (e.g. plotly_click, plotly_hover, etc) and source is specified in the plot where the click event data are coming from.
This method was adapted from this answer. This article is also a useful reference.
2. Reset the reactive dataframe
vals$click_all <- data.frame(x = numeric(),
y = numeric(),
label = character())
3. Use observeEvent to trigger "resets" when plot variables change
observeEvent(c(
input$column_x,
input$column_y
), {
session$sendCustomMessage("resetValue", ".clientValue-plotly_click-select")
vals$click_all <- data.frame(x = numeric(),
y = numeric(),
label = character())
})
Note: you need to add the session argument to your server function, like this:
server <- function(input, output, session) {
...
}
Minimal example
library(shiny)
library(plotly)
library(htmlwidgets)
js <- HTML(
"Shiny.addCustomMessageHandler('resetValue', function(variableName){
Shiny.onInputChange(variableName, null);
}
);"
)
ui <- fluidPage(
# 5b. js to reset the plotly click event
tags$head(tags$script(js)),
fluidRow(column(width = 3,
selectInput("column_x", "X Variable", colnames(mtcars)),
selectInput("column_y", "Y Variable", colnames(mtcars))),
column(width = 9,
plotlyOutput("plot")
)
)
)
server <- function(input, output, session) {
# 1. create reactive values
vals <- reactiveValues()
# 2. create df to store clicks
vals$click_all <- data.frame(x = numeric(),
y = numeric(),
label = character())
# 3. add points upon plot click
observeEvent({event_data("plotly_click", source = "select")}, {
# get clicked point
click_data <- event_data("plotly_click", source = "select")
# check if from correct curve
if(!is.null(click_data) && click_data[["curveNumber"]] == 0) {
# get data for current point
label_data <- data.frame(x = click_data[["x"]],
y = click_data[["y"]],
label = click_data[["key"]],
stringsAsFactors = FALSE)
# add current point to df of all clicks
vals$click_all <- merge(vals$click_all,
label_data,
all = TRUE)
}
})
output$plot <- renderPlotly({
mtcars$model <- row.names(mtcars)
g <- ggplot(mtcars, aes_string(x = input$column_x,
y = input$column_y,
key = "model",
group = 1)) +
geom_point() +
geom_smooth(aes(group = 1)) +
# 4. add labels for clicked points
geom_text(data = vals$click_all,
aes(x = x, y = y, label = label),
inherit.aes = FALSE, nudge_x = 1.5)
ggplotly(g, source = "select", tooltip = c("key"))
})
# 5a. reset plotly click event and vals$click_all upon changing plot inputs
observeEvent(c(
input$column_x,
input$column_y
), {
session$sendCustomMessage("resetValue", ".clientValue-plotly_click-select")
vals$click_all <- data.frame(x = numeric(),
y = numeric(),
label = character())
})
}
shinyApp(ui, server)

Resources