Saving dotchart with shiny - r

Do you see any mistake here?
the ggsave works, but png(file=file) part not - it saves empty white image.
output$savePlotAmount <- downloadHandler(
filename = "amount.png",
content = function(file) {
if(input$plotType == "dot"){
png(file = file)
plotAmount()
dev.off()
}else{
ggsave(plotAmount(), filename = file)
}
})
I spent "hours" on trying to repair it but I don't know what's going on. Sorry that the example is not reproductible, but it is to hard to reproduct all app.
EDIT:
What is plotAmount():
plotAmount <- reactive({
if(input$plotType == "violin") {
plotAmount <- ggplot(values$x, aes_string(x = input$groupedBy, y = input$yVariableContinous)) +
geom_violin() +
ggtitle(paste0(input$yVariableContinous, " grouped by ", input$groupedBy)) +
scale_y_continuous(limits = c(0, quantile(values$x[,input$yVariableContinous] , 0.95, na.rm = T)))
}
if(input$plotType == "boxplot") {
plotAmount <- ggplot(values$x, aes_string(x = input$groupedBy, y = input$yVariableContinous)) +
geom_boxplot(outlier.shape = NA) +
ggtitle(paste0(input$yVariableContinous, " grouped by ", input$groupedBy)) +
scale_y_continuous(limits = c(0, quantile(values$x[,input$yVariableContinous] , 0.95, na.rm = T)))
}
if(input$plotType == "dot") {
var <- ifelse(input$groupedBy == 1, input$xVariable, input$groupedBy)
agregat <- aggregate(x = values$x[,input$yVariableContinous], by = list(g = values$x[,var], xx = values$x[,input$xVariable]), FUN = input$valueAs)
dotchart(agregat$x, labels = agregat$xx,
groups = as.factor(agregat$g),
color = brewer.pal(9,"Set1")[as.numeric(as.factor(agregat$g))],
xlab = "salary",
cex = .75,
main = paste0(input$yVariableContinous, " for ", input$xVariable,
"\ngrouped by ", input$groupedBy),
xlim = c(min(values$x[,input$yVariableContinous], na.rm = T), quantile(values$x[,input$yVariableContinous] , 0.95, na.rm = T)),
pch = 16
)
}

ggplot2 plots need to be print()'d to render.

Related

How to change area style with echarts4r::e_area()

I can change the line style and the item style, but I cannot seem to be able to pass arguments to areaStyle (see areaStyle).
For example:
library(echarts4r)
data.frame(x = seq.int(1, 5, 1),
y = 10) %>%
e_chart(x = x) %>%
e_area(
serie = y,
areaStyle = list(opacity = 0),
lineStyle = list(opacity = 0),
itemStyle = list(opacity = 0)
)
produces an area chart with no points and no line, but the area is still visible. How do I change the color, opacity, etc. of the area itself?
I had a look at the source code of e_area_ (which is called by e_area). and the issue is that e_area_ inits areaStyle as an empty list. See https://github.com/JohnCoene/echarts4r/blob/bf23891749cf42a40656fa87ff04ecb3627a9af5/R/add_.R#L263-L269 . And unfortunately this empty list doesn't gets updated when the user provides his own specs. Not sure whether this is a bug or whether this is intended. Perhaps you should file an issue.
As a possible quick workaround here is "fixed" e_area2_ which updates the default empty list via modifyList:
library(echarts4r)
library(dplyr)
e_area2_ <- function(e, serie, bind = NULL, name = NULL, legend = TRUE,
y_index = 0, x_index = 0, coord_system = "cartesian2d", ...) {
.default <- list(areaStyle = list())
args <- utils::modifyList(.default, list(...))
if (missing(e)) {
stop("must pass e", call. = FALSE)
}
if (missing(serie)) {
stop("must pass serie", call. = FALSE)
}
for (i in seq_along(e$x$data)) {
vector <- echarts4r:::.build_data2(
e$x$data[[i]], e$x$mapping$x,
serie
)
if (!is.null(bind)) {
vector <- echarts4r:::.add_bind2(e, vector, bind, i = i)
}
l <- list(data = vector)
if (coord_system == "cartesian2d") {
if (y_index != 0) {
e <- echarts4r:::.set_y_axis(e, serie, y_index, i)
}
if (x_index != 0) {
e <- echarts4r:::.set_x_axis(e, x_index, i)
}
l$yAxisIndex <- y_index
l$xAxisIndex <- x_index
} else if (coord_system == "polar") {
l$data <- as.list(unname(unlist(dplyr::select(
e$x$data[[i]],
serie
))))
}
if (!e$x$tl) {
nm <- echarts4r:::.name_it(e, serie, name, i)
args
opts <- c(
list(name = nm, type = "line", coordinateSystem = coord_system),
args
)
l <- append(l, opts)
if (isTRUE(legend)) {
e$x$opts$legend$data <- append(
e$x$opts$legend$data,
list(nm)
)
}
e$x$opts$series <- append(e$x$opts$series, list(l))
} else {
e$x$opts$options[[i]]$series <- append(
e$x$opts$options[[i]]$series,
list(l)
)
}
}
if (isTRUE(e$x$tl)) {
if (is.null(name)) {
name <- serie
}
series_opts <- c(
list(
name = name, type = "line", yAxisIndex = y_index,
xAxisIndex = x_index, coordinateSystem = coord_system
),
args
)
if (isTRUE(legend)) {
e$x$opts$baseOption$legend$data <- append(
e$x$opts$baseOption$legend$data,
list(name)
)
}
e$x$opts$baseOption$series <- append(
e$x$opts$baseOption$series,
list(series_opts)
)
}
e
}
data.frame(
x = seq.int(1, 5, 1),
y = 10
) %>%
e_chart(x = x) %>%
e_area2_(
serie = "y",
areaStyle = list(opacity = 0),
lineStyle = list(opacity = 0),
itemStyle = list(opacity = 0)
)
e_area() is going to be deprecated (see this GitHub Issue). Using e_line() and areaStyle (which follows from echarts.js) solves my issue.
library(echarts4r)
library(magrittr)
data.frame(x = seq.int(1, 5, 1),
y = 10) %>%
e_chart(x = x) %>%
e_line(
serie = y,
areaStyle = list(opacity = 0),
lineStyle = list(opacity = 0),
itemStyle = list(opacity = 0)
)
With area areaStyle opactiy = 1:
library(echarts4r)
library(magrittr)
data.frame(x = seq.int(1, 5, 1),
y = 10) %>%
e_chart(x = x) %>%
e_line(
serie = y,
areaStyle = list(opacity = 1),
lineStyle = list(opacity = 0),
itemStyle = list(opacity = 0)
)

How to replace a rendered plot with its own plot_click info in R Shiny?

My app is supposed to load certain data as input file (in this post i will give a part of it written in form of data frame so you can use to run my example). and then plot three plots . i want that when the user click oh the plot at the top of page , a first new plot will be displayed based on the click info and when the new plot will be displayed then i want to plot a second new plot based on the click info of the first new plot.
library(dplyr)
library(shiny)
library(shinydashboard)
library(shinyWidgets)
library(ggplot2)
library(gridExtra)
library(scales)
library(grid)
library(RColorBrewer)
library(officer)
library(svglite)
library(rvg)
library(readxl)
library(tools)
library(rsvg)
body <- dashboardBody(
fluidRow(
tabBox(
# The id lets us use input$tabset1 on the server to find the current tab
id = "tabset1",height = 750,width=20,
tabPanel("Summary",dataTableOutput(outputId = "table")),
tabPanel("Visualization",sliderInput("scalegvt","Scale Data by:", min = 0, max = 100, value = c(70,100)),plotOutput("p1", height = 1000,click = "plot_click")
)
)
)
)
side<- dashboardSidebar(
width = 290,
sidebarMenu(
menuItem("Summary",tabName = "Summary") ,
uiOutput('choose_Da'),
selectizeGroupUI(
id = "m",
inline = FALSE,
params = list(
Lot = list(inputId = "Lot", title = "Lot"),
wafer = list(inputId = "wafer", title = "wafer"),
M_datum = list(inputId = "M_Datum", title = "M_Datum"),
Yield = list(inputId = "Yield", title = "Yield")
)
),inline=FALSE,
menuItem("Visualization",tabName = "Visualization")
))
ui <- function(request) {
dashboardPage(
dashboardHeader(title = "Yield Report",titleWidth = 290),
side,
body
)
}
server = function(input, output,session) {
newscale <- reactive({
req(input$scalegvt)
})
mydt<-data.frame(Lot=c(rep("A",4),rep("b",5),rep("n",3),rep("x",2)),M_Datum=as.Date(c("2012-06-05","2012-06-15","2012-06-10","2014-11-17","2014-03-18","2014-06-15","2014-06-10","2014-06-17","2015-11-27","2016-08-15","2016-09-10","2016-10-27","2017-09-10","2017-10-12")),wafer=(c(rep(5,14)+1:14)),Yield=c(rep(10,14)+57))
dz<-reactive({
req(res_mod())
dat<-res_mod()
dt<-dat[dat$M_Datum >=input$dateRange[1] & dat$M_Datum <= input$dateRange[2],]
dt[,2]<-as.Date(format(as.Date(dt[,2]), "%Y-%m-01"))
req(dt$M_Datum,dt$Yield)
dr<-data.frame("M_Datum"=dt$M_Datum,"Yield"=dt$Yield)
req(dr$M_Datum,dr$Yield)
dx<-aggregate(Yield~M_Datum,dr,mean)
req(dx$M_Datum,dx$Yield)
dx$M_Datum<-format(dx$M_Datum, "%b %Y")
return(data.frame("M_Datum"=dx$M_Datum,"Yield"=dx$Yield))
})
#observeEvent(input$plot_click,
#{ a<- reactive(nearPoints(dz(), input$plot_click, threshold = 10, maxpoints = 1,
# addDist = F))
# b<-reactive(match(substr(a()$M_Datum,1,3),month.abb))
# req(res_mod())
#dat<-res_mod()
#dt<-dat[dat$M_Datum >=input$dateRange[1] & dat$M_Datum <= input$dateRange[2],]
#dt<-dt[substr(dt$M_Datum,6,7)==as.character(b()),]
#req(dt$Lot,dt$Yield)
#dr<-data.frame("Lot"=dt$Lot,"Yield"=dt$Yield)
# req(dr$Lot,dr$Yield)
# dx<-aggregate(Yield~Lot,dr,mean)
# req(dx$Lot,dx$Yield)
# dza<-data.frame("Lot"=dx$Lot,"Yield"=dx$Yield)
# output$p2 <- renderPlot({ ggplot(dza, aes(x = Lot,y = Yield,group = 1)) +
# geom_point()})
#})
output$choose_Da <- renderUI({
dateRangeInput('dateRange',
label = 'Filter by date',
start = min(mydt$M_Datum) , end = max(mydt$M_Datum),min=min(mydt$M_Datum),max=max(mydt$M_Datum)
)
})
res_mod <- callModule(
module = selectizeGroupServer,
id = "m",
data = mydt,
vars = c("Lot","M_Datum","Yield","wafer"),
inline=FALSE
)
output$table <- renderDataTable({
dato<-res_mod()
return(dato[dato$M_Datum >= input$dateRange[1] & dato$M_Datum <= input$dateRange[2],]) },
options = list(scrollX = TRUE))
filtredplot<-reactive({
req(res_mod())
dat<-res_mod()
dt<-dat[dat$M_Datum >=input$dateRange[1] & dat$M_Datum <= input$dateRange[2],]
dt[,2]<-as.Date(format(as.Date(dt[,2]), "%Y-%m-01"))
req(dt$M_Datum,dt$Yield)
dr<-data.frame("M_Datum"=dt$M_Datum,"Yield"=dt$Yield)
req(dr$M_Datum,dr$Yield)
dx<-aggregate(Yield~M_Datum,dr,mean)
req(dx$M_Datum,dx$Yield)
dz<-data.frame("M_Datum"=dx$M_Datum,"Yield"=dx$Yield)
dz$M_Datum<-factor(format(dz$M_Datum, "%b %Y"), levels=format(sort(unique(dz$M_Datum)),"%b %Y"))
hline_data <- data.frame(y = c(mean(dz$Yield)-sd(dz$Yield),mean(dz$Yield), mean(dz$Yield)+sd(dz$Yield)), type = factor(c(2, 1, 2)),
stringsAsFactors = FALSE)
ggplot(dz, aes(x=M_Datum, y=Yield,group = 1)) +
geom_point(size=7,colour="#007A9D",shape=4) +
theme(axis.text.x = element_text(angle = 0, vjust = 0.5, hjust=1))+
theme(legend.direction = "horizontal", legend.position = "top", legend.key = element_blank(),
legend.background = element_rect(fill = "white", colour = "white"),
axis.text.y.left = element_text(color = "#007A9D"),
axis.title.y.left = element_text(color = "#007A9D"),
plot.title = element_text(color="#007A9D")
)+
ylab("Mean Yield")+
xlab("")+
ggtitle(paste0("FCM-Yield Trend :"," ",paste0(c(input[["m-Customer_Name"]],input[["m-Local_Process_Id"]],input[["m-Process_Family"]],input[["m-MEMS_flag"]],input[["m-Device"]]),collapse = ",")))+
ylim(newscale())+
geom_hline(data = hline_data,
aes(yintercept = y, linetype = type, colour = type)) +
scale_colour_manual(values = c("#007A9D", "#EF783D"),
labels = c("Mean", "Mean+-sd"),
name = "Key:") +
scale_linetype_manual(values = 1:2,
labels = c("Mean", "Mean+-sd"),
name = "Key:")
})
output$p1<-renderPlot({
filtredplot() })
}
shinyApp(ui,server)
in that part of code turned to comment i have tried using the clik info to transform that month name to number to use it in order to filter data that means i want to plot the lot (x axis ) vs Yield ( as y axis in form of mean(avarage) ) so i can get average of yield pro lot in that month and then when i click again i want to get a second plot showing yield ( y axis not aggregated as mean this time) vs wafer (x axis) and of course only for that lot chosen by clickíng the first new plot.
The code posted is not a minimal reproducible example MRE. I did not go through it. But here is an MRE to achieve the task you have described: to output a second plot (p2) based on the plot_click of a first plot (p1) using nearPoints() shiny function.
library(shiny)
library(ggplot2)
data <- mpg
ui <- basicPage(
plotOutput("p1", click = "plot_click"),
plotOutput("p2")
)
server <- function(input, output) {
output$p1 <- renderPlot({
ggplot(data, aes(x = displ, y = cty)) +
geom_point()
})
observeEvent(input$plot_click,{
a <- nearPoints(data,
input$plot_click,
threshold = 10,
maxpoints = 1,
addDist = F)$model
if (length(a) > 0) {
df <- data[data$model == a, ]
output$p2 <- renderPlot({
ggplot(df, aes(x = model, y = displ, group = 1)) +
geom_point()
})
}
})
}
shinyApp(ui, server)
EDITED here is the above solution using your code. A click on p1 outputs a second plot p2, and a click on p2 outputs a third plot p3. I made the plots smaller because I'm working on a laptop. Note that because your sample data is small, not all datapoints result in a valid click. But there are enough "good" points to test out the solution.
library(dplyr)
library(shiny)
library(shinydashboard)
library(shinyWidgets)
library(ggplot2)
body <- dashboardBody(
fluidRow(
tabBox(
# The id lets us use input$tabset1 on the server to find the current tab
id = "tabset1",height = 750,width=20,
tabPanel("Summary",dataTableOutput(outputId = "table")),
tabPanel("Visualization",
sliderInput("scalegvt","Scale Data by:", min = 0, max = 100, value = c(70,100)),
plotOutput("p1", height = 300, width = 300, click = "plot_click_p1"),
plotOutput("p2", height = 300, width = 300, click = "plot_click_p2"),
plotOutput("p3", height = 300, width = 300,)
)
)
)
)
side <- dashboardSidebar(
width = 290,
sidebarMenu(
menuItem("Summary",tabName = "Summary") ,
uiOutput('choose_Da'),
selectizeGroupUI(
id = "m",
inline = FALSE,
params = list(
Lot = list(inputId = "Lot", title = "Lot"),
wafer = list(inputId = "wafer", title = "wafer"),
M_datum = list(inputId = "M_Datum", title = "M_Datum"),
Yield = list(inputId = "Yield", title = "Yield")
)
),inline=FALSE,
menuItem("Visualization",tabName = "Visualization")
))
ui <- function(request) {
dashboardPage(
dashboardHeader(title = "Yield Report",titleWidth = 290),
side,
body
)
}
server = function(input, output,session) {
newscale <- reactive({
req(input$scalegvt)
})
mydt<-data.frame(Lot=c(rep("A",4),rep("b",5),rep("n",3),rep("x",2)),M_Datum=as.Date(c("2012-06-05","2012-06-15","2012-06-10","2014-11-17","2014-03-18","2014-06-15","2014-06-10","2014-06-17","2015-11-27","2016-08-15","2016-09-10","2016-10-27","2017-09-10","2017-10-12")),wafer=(c(rep(5,14)+1:14)),Yield=c(rep(10,14)+57))
dz<-reactive({
req(res_mod())
dat<-res_mod()
dt<-dat[dat$M_Datum >=input$dateRange[1] & dat$M_Datum <= input$dateRange[2],]
dt[,2]<-as.Date(format(as.Date(dt[,2]), "%Y-%m-01"))
req(dt$M_Datum,dt$Yield)
dr<-data.frame("M_Datum"=dt$M_Datum,"Yield"=dt$Yield)
req(dr$M_Datum,dr$Yield)
dx<-aggregate(Yield~M_Datum,dr,mean)
req(dx$M_Datum,dx$Yield)
dx$M_Datum<-format(dx$M_Datum, "%b %Y")
return(data.frame("M_Datum"=dx$M_Datum,"Yield"=dx$Yield))
})
observeEvent(input$plot_click_p1, {
a <- nearPoints(dz(),
input$plot_click_p1,
threshold = 10,
maxpoints = 1,
addDist = F)
b <- match(substr(a$M_Datum,1,3),month.abb)
req(res_mod())
dat <- res_mod()
dt <- dat[dat$M_Datum >=input$dateRange[1] & dat$M_Datum <= input$dateRange[2],]
dt <- dt[substr(dt$M_Datum,6,7)==as.character(b),]
req(dt$Lot, dt$Yield)
dr <- data.frame("Lot"=dt$Lot,"Yield"=dt$Yield)
req(dr$Lot, dr$Yield)
dx <- aggregate(Yield~Lot,dr,mean)
req(dx$Lot,dx$Yield)
dza <- data.frame("Lot"=dx$Lot,"Yield"=dx$Yield)
output$p2 <- renderPlot({
ggplot(dza, aes(x = Lot,y = Yield,group = 1)) +
geom_point()
})
})
observeEvent(input$plot_click_p2, {
output$p3 <- renderPlot({
test <- nearPoints(mydt,
input$plot_click_p2,
threshold = 10,
maxpoints = 1,
addDist = F)
str(test)
ggplot(test, aes(x = Lot, y = Yield)) +
geom_point()
})
})
output$choose_Da <- renderUI({
dateRangeInput('dateRange',
label = 'Filter by date',
start = min(mydt$M_Datum) , end = max(mydt$M_Datum),min=min(mydt$M_Datum),max=max(mydt$M_Datum)
)
})
res_mod <- callModule(
module = selectizeGroupServer,
id = "m",
data = mydt,
vars = c("Lot","M_Datum","Yield","wafer"),
inline=FALSE
)
output$table <- renderDataTable({
dato <- res_mod()
return(dato[dato$M_Datum >= input$dateRange[1] & dato$M_Datum <= input$dateRange[2],])
},options = list(scrollX = TRUE))
filtredplot <- reactive({
req(res_mod())
dat <- res_mod()
dt <- dat[dat$M_Datum >=input$dateRange[1] & dat$M_Datum <= input$dateRange[2],]
dt[,2] <- as.Date(format(as.Date(dt[,2]), "%Y-%m-01"))
req(dt$M_Datum,dt$Yield)
dr<-data.frame("M_Datum"=dt$M_Datum,"Yield"=dt$Yield)
req(dr$M_Datum,dr$Yield)
dx<-aggregate(Yield~M_Datum,dr,mean)
req(dx$M_Datum,dx$Yield)
dz<-data.frame("M_Datum"=dx$M_Datum,"Yield"=dx$Yield)
dz$M_Datum<-factor(format(dz$M_Datum, "%b %Y"), levels=format(sort(unique(dz$M_Datum)),"%b %Y"))
hline_data <- data.frame(y = c(mean(dz$Yield)-sd(dz$Yield),mean(dz$Yield), mean(dz$Yield)+sd(dz$Yield)), type = factor(c(2, 1, 2)),
stringsAsFactors = FALSE)
ggplot(dz, aes(x=M_Datum, y=Yield,group = 1)) +
geom_point(size=7,colour="#007A9D",shape=4) +
theme(axis.text.x = element_text(angle = 0, vjust = 0.5, hjust=1))+
theme(legend.direction = "horizontal", legend.position = "top", legend.key = element_blank(),
legend.background = element_rect(fill = "white", colour = "white"),
axis.text.y.left = element_text(color = "#007A9D"),
axis.title.y.left = element_text(color = "#007A9D"),
plot.title = element_text(color="#007A9D")
) +
ylab("Mean Yield")+
xlab("")+
ggtitle(paste0("FCM-Yield Trend :"," ",paste0(c(input[["m-Customer_Name"]],input[["m-Local_Process_Id"]],input[["m-Process_Family"]],input[["m-MEMS_flag"]],input[["m-Device"]]),collapse = ",")))+
ylim(newscale())+
geom_hline(data = hline_data,
aes(yintercept = y, linetype = type, colour = type)) +
scale_colour_manual(values = c("#007A9D", "#EF783D"),
labels = c("Mean", "Mean+-sd"),
name = "Key:") +
scale_linetype_manual(values = 1:2,
labels = c("Mean", "Mean+-sd"),
name = "Key:")
})
output$p1 <- renderPlot({
filtredplot()
})
}
shinyApp(ui,server)

Add a download button to Shiny RMarkdown report?

How do you add a "download PNG" button to a Shiny RMarkdown report? I gather that I'll need to use downloadHandler() but I can't find any info on passing the plot results to that function in an Rmarkdown document specifically (since there is no saved output e.g., output$plot <- renderPlot() like in regular Shiny). Below is an example which allows users to map a variable with different color palettes. Any advice would be much appreciated!
Example Report
knitr::opts_chunk$set(echo = TRUE)
# load libraries
library(tidyverse)
library(sf)
library(RColorBrewer)
library(nycgeo)
# save data
df <- nyc_boundaries(geography = "tract")
df <- mutate(df, response_rate = sample(30:85, size = nrow(df), replace = TRUE))
# define palettes
viridis_pals <- c("Viridis" = "D",
"Magma" = "A",
"Inferno" = "B",
"Plasma" = "C")
brewer_pals <- c("Yellow-Orange-Red" = "YlOrRd",
"Yellow-Orange-Brown" = "YlOrBr",
"Yellow-Green-Blue" = "YlGnBu",
"Yellow-Green" = "YlGn",
"Reds",
"Red-Purple" = "RdPu",
"Purples",
"Purple-Red" = "PuRd",
"Purple-Blue-Green" = "PuBuGn",
"Purple-Blue" = "PuBu",
"Orange-Red" = "OrRd",
"Oranges",
"Greys",
"Greens",
"Green-Blue" = "GnBu",
"Blue-Purple" = "BuPu",
"Blue-Green" = "BuGn",
"Blues")
Interactive Map
selectInput("pal_type", label = "Palette Type", choices = c("Brewer","Viridis"))
renderUI({
req(input$pal_type)
if (input$pal_type == "Viridis") {
selectInput("pal", label = "Color Palette", choices = viridis_pals)
} else if (input$pal_type == "Brewer") {
selectInput("pal", label = "Color Palette", choices = brewer_pals)
}
})
renderPlot({
req(input$pal)
map <- ggplot() +
geom_sf(data = df, aes(fill = response_rate), color = "darkgrey") +
theme_void() +
labs(x = NULL, y = NULL,
title = "A Fake Map")
final_map <- if (input$pal %in% viridis_pals) {
map + viridis::scale_fill_viridis("Fake Variable",
labels = scales::label_percent(scale = 1),
option = input$pal,
alpha = 0.8)
} else if (input$pal %in% brewer_pals) {
map + scale_fill_gradientn("Fake Variable",
colors = brewer.pal(9, input$pal),
labels = scales::label_percent(scale = 1))
}
final_map
})
# reactively generate file name
file_name <- reactive({
paste0("final_map_", input$pal, ".png")
})
# add download of plot
downloadHandler(
filename = file_name(),
content = function(file) {ggsave(file, plot())}
)
I figured out the solution!
Change the plotting pipeline into a reactive: plot <- reactive({gglot() + ...})
Call that reactive in a render plot to display the map: renderPlot({plot()})
Pass that to the downloadHandler to download the plot: (downloadHandler(filename = function() {paste0("final_map_", input$pal, ".png")},content = function(file) {ggsave(file, plot())} ))
Working code below :)
knitr::opts_chunk$set(echo = TRUE)
# load libraries
library(tidyverse)
library(sf)
library(RColorBrewer)
library(nycgeo)
# save data
df <- nyc_boundaries(geography = "tract")
df <- mutate(df, response_rate = sample(30:85, size = nrow(df), replace = TRUE))
# define palettes
viridis_pals <- c("Viridis" = "D",
"Magma" = "A",
"Inferno" = "B",
"Plasma" = "C")
brewer_pals <- c("Yellow-Orange-Red" = "YlOrRd",
"Yellow-Orange-Brown" = "YlOrBr",
"Yellow-Green-Blue" = "YlGnBu",
"Yellow-Green" = "YlGn",
"Reds",
"Red-Purple" = "RdPu",
"Purples",
"Purple-Red" = "PuRd",
"Purple-Blue-Green" = "PuBuGn",
"Purple-Blue" = "PuBu",
"Orange-Red" = "OrRd",
"Oranges",
"Greys",
"Greens",
"Green-Blue" = "GnBu",
"Blue-Purple" = "BuPu",
"Blue-Green" = "BuGn",
"Blues")
Interactive Map
selectInput("pal_type", label = "Palette Type", choices = c("Brewer","Viridis"))
renderUI({
req(input$pal_type)
if (input$pal_type == "Viridis") {
selectInput("pal", label = "Color Palette", choices = viridis_pals)
} else if (input$pal_type == "Brewer") {
selectInput("pal", label = "Color Palette", choices = brewer_pals)
}
})
plot <- reactive({
req(input$pal)
map <- ggplot() +
geom_sf(data = df, aes(fill = response_rate), color = "darkgrey") +
theme_void() +
labs(x = NULL, y = NULL,
title = "A Fake Map")
final_map <- if (input$pal %in% viridis_pals) {
map + viridis::scale_fill_viridis("Fake Variable",
labels = scales::label_percent(scale = 1),
option = input$pal,
alpha = 0.8)
} else if (input$pal %in% brewer_pals) {
map + scale_fill_gradientn("Fake Variable",
colors = brewer.pal(9, input$pal),
labels = scales::label_percent(scale = 1))
}
final_map
})
renderPlot({plot()})
# add download of plot
downloadHandler(
filename = function() {paste0("final_map_", input$pal, ".png")},
content = function(file) {ggsave(file, plot())}
)

How to segment descriptive bar plots using DataExplorer

I have a dataset and would like to do some exploratory data analysis before building a predictive model. All variables are categorical. I know that I can use 'dataExplorer' to do some quick EDA:
library(tidyverse)
library(dataExplorer)
dat <- data.frame(circuit = sample(c("China", "Murica", "Brazil"), 100, replace = T),
driver = sample(c("Kimi", "Seb", "Max", "Lando", "Lance"), 100, replace = T),
opinion = sample(c("Garbage", "Not.Garbage"), 100, replace = T, prob = c(0.8, 0.2)))
dat %>%
select(-opinion) %>%
plot_bar
However, I want the bars for 'circuit' and 'driver' to be filled in to represent the respective proportions of 'opinion' for each variable (see below). This is so that I can see which predictor variables are most closely associated with my outcome variable.
dat %>%
ggplot(aes(x = circuit, fill = opinion)) +
geom_histogram(stat = "count")
However, I don't want to build each plot individually and then use grid.arrange to organize them.
Thanks for any help :)
I don't think there is an easy way unless you tweak the plot_bar function, since it is currently designed to visualize univariate distribution. Run the following function and it should work with your example:
library(tidyverse)
library(data.table) ## Note: You will need to load data.table
library(DataExplorer)
## Rewrite plot_bar
plot_bar2 <- function(data, group, with = NULL, maxcat = 50, order_bar = TRUE, binary_as_factor = TRUE, title = NULL, ggtheme = theme_gray(), theme_config = list(), nrow = 3L, ncol = 3L, parallel = FALSE) {
frequency <- measure <- variable <- value <- NULL
if (!is.data.table(data)) data <- data.table(data)
split_data <- split_columns(data, binary_as_factor = binary_as_factor)
if (split_data$num_discrete == 0) stop("No discrete features found!")
discrete <- split_data$discrete
ind <- DataExplorer:::.ignoreCat(discrete, maxcat = maxcat)
if (length(ind)) {
message(length(ind), " columns ignored with more than ", maxcat, " categories.\n", paste0(names(ind), ": ", ind, " categories\n"))
drop_columns(discrete, names(ind))
if (length(discrete) == 0) stop("Note: All discrete features ignored! Nothing to plot!")
}
feature_names <- names(discrete)
if (is.null(with)) {
dt <- discrete[, list(frequency = .N), by = feature_names]
} else {
if (is.factor(data[[with]])) {
measure_var <- suppressWarnings(as.numeric(levels(data[[with]]))[data[[with]]])
} else if (is.character(data[[with]])) {
measure_var <- as.numeric(data[[with]])
} else {
measure_var <- data[[with]]
}
if (all(is.na(measure_var))) stop("Failed to convert `", with, "` to continuous!")
if (with %in% names(discrete)) drop_columns(discrete, with)
tmp_dt <- data.table(discrete, "measure" = measure_var)
dt <- tmp_dt[, list(frequency = sum(measure, na.rm = TRUE)), by = feature_names]
}
dt2 <- suppressWarnings(melt.data.table(dt, id.vars = c(group, "frequency"), measure.vars = setdiff(feature_names, group))) # This line is updated
layout <- DataExplorer:::.getPageLayout(nrow, ncol, ncol(discrete))
plot_list <- DataExplorer:::.lapply(
parallel = parallel,
X = layout,
FUN = function(x) {
if (order_bar) {
base_plot <- ggplot(dt2[variable %in% feature_names[x]], aes(x = reorder(value, frequency), y = frequency))
} else {
base_plot <- ggplot(dt2[variable %in% feature_names[x]], aes(x = value, y = frequency))
}
base_plot +
geom_bar(stat = "identity", aes_string(fill = group)) + # This line is updated
coord_flip() +
xlab("") + ylab(ifelse(is.null(with), "Frequency", toTitleCase(with)))
}
)
class(plot_list) <- c("multiple", class(plot_list))
plotDataExplorer(
plot_obj = plot_list,
page_layout = layout,
title = title,
ggtheme = ggtheme,
theme_config = theme_config,
facet_wrap_args = list(
"facet" = ~ variable,
"nrow" = nrow,
"ncol" = ncol,
"scales" = "free"
)
)
}
## Create data and plot
dat <- data.frame(
circuit = sample(c("China", "Murica", "Brazil"), 100, replace = T),
driver = sample(c("Kimi", "Seb", "Max", "Lando", "Lance"), 100, replace = T),
opinion = sample(c("Garbage", "Not.Garbage"), 100, replace = T, prob = c(0.8, 0.2))
)
plot_bar2(dat, group = "opinion")
The plot looks like this:

Edit labels of plotly tooltip with ggplot stat_function

I'm trying to plot a function with ggplotly. But the tooltip-labels cannot be edited correctly. This is the code I tried:
library(shiny)
library(ggplot2)
library(plotly)
feeInMonth <- function(dayFare, days){
fee = dayFare * days
if(fee > 662.5){ #662.5 = 100 + 50/0.8 + 250/0.5
fee = (fee -262.5)} else if(fee > 162.5 & fee <= 662.5){ #162.5 = 100 + 50/0.8
fee = fee/2+68.75 } else if(fee > 100 & fee <= 162.5){#(fee-162.5)/2+150
fee = fee*0.8+20 } else { return(fee)} #(fee-100)*0.8+100
return(fee)
}
g <- Vectorize(feeInMonth)
ui <- fluidPage(
titlePanel(HTML("北京地铁月度支出计算器 <br/>Beijing Subway monthly Fare Calculator")),
fluidRow(
column(4,radioButtons("radio", label = h4(HTML("X轴选择 <br/> Select X Variable")),
choiceNames = c("以天数看花费 \n days as X variable",
"以单日费用看花费 \n day fare as X variable"),
choiceValues = c("dayFare","days"),
selected = "days")),
column(5,uiOutput("Input"))),
# Show a plot of the generated distribution
plotlyOutput("distPlot", width=780,height = 400)
)
server <- function(input, output) {
output$Input <- renderUI({
if(input$radio == "days"){
numericInput("Input", label = h4(HTML('每月使用日数<br/> monthly work days')),
value = 22, min = 1, max = 31)
}else{
numericInput("Input", label = h4(HTML('平均每日花费<br/> average each day fare')),
value = 10, min = 3, max = 50)
}})
output$distPlot <- renderPlotly(
{
if(input$radio == "dayFare"){
p <- ggplot(data.frame(dayFare = c(3,50),days = c(0,31)),
aes(x = days,text = paste('Fare: ', g(dayFare,days),'</br>days: ', days))) +
stat_function(fun = g,args = c(dayFare = input$Input)) +
theme(axis.line = element_line(colour = "darkblue", size = 1.5, linetype = "solid"))+
labs(x = HTML("使用日数\n using days"), y = HTML("费用\ fare"))
}
if(input$radio == "days"){
p <- ggplot(data.frame(dayFare = c(3,50),days = c(0,31)),
aes(x = dayFare,text = paste('Fare: ', g(dayFare,days),'</br>day Fare: ', dayFare))) +
stat_function(fun = g,args = c(days = input$Input),size =2) +
theme(axis.line = element_line(colour = "darkblue",size = 1.5, linetype = "solid"))+
labs(x = HTML("平均每日花费\n average each day fare"), y = HTML("费用\ fare"))
}
gg <- plotly_build(p)
gg <- style(gg, line = list(color = 'lightblue'))
})
}
shinyApp(ui = ui, server = server)
The resulting plot looks like this:
The y or fare number is not correct and it seems like it's the sum of all the y value. And the x/days/dayfare value is fixed, it is not changing.
I also tried this:
gg$x$data[[2]]$text <- paste('Fare: ', g(x),'</br>number: ', x)
but I get this error:
object 'x' not found
Is there any other way I can try?
About this small project, there is another solved question:
about the radioButtom setting
I looked at the similar questions like these:
the working well solution in its situation
Apparently ggplotly doesnt know how to render the tooltips when text is explicitly given. If you remove it, then the hover-values change:
If it would work, you would have to include tooltip = "text" in the ggplotly call.
Thats the adapted server function:
server <- function(input, output) {
output$Input1 <- renderUI({
if(input$radio == "days"){
numericInput("Input", label = h4(HTML('每月使用日数<br/> monthly work days')),
value = 22, min = 1, max = 31)
}else{
numericInput("Input", label = h4(HTML('平均每日花费<br/> average each day fare')),
value = 10, min = 3, max = 50)
}})
output$distPlot <- renderPlotly({
req(input$Input)
df <- data.frame(dayFare = seq(3,50,length.out = 32), days = 0:31)
df$gF <- g(df$dayFare, df$days)
if(input$radio == "dayFare"){
p <- ggplot(data = df,
aes(x = days, y = gF#, text = paste('Fare: ', df$gF,'<br>days: ', df$days)
)) +
stat_function(fun = g, args = c(input$Input)) +
theme(axis.line = element_line(colour = "darkblue", size = 1.5, linetype = "solid")) +
labs(x = HTML("使用日数\n using days"), y = HTML("费用\ fare"))
}
if(input$radio == "days"){
p <- ggplot(data = df,
aes(x = dayFare, y=gF#, text = paste('Fare: ', df$gF, '<br>day Fare: ', df$dayFare)
)) +
stat_function(fun = g, args = c(input$Input), size =2) +
theme(axis.line = element_line(colour = "darkblue",size = 1.5, linetype = "solid")) +
labs(x = HTML("平均每日花费\n average each day fare"), y = HTML("费用\ fare"))
}
ggplotly(p, source = "A", dynamicTicks = F) %>% #tooltip = "text"
style(line = list(color = 'lightblue'))
})
}

Resources