So I am trying to draw a few ggplots and their legend using gridExtra. The legend appears in the last cell on a white background - I would like to change the background color there, so that white background disappears. How can I do that?
Here's my code:
library(reshape)
library(ggplot2)
library(plyr)
library(wq)
library(gridExtra)
library(lattice)
library(grid)
testVisualization <- function()
{
set.seed(123)
xx <- sample(seq(from = 20, to = 50, by = 5), size = 50, replace = TRUE)
yy <- sample(seq(from = 1, to = 50), size = 50, replace = TRUE)
zz <- sample(seq(from = 1, to = 10, by = 1), size = 50, replace = TRUE)
dd <- data.frame(xx,yy,zz)
colRainbow <- rainbow(n, s = 1, v = 1, start = 0, end = max(1, n - 1)/n, alpha = 1)
gg <- ggplot() + geom_point(data=dd, aes(x=xx, y=yy, colour=zz))+
theme_custom()
lay2 <- rbind(c(1,1,1,1,1),
c(2,2,3,3,4))
legg1 <- g_legend(gg)
grid.arrange(
gg+guides(fill=FALSE, colour=FALSE, size=FALSE),
gg+guides(fill=FALSE, colour=FALSE, size=FALSE),
gg+guides(fill=FALSE, colour=FALSE, size=FALSE),
legg1,
layout_matrix=lay2)
}
theme_custom <- function()
{
theme(
plot.background = element_rect(fill = "#002B36", colour = "#002B36"),
panel.background = element_rect(fill = "#002B36"),
panel.background = element_rect(fill = "#002B36"),
legend.background = element_rect(fill="#002B36", colour = "#002B36"),
legend.margin = unit(c(-4, -4), "cm"),
legend.key = element_rect(fill="#002B36", colour ="#002B36"),
legend.text =element_text(colour = "#DCD427"),
legend.title=element_text(colour = "#DCD427")
)
}
g_legend<-function(a.gplot){
tmp <- ggplot_gtable(ggplot_build(a.gplot))
leg <- which(sapply(tmp$grobs, function(x) x$name) == "guide-box")
legend <- tmp$grobs[[leg]]
#+ legend.margin = unit(-0.5, "cm")
legend
}
Try this,
g_legend<-function(gg){
tmp <- ggplot_gtable(ggplot_build(gg))
id <- which(sapply(tmp$grobs, function(x) x$name) == "guide-box")
leg <- tmp$grobs[[id]]
bkg <- leg[["grobs"]][[1]][["grobs"]][leg[["grobs"]][[1]][["layout"]][,"name"]=="background"][[1]][["gp"]][["fill"]]
leg <- gtable_add_grob(leg, grobs = rectGrob(gp=gpar(fill=bkg, col="red", lty=2)),
t=1, l=1, b=nrow(leg), r=ncol(leg), z=-1)
# no idea why, but the legend seems to have weird negative sizes
# that make the background overlap with neighbouring elements
# workaround: set those unidentified sizes to 1null
leg$widths[c(1,2,4,5)] <- unit(rep(1,4),"null")
leg$heights[c(1,2,4,5)] <- unit(rep(1,4),"null")
leg
}
Related
I want to round the values above the bar chart to one decimal place. For example 14 should be 1.5 and not 1.52977.
This is how the bar chart looks right now
This is my code:
CPUE1 <- CPUE
CPUE1$Strecke <- factor (CPUE1$Strecke, levels = c('30/31', '14', '12', '10','1c','1bc', '1b'))
ggplot(CPUE1, aes(x= Strecke, y= CPUE, fill = Strecke ))+
geom_bar(stat='identity', position = 'dodge')+
theme_minimal()+
geom_text (aes (label = CPUE), position=position_dodge(width=0.9), vjust=-0.25)+
scale_fill_manual (values =
c("12" = "green", "10"= "green",
"1c" = "green", "14"= "red",
"1b"= "red","1bc"= "red","30/31" = "red"))
Add round to your geom_text:
library(tidyverse)
tribble(
~Strecke, ~CPUE,
"1b", 1.333,
"1c", 1.222,
"1b", 2.666,
"1c", 2.777
) |>
mutate(Strecke = factor(Strecke)) |>
ggplot(aes(Strecke, CPUE, fill = Strecke)) +
geom_bar(stat = "identity", position = "dodge") +
theme_minimal() +
geom_text(aes(label = round(CPUE, 1)), position = position_dodge(width = 0.9), vjust = -0.25) +
scale_fill_manual(values = c("1b" = "red", "1c" = "blue"))
Created on 2022-07-07 by the reprex package (v2.0.1)
Given this data here:
p <- ggplot(mpg, aes(displ, cty)) + geom_point() + facet_grid(drv ~ cyl)
g <- ggplot_gtable(ggplot_build(p))
strip_both <- which(grepl('strip-', g$layout$name))
fills <- c("red","green","blue","yellow","red","green","blue","yellow")
k <- 1
for (i in strip_both) {
j <- which(grepl('rect', g$grobs[[i]]$grobs[[1]]$childrenOrder))
g$grobs[[i]]$grobs[[1]]$children[[j]]$gp$fill <- fills[k]
k <- k+1
}
grid.draw(g)
I want to add a legend for the colors of the facets:
as shown here
One option to achieve your desired result would be with an auxiliary geom_point layer which draws nothing but is only used to map a variable with your desired four categories on the fill aes. Doing so will automatically add a fill legend for which we could set your desired colors using scale_fill_manual. Additionally I switched the key_glyph for the point layer to draw_key_rectto mimic your desired style for the legend keys and added na.rm to silent the warning about removed NAs:
library(ggplot2)
library(grid)
p <- ggplot(mpg, aes(displ, cty)) + geom_point() + facet_grid(drv ~ cyl) +
geom_point(data = data.frame(x = NA_real_, y = NA_real_, fill = c("AB", "D", "FF", "v")),
aes(x = x, y = y, fill = fill), na.rm = TRUE, key_glyph = "rect") +
scale_fill_manual(values = c("AB" = "red", D = "yellow", FF = "blue", v = "green"), name = NULL) +
theme(legend.position = "bottom")
g <- ggplot_gtable(ggplot_build(p))
strip_both <- which(grepl('strip-', g$layout$name))
fills <- c("red","green","blue","yellow","red","green","blue","yellow")
k <- 1
for (i in strip_both) {
j <- which(grepl('rect', g$grobs[[i]]$grobs[[1]]$childrenOrder))
g$grobs[[i]]$grobs[[1]]$children[[j]]$gp$fill <- fills[k]
k <- k+1
}
grid.draw(g)
Using the plotly library, I made the following plot in R:
library(dplyr)
library(ggplot2)
library(plotly)
set.seed(123)
df <- data.frame(var1 = rnorm(1000,10,10),
var2 = rnorm(1000,5,5))
df <- df %>% mutate(var3 = ifelse(var1 <= 5 & var2 <= 5, "a", ifelse(var1 <= 10 & var2 <= 10, "b", "c")))
plot = df %>%
ggplot() + geom_point(aes(x=var1, y= var2, color= var3))
ggplotly(plot)
This is a simple scatter plot - two random variables are generated, and then the colors of the points are decided by some criteria (e.g. if var1 and var2 are between certain ranges).
From here, I could also summary statistics:
df$var3 = as.factor(df$var3)
summary = df %>%
group_by(var3) %>%
summarize(Mean_var1 = mean(var1), Mean_var2 = mean(var2), count=n())
# A tibble: 3 x 4
var3 Mean_var1 Mean_var2 count
* <fct> <dbl> <dbl> <int>
1 a -1.70 0.946 158
2 b 4.68 4.94 260
3 c 15.8 6.49 582
My question: is it possible to add some buttons to this plot which would allow the user to color the points based on custom choices? E.g. something like this :
Now, the user can type in any range they want - and the color of the points change, and the some summary statistics are generated.
Can someone please show me how to do this in R?
I had this idea - first I would create this massive table that would create all possible range combinations of "var1" and "var2":
vec1 <- c(-20:40,1)
vec2 <- c(-20:40,1)
a <- expand.grid(vec1, vec2)
for (i in seq_along(vec1)) {
for (j in seq_along(vec2)) {
df <- df %>% mutate(var3 = ifelse(var1 <= i & var2 <= i, "a", ifelse(var1 <= j & j <= 10, "b", "c")))
}
}
Then, depending on which ranges the user wants - an SQL style statement isolate the rows from this massive table corresponding to those ranges :
custom_df = df[df$var1 > -20 & df$var1 <10 & df$var1 > -20 & df$var2 <10 , ]
Then, an individual grap would be made for "custom_df" and summary statistics would also be recorded for "custom_df":
summary = custom_df %>%
group_by(var3) %>%
summarize(Mean_var1 = mean(var1), Mean_var2 = mean(var2), count=n())
But I am not sure how to neatly and efficiently do this in R.
Can someone please show me how to do this?
Thanks
I have built a small shiny app to perform most of your requirements. Based on your pre-defined large dataframe df, user can define the following:
Choose the minimum and maximum value for variables var1 and var2.
Choose criteria to define the variable var3, which is used to display different colors of data points. This is a range now.
Save plot as a HTML file.
Summary stats displayed as a table.
You can define further options to provide the user the option to choose color and so on. For that perhaps you should google on how to use scale_color_manual().
Update: Added user option to choose red and green color based on var1 and var2 range values.
library(shiny)
library(plotly)
library(dplyr)
library(DT)
### define a large df
set.seed(123)
df <- data.frame(var1 = rnorm(1000,10,10),
var2 = rnorm(1000,15,15))
ui <- fluidPage(
titlePanel(p("My First Test App", style = "color:red")),
sidebarLayout(
sidebarPanel(
p("Choose Variable limits"),
# Horizontal line ----
tags$hr(),
uiOutput("var1a"), uiOutput("var1b"),
uiOutput("var2a"), uiOutput("var2b"),
uiOutput("criteria")
),
mainPanel(
DTOutput("summary"), br(),
plotlyOutput("plot"),
br(), br(), br(),
uiOutput("saveplotbtn")
)
)
)
server <- function(input, output, session){
output$var1a <- renderUI({
tagList(
numericInput("var11", "Variable 1 min",
min = min(df$var1), max = max(df$var1), value = min(df$var1))
)
})
output$var1b <- renderUI({
if (is.null(input$var11)){
low1 <- min(df$var1)
}else low1 <- max(min(df$var1),input$var11) ## cannot be lower than var 1 minimum
tagList(
numericInput("var12", "Variable 1 max", min = low1, max = max(df$var1), value = max(df$var1))
)
})
output$var2a <- renderUI({
tagList(
numericInput("var21", "Variable 2 min",
min = min(df$var2), max = max(df$var2), value = min(df$var2))
)
})
output$var2b <- renderUI({
if (is.null(input$var21)){
low2 <- min(df$var2)
}else low2 <- max(min(df$var2),input$var21) ## cannot be lower than var 2 minimum
tagList(
numericInput("var22", "Variable 2 max", min = low2, max = max(df$var2), value = max(df$var2))
)
})
output$criteria <- renderUI({
req(input$var11,input$var12,input$var21,input$var22)
tagList(
sliderInput("crit11", "Variable 1 red color range:",
min = -10, max = 0, value = c(-10,0)),
sliderInput("crit12", "Variable 2 red color range:",
min = -25, max = 0, value = c(-25,0)),
sliderInput("crit21", "Variable 1 green color range:",
min = 0.1, max = 10, value = c(0.1,10)),
sliderInput("crit22", "Variable 2 green color range:",
min = 0.1, max = 20, value = c(0.1,20))
)
})
dat <- reactive({
req(input$crit11,input$crit12,input$crit21,input$crit22)
df <- df %>% filter(between(var1, input$var11, input$var12)) %>%
filter(between(var2, input$var21, input$var22))
# df1 <- df %>% mutate(var3 = ifelse(var1 <= i & var2 <= i, "a", ifelse(var1 <= j & var2 <= j , "b", "c")))
df1 <- df %>% mutate(var3 = ifelse(between(var1, input$crit11[1], input$crit11[2]) & between(var2, input$crit12[1], input$crit12[2]), "a",
ifelse(between(var1, input$crit21[1], input$crit21[2]) & between(var2, input$crit22[1], input$crit22[2]), "b", "c")))
})
summari <- reactive({
req(dat())
df1 <- dat()
df1$var3 = as.factor(df1$var3)
summary = df1 %>%
group_by(var3) %>%
dplyr::summarize(Mean_var1 = mean(var1), Mean_var2 = mean(var2), count=n())
})
output$summary <- renderDT(summari())
rv <- reactiveValues()
observe({
req(dat())
p <- ggplot(data=dat()) + geom_point(aes(x=var1, y= var2, color= var3))
pp <- ggplotly(p)
rv$plot <- pp
})
output$plot <- renderPlotly({
rv$plot
})
output$saveplotbtn <- renderUI({
div(style="display: block; padding: 5px 350px 5px 50px;",
downloadBttn("saveHTML",
HTML("HTML"),
style = "fill",
color = "default",
size = "lg",
block = TRUE,
no_outline = TRUE
) )
})
output$saveHTML <- downloadHandler(
filename = function() {
paste("myplot", Sys.Date(), ".html", sep = "")
},
content = function(file) {
htmlwidgets::saveWidget(as_widget(rv$plot), file, selfcontained = TRUE) ## self-contained
}
)
}
shinyApp(ui, server)
How can I create a "table result" to each relationship I assumed in the selectInput "Col" and "Row"? Dinamicaly, after each press 'ok' botom.
library(shiny)
shinyUI(fluidPage(
h4("Give a valor between 0 to 5, to each col/row relationship"),
uiOutput("colrow"),
hr(),
h5("Result:"),
tableOutput("result")
))
shinyServer(
function(input, output, session) {
cols <<- c("Select"="", "col01" = "c01", "col02" = "c02")
rows <<- c("Select"="", "row01" = "r01", "row02" = "r02")
values <<- c("Select"="", 1:5)
output$colrow <- renderUI({
div(selectInput("ipt_col", label = "Col",
choices = c(cols),
selected = cols[1],
width = "50%"),
selectInput("ipt_row", label = "Row",
choices = c(rows),
selected = rows[1],
width = "50%"),
selectInput("ipt_vlr", label = "Value",
choices = c(values),
selected = ""),
actionButton("bt_ok", "ok")
)
})
colrow_vlr <- eventReactive(input$bt_ok, {
as.data.frame(matrix(input$ipt_vlr, 1,1, dimnames = list(input$ipt_row,input$ipt_col)))
})
output$result <- renderTable({
colrow_vlr()
})
})
I changed your code a little bit and now it works. I added comments at where the changes were made.
library(shiny)
ui <- fluidPage(
h4("Give a valor between 0 to 5, to each col/row relationship"),
uiOutput("colrow"),
hr(),
h5("Result:"),
# using DT which is recommended in shiny
DT::dataTableOutput("result")
)
server <- function(input, output, session) {
# no need to assign in the global env especially 'cols' is reserved
cols <- c("Select"="", "col01" = "c01", "col02" = "c02")
rows <- c("Select"="", "row01" = "r01", "row02" = "r02")
values <- c("Select"="", 1:5)
output$colrow <- renderUI({
div(selectInput("ipt_col", label = "Col",
choices = cols, # no need to wrap with c()
selected = cols[1],
width = "50%"),
selectInput("ipt_row", label = "Row",
choices = rows,
selected = rows[1],
width = "50%"),
selectInput("ipt_vlr", label = "Value",
choices = values,
selected = ""),
actionButton("bt_ok", "ok")
)
})
colrow_vlr <- eventReactive(input$bt_ok, {
as.data.frame(matrix(input$ipt_vlr, 1,1, dimnames = list(input$ipt_row,input$ipt_col)))
})
output$result <- DT::renderDataTable({
colrow_vlr()
})
}
shinyApp(ui = ui, server = server)
To a 3 year old post
ggplot2: facet_wrap strip color based on variable in data set
Baptiste has given the following solution:
d <- data.frame(fruit = rep(c("apple", "orange", "plum", "banana", "pear", "grape")),
farm = rep(c(0,1,3,6,9,12), each=6),
weight = rnorm(36, 10000, 2500),
size=rep(c("small", "large")))
p1 = ggplot(data = d, aes(x = farm, y = weight)) +
geom_jitter(position = position_jitter(width = 0.3),
aes(color = factor(farm)), size = 2.5, alpha = 1) +
facet_wrap(~fruit)
dummy <- ggplot(data = d, aes(x = farm, y = weight))+ facet_wrap(~fruit) +
geom_rect(aes(fill=size), xmin=-Inf, xmax=Inf, ymin=-Inf, ymax=Inf) +
theme_minimal()
library(gtable)
g1 <- ggplotGrob(p1)
g2 <- ggplotGrob(dummy)
gtable_select <- function (x, ...)
{
matches <- c(...)
x$layout <- x$layout[matches, , drop = FALSE]
x$grobs <- x$grobs[matches]
x
}
panels <- grepl(pattern="panel", g2$layout$name)
strips <- grepl(pattern="strip-t", g2$layout$name)
g2$layout$t[panels] <- g2$layout$t[panels] - 1
g2$layout$b[panels] <- g2$layout$b[panels] - 1
new_strips <- gtable_select(g2, panels | strips)
library(grid)
grid.newpage()
grid.draw(new_strips)
gtable_stack <- function(g1, g2){
g1$grobs <- c(g1$grobs, g2$grobs)
g1$layout <- transform(g1$layout, z= z-max(z), name="g2")
g1$layout <- rbind(g1$layout, g2$layout)
g1
}
## ideally you'd remove the old strips, for now they're just covered
new_plot <- gtable_stack(g1, new_strips)
grid.newpage()
grid.draw(new_plot)
(I have just updated the "strip-t" pattern and opened the grid library as it was suggested in the old post)
I repost this because it's an old brillant stuff and I want to use it myself for a presentation.
I'm a beginner in ggplot and this could also help me for various scripts.
Here are my questions :
- How is it possible to choose the color and not to give the same blue and red please? In my script, I have 3 colors to set, and I hope it can be less agressive. Is it possible to do it ?
- Another question, is it possible to integrate this in the legend, i.e to know what are this colors refering ?
Many thanks
you can change the strip colours with the fill scale in the dummy plot. Combining the legends is a bit tricky, but here's a starting point.
library(ggplot2)
library(gtable)
library(gridExtra)
library(grid)
gtable_stack <- function(g1, g2){
g1$grobs <- c(g1$grobs, g2$grobs)
g1$layout <- transform(g1$layout, z= z-max(z), name="g2")
g1$layout <- rbind(g1$layout, g2$layout)
g1
}
gtable_select <- function (x, ...)
{
matches <- c(...)
x$layout <- x$layout[matches, , drop = FALSE]
x$grobs <- x$grobs[matches]
x
}
d <- data.frame(fruit = rep(c("apple", "orange", "plum", "banana", "pear", "grape")),
farm = rep(c(0,1,3,6,9,12), each=6),
weight = rnorm(36, 10000, 2500),
size=rep(c("small", "large")))
p1 = ggplot(data = d, aes(x = farm, y = weight)) +
geom_jitter(position = position_jitter(width = 0.3),
aes(color = factor(farm)), size = 2.5, alpha = 1) +
facet_wrap(~fruit)
dummy <- ggplot(data = d, aes(x = farm, y = weight))+ facet_wrap(~fruit) +
geom_rect(aes(fill=size), xmin=-Inf, xmax=Inf, ymin=-Inf, ymax=Inf) +
theme_minimal() + scale_fill_brewer(palette = "Pastel2")
g1 <- ggplotGrob(p1)
g2 <- ggplotGrob(dummy)
# extract legends
leg <- g1$grobs[[grep("guide-box", g1$layout$name)]]
dummy_leg <- g2$grobs[[grep("guide-box", g2$layout$name)]]
combined_leg <- rbind.gtable(leg, dummy_leg)
g1$grobs[[grep("guide-box", g1$layout$name)]] <- combined_leg
# move dummy panels one cell up
panels <- grepl(pattern="panel", g2$layout$name)
strips <- grepl(pattern="strip-t", g2$layout$name)
g2$layout$t[panels] <- g2$layout$t[panels] - 1
g2$layout$b[panels] <- g2$layout$b[panels] - 1
new_strips <- gtable_select(g2, panels | strips)
# stack new strips on top of gtable
# ideally you'd remove the old strips, for now they're just covered
new_plot <- gtable_stack(g1, new_strips)
grid.newpage()
grid.draw(new_plot)