Related
I was wondering if anyone knows a way to combine a table and ggplot legend so that the legend appears as a column in the table as shown in the image. Sorry if this has been asked before but I haven't been able to find a way to do this.
Edit: attached is code to produce the output below (minus the legend/table combination, which I am trying to produce, as I stitched that together in Powerpoint)
library(ggplot2)
library(gridExtra)
library(dplyr)
library(formattable)
library(signal)
#dataset for ggplot
full.data <- structure(list(error = c(0, 1, 2, 3, 4, 5, 6, 0, 1, 2, 3, 4,
5, 6, 0, 1, 2, 3, 4, 5, 6, 0, 1, 2, 3, 4, 5, 6, 0, 1, 2, 3, 4,
5, 6, 0, 1, 2, 3, 4, 5, 6), prob.ed.n = c(0, 0, 0.2, 0.5, 0.8,
1, 1, 0, 0, 0.3, 0.7, 1, 1, 1, 0, 0.1, 0.4, 0.9, 1, 1, 1, 0,
0.1, 0.5, 0.9, 1, 1, 1, 0, 0.1, 0.6, 1, 1, 1, 1, 0, 0.1, 0.6,
1, 1, 1, 1), N = c(1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 2,
3, 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 5, 5, 5, 5, 5, 5, 5,
6, 6, 6, 6, 6, 6, 6)), row.names = c(NA, -42L), class = "data.frame")
#summary table
summary.table <- structure(list(prob.fr = c("1.62%", "1.35%", "1.09%", "0.81%", "0.54%", "0.27%"), prob.ed.n = c("87.4%", "82.2%", "74.8%", "64.4%", "49.8%", "29.2%"), N = c(6, 5, 4, 3, 2, 1)), row.names = c(NA,
-6L), class = "data.frame")
#table object to beincluded with ggplot
table <- tableGrob(summary.table %>%
rename(
`Prb FR` = prob.fr,
`Prb ED` = prob.ed.n,
),
rows = NULL)
#plot
plot <- ggplot(full.data, aes(x = error, y = prob.ed.n, group = N, colour = as.factor(N))) +
geom_vline(xintercept = 2.45, colour = "red", linetype = "dashed") +
geom_hline(yintercept = 0.9, linetype = "dashed") +
geom_line(data = full.data %>%
group_by(N) %>%
do({
tibble(error = seq(min(.$error), max(.$error),length.out=100),
prob.ed.n = pchip(.$error, .$prob.ed.n, error))
}),
size = 1) +
scale_x_continuous(labels = full.data$error, breaks = full.data$error, expand = c(0, 0.05)) +
scale_y_continuous(expand = expansion(add = c(0.01, 0.01))) +
scale_color_brewer(palette = "Dark2") +
guides(color = guide_legend(reverse=TRUE, nrow = 1)) +
theme_bw() +
theme(legend.key = element_rect(fill = "white", colour = "black"),
legend.direction= "horizontal",
legend.position=c(0.8,0.05)
)
#arrange plot and grid side-by-side
grid.arrange(plot, table, nrow = 1, widths = c(4,1))
A simple approach is to use the legend labels themselves as the table. Here I demonstrate using knitr::kable to automatically format the table column widths:
library(knitr)
table = summary.table %>%
rename(`Prb FR` = prob.fr, `Prb ED` = prob.ed.n) %>%
kable %>%
gsub('|', ' ', ., fixed = T) %>%
strsplit('\n') %>%
trimws
header = table[[1]]
header = paste0(header, '\n', paste0(rep('─', nchar(header)), collapse =''))
table = table[-(1:2)]
table = do.call(rbind, table)[,1]
table = data.frame(N=summary.table$N, lab = table)
plot_data = full.data %>%
group_by(N) %>%
do({
tibble(error = seq(min(.$error), max(.$error),length.out=100),
prob.ed.n = pchip(.$error, .$prob.ed.n, error))
}) %>%
left_join(table)
ggplot(plot_data, aes(x = error, y = prob.ed.n, group = N, colour = lab)) +
geom_line() +
guides(color = guide_legend(header, reverse=TRUE,
label.position = "left",
title.theme = element_text(size=8, family='mono'),
label.theme = element_text(size=8, family='mono'))) +
theme(
legend.key = element_rect(fill = NA, colour = NA),
legend.spacing.y = unit(0, "pt"),
legend.key.height = unit(10, "pt"),
legend.background = element_blank())
This is an interesting problem. The short answer: Yes, it's possible. But I don't see a way around hard coding the position of table and legend, which is ugly.
The suggestion below requires hard coding in three places. I am using {ggpubr} for the table, and {cowplot} for the stitching.
Another problem arises from the legend key spacing for vertical legends. This is still a rather unresolved issue for other keys than polygons, to my knowledge. The associated GitHub issue is closed The legend spacing is not a problem any more. Ask teunbrand, and he knows the answer.
Some other relevant comments in the code.
library(tidyverse)
library(ggpubr)
library(cowplot)
#>
#> Attaching package: 'cowplot'
#> The following object is masked from 'package:ggpubr':
#>
#> get_legend
full.data <- structure(list(error = c(
0, 1, 2, 3, 4, 5, 6, 0, 1, 2, 3, 4,
5, 6, 0, 1, 2, 3, 4, 5, 6, 0, 1, 2, 3, 4, 5, 6, 0, 1, 2, 3, 4,
5, 6, 0, 1, 2, 3, 4, 5, 6
), prob.ed.n = c(
0, 0, 0.2, 0.5, 0.8,
1, 1, 0, 0, 0.3, 0.7, 1, 1, 1, 0, 0.1, 0.4, 0.9, 1, 1, 1, 0,
0.1, 0.5, 0.9, 1, 1, 1, 0, 0.1, 0.6, 1, 1, 1, 1, 0, 0.1, 0.6,
1, 1, 1, 1
), N = c(
1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 2,
3, 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 5, 5, 5, 5, 5, 5, 5,
6, 6, 6, 6, 6, 6, 6
)), row.names = c(NA, -42L), class = "data.frame")
summary.table <-
structure(list(
prob.fr = c("1.62%", "1.35%", "1.09%", "0.81%", "0.54%", "0.27%"),
prob.ed.n = c("87.4%", "82.2%", "74.8%", "64.4%", "49.8%", "29.2%"),
N = c(6, 5, 4, 3, 2, 1)
), row.names = c(NA, -6L), class = "data.frame")
## Hack 1 - create some space for the new legend
spacer <- paste(rep(" ", 6), collapse = "")
my_table <-
summary.table %>%
mutate(N = paste(spacer, N))
p1 <-
ggplot(full.data, aes(x = error, y = prob.ed.n, group = N, colour = as.factor(N))) +
geom_vline(xintercept = 2.45, colour = "red", linetype = "dashed") +
geom_hline(yintercept = 0.9, linetype = "dashed") +
geom_line(
data = full.data %>%
group_by(N) %>%
do({
tibble(
error = seq(min(.$error), max(.$error), length.out = 100),
prob.ed.n = signal::pchip(.$error, .$prob.ed.n, error)
)
}),
size = 1
) +
## remove the legend labels. You have them in the table already.
scale_color_brewer(NULL, palette = "Dark2", labels = rep("", length(unique(full.data$N)))) +
## remove all the legend specs! I've also removed the not so important reverse scale
## I have removed fill and color to make it aesthetically more pleasing
theme(
legend.key = element_rect(fill = NA, colour = NA),
## hack 2 - hard code legend key spacing
legend.spacing.y = unit(1.8, "pt"),
legend.background = element_blank()
) +
## make y spacing work
guides(color = guide_legend(byrow = TRUE))
## create the plot elements
p_leg <- cowplot::get_legend(p1)
p2 <- ggtexttable(my_table, rows = NULL)
## we don't want the legend twice
p <- p1 + theme(legend.position = "none")
## hack 3 - hard code the plot element positions
ggdraw(p, xlim = c(0, 1.7)) +
draw_plot(p2, x = .8) +
draw_plot(p_leg, x = .97, y = 0.975, vjust = 1)
Created on 2021-12-31 by the reprex package (v2.0.1)
My solution is not quite what you're looking for, but conveys the information and would be much easier to produce and to cope with graphs of differing numbers of lines. I've coloured the boxes with the colours from the lines, rather than adding a coloured line.
NB: Legend kept to show the match between line colours and filled boxes.
The full code:
library(ggplot2)
library(gridExtra)
library(dplyr)
library(formattable)
library(signal)
#dataset for ggplot
full.data <- structure(list(error = c(0, 1, 2, 3, 4, 5, 6, 0, 1, 2, 3, 4,
5, 6, 0, 1, 2, 3, 4, 5, 6, 0, 1, 2, 3, 4, 5, 6, 0, 1, 2, 3, 4,
5, 6, 0, 1, 2, 3, 4, 5, 6), prob.ed.n = c(0, 0, 0.2, 0.5, 0.8,
1, 1, 0, 0, 0.3, 0.7, 1, 1, 1, 0, 0.1, 0.4, 0.9, 1, 1, 1, 0,
0.1, 0.5, 0.9, 1, 1, 1, 0, 0.1, 0.6, 1, 1, 1, 1, 0, 0.1, 0.6,
1, 1, 1, 1), N = c(1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 2,
3, 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 5, 5, 5, 5, 5, 5, 5,
6, 6, 6, 6, 6, 6, 6)), row.names = c(NA, -42L), class = "data.frame")
#summary table
summary.table <- structure(list(prob.fr = c("1.62%", "1.35%", "1.09%", "0.81%", "0.54%", "0.27%"),
prob.ed.n = c("87.4%", "82.2%", "74.8%", "64.4%", "49.8%", "29.2%"),
N = c(6, 5, 4, 3, 2, 1)), row.names = c(NA,-6L), class = "data.frame")
# table object to beincluded with ggplot
table <- tableGrob(summary.table %>%
rename(
`Prb FR` = prob.fr,
`Prb ED` = prob.ed.n,
), rows = NULL)
# Change cells to match the line colours
# Id the colour codes
color_range <- RColorBrewer::brewer.pal(8, "Dark2") # Find the colours being used in the graph
# Function to find the cell in a tableGrob
find_cell <- function(table, row, col, name="core-fg"){
l <- table$layout
which(l$t==row & l$l==col & l$name==name)
}
# Fill the cells with the appropriate colour
for(i in 1:nrow(summary.table)) {
cell_ref <- find_cell(table, i+1, 3, "core-bg")
table$grobs[cell_ref][[1]][["gp"]] <- grid::gpar(fill=color_range[nrow(summary.table)+1-i], col = color_range[nrow(summary.table)+1-i], lwd=5)
}
#plot
plot <- ggplot(full.data, aes(x = error, y = prob.ed.n, group = N, colour = as.factor(N))) +
geom_vline(xintercept = 2.45, colour = "red", linetype = "dashed") +
geom_hline(yintercept = 0.9, linetype = "dashed") +
geom_line(data = full.data %>%
group_by(N) %>%
do({
tibble(error = seq(min(.$error), max(.$error),length.out=100),
prob.ed.n = pchip(.$error, .$prob.ed.n, error))
}),
size = 1) +
scale_x_continuous(labels = full.data$error, breaks = full.data$error, expand = c(0, 0.05)) +
scale_y_continuous(expand = expansion(add = c(0.01, 0.01))) +
scale_color_brewer(palette = "Dark2") +
guides(color = guide_legend(reverse=TRUE, nrow = 1)) +
theme_minimal() +
theme(legend.key = element_rect(fill = "white", colour = "black"),
legend.direction= "horizontal",
legend.position=c(0.8,0.05)
)
#arrange plot and grid side-by-side
grid.arrange(plot, table, nrow = 1, widths = c(4,1))
Let's suppose we have the following plot, which is simplified for brevity from the example code and has a vertical legend.
library(ggplot2)
library(gridExtra)
library(dplyr)
library(formattable)
library(signal)
# Omitted full code, same as in question
# full.data <- structure(...)
# summary.table <- structure(...)
# table <- tableGrob(...)
# Simplified plot
plot <- ggplot(full.data, aes(x = error, y = prob.ed.n, group = N, colour = as.factor(N))) +
geom_line(data = full.data %>%
group_by(N) %>%
do({
tibble(error = seq(min(.$error), max(.$error),length.out=100),
prob.ed.n = pchip(.$error, .$prob.ed.n, error))
}),
size = 1) +
guides(color = guide_legend(reverse=TRUE)) +
theme(legend.key = element_rect(fill = "white", colour = "black"))
plot
We can write the following function to place the legend keys into the table. It is a bit unwieldy because gtable and grid code is often not very elegant, but it should do the job. By default, it replaces the last column in the tableGrob output with the keys of the first legend.
Note that this only handles vertical legends, not horizontal ones. Also, it is a bit naive in assuming the table and legend fit together in their natural order: it doesn't do any fancy label matching and assumes the order in the table and legend are the same.
library(grid)
library(gtable)
#' #param tableGrob The output of the `gridExtra::tableGrob()` function.
#' #param plot A ggplot2 object with a single, vertical legend
#' #param replace_col An `integer(1)` with the column number in the
#' table to replace with keys. Defaults to the last one.
#' #param key_padding The amount of extra space to surround keys with,
#' as a `grid::unit()` object.
#'
#' #return A modified version of the `tableGrob` argument
add_legend_column <- function(
tableGrob,
plot,
replace_col = ncol(tableGrob),
key_padding = unit(5.5, "pt")
) {
# Getting legend keys
keys <- cowplot::get_legend(plot)
keys <- keys$grobs[[which(keys$layout$name == "guides")[1]]]
keys <- gtable_filter(keys, 'label|key')
idx <- unique(keys$layout$t)
keys <- lapply(idx, function(i) {
x <- keys[i, ]
# Set justification of keys
x$vp$x <- unit(0.5, "npc")
x$vp$justification <- x$vp$valid.just <- c(0.5, 1)
# Set key padding
x <- gtable_add_padding(x, key_padding)
x
})
if (nrow(table) != length(keys) + 1) {
stop("Keys don't fit in the table")
}
# Measure keys
width <- max(do.call(unit.c, lapply(keys, grobWidth)))
width <- max(width, table$widths[replace_col])
height <- do.call(unit.c, lapply(keys, grobHeight))
# Delete foreground content of the column to replace
drop <- table$layout$l == replace_col & table$layout$t != 1
drop <- drop & endsWith(table$layout$name, "-fg")
table$grobs <- table$grobs[!drop]
table$layout <- table$layout[!drop, ]
# Add keys to table
table <- gtable_add_grob(
table, keys, name = "key",
t = seq_along(keys) + 1,
l = replace_col
)
# Set dimensions
table$widths[replace_col] <- width
table$heights[-1] <- unit.pmax(table$heights[-1], height)
return(table)
}
Lastly, we can add the table in our favorite plot composition package as follows. Note that the text size of the legend and the table mismatched, so I've set the legend text size to match the one of the table. Naturally, the plot looks better after you delete the legend that we capture in the table.
library(patchwork)
#>
#> Attaching package: 'patchwork'
#> The following object is masked from 'package:formattable':
#>
#> area
(plot + theme(legend.position = "none")) +
add_legend_column(table, plot + theme(legend.text = element_text(size = 12)))
I have no idea how well this generalises when the plot has > 1 legend or when the tableGrob() has additional options turned on or off, it is the first time I've used this function.
I suggest defining the plot and table seperately and then stitching them together. To get colors for the table, you could extract the scale_color_brewer values from the ggplot object and dynamically define your table theme. To stitch, use your favorite multiplot graphics tool, like gridExtra::grid.arrange().
The difference between this answer and the above answer (https://stackoverflow.com/a/70581378/7941188) is I'm extracting the scale colors directly from the ggplot object to define the colors in the accompanying table. This makes sure the colors are matched up, and theoretically you could use this approach with multiple scales/legends.
Do you want the typical ggplot legend keys? Or is coloring the background of a cell sufficient? EDIT: I updated my answer to show how you could use unicode symbols to approximate ggplot legend keys.
library(ggplot2)
library(gridExtra)
library(signal)
ldata <- full.data %>%
group_by(N) %>%
do({
tibble(error = seq(min(.$error), max(.$error),length.out=100),
prob.ed.n = pchip(.$error, .$prob.ed.n, error))
})
#plot
p <- ggplot(full.data, aes(x = error, y = prob.ed.n, group = N, colour = as.factor(N))) +
geom_vline(xintercept = 2.45, colour = "red", linetype = "dashed") +
geom_hline(yintercept = 0.9, linetype = "dashed") +
geom_line(data = ldata, size = 1) +
scale_x_continuous(labels = full.data$error, breaks = full.data$error, expand = c(0, 0.05)) +
scale_y_continuous(expand = expansion(add = c(0.01, 0.01))) +
scale_color_brewer(palette = "Dark2") +
theme_bw() +
theme(legend.position = "none")
# Get scale data from ggplot object
pb <- ggplot_build(p)
scale_cols <- unique(pb$data[[3]][,c("colour", "group")])
table2 <- merge(table, scale_cols, by.x = "N", by.y = "group", sort = FALSE)
table2$N2 <- "\u2015"
table2 <- table2[,c("N", "N2", "Prb FR", "Prb ED", "colour")]
# Define vectors of fills and colors for table
fills <- c(table2$colour, rep("grey90", nrow(table2)*4))
cols <- c(rep("black", nrow(table2)*1), table2$colour, rep("black", nrow(table2)*3))
bgcols <- c(rep("white", nrow(table2)*5))
tt <- ttheme_default(core=list(bg_params = list(fill=fills, col=bgcols), fg_params = list(col=cols)))
t <- tableGrob(table2, theme = tt, rows = NULL)
# Combine plot and table
grid.arrange(p, t[,c(1:4)], nrow = 1, ncol = 2, widths=c(2,0.5))
I was wondering if anyone knows a way to combine a table and ggplot legend so that the legend appears as a column in the table as shown in the image. Sorry if this has been asked before but I haven't been able to find a way to do this.
Edit: attached is code to produce the output below (minus the legend/table combination, which I am trying to produce, as I stitched that together in Powerpoint)
library(ggplot2)
library(gridExtra)
library(dplyr)
library(formattable)
library(signal)
#dataset for ggplot
full.data <- structure(list(error = c(0, 1, 2, 3, 4, 5, 6, 0, 1, 2, 3, 4,
5, 6, 0, 1, 2, 3, 4, 5, 6, 0, 1, 2, 3, 4, 5, 6, 0, 1, 2, 3, 4,
5, 6, 0, 1, 2, 3, 4, 5, 6), prob.ed.n = c(0, 0, 0.2, 0.5, 0.8,
1, 1, 0, 0, 0.3, 0.7, 1, 1, 1, 0, 0.1, 0.4, 0.9, 1, 1, 1, 0,
0.1, 0.5, 0.9, 1, 1, 1, 0, 0.1, 0.6, 1, 1, 1, 1, 0, 0.1, 0.6,
1, 1, 1, 1), N = c(1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 2,
3, 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 5, 5, 5, 5, 5, 5, 5,
6, 6, 6, 6, 6, 6, 6)), row.names = c(NA, -42L), class = "data.frame")
#summary table
summary.table <- structure(list(prob.fr = c("1.62%", "1.35%", "1.09%", "0.81%", "0.54%", "0.27%"), prob.ed.n = c("87.4%", "82.2%", "74.8%", "64.4%", "49.8%", "29.2%"), N = c(6, 5, 4, 3, 2, 1)), row.names = c(NA,
-6L), class = "data.frame")
#table object to beincluded with ggplot
table <- tableGrob(summary.table %>%
rename(
`Prb FR` = prob.fr,
`Prb ED` = prob.ed.n,
),
rows = NULL)
#plot
plot <- ggplot(full.data, aes(x = error, y = prob.ed.n, group = N, colour = as.factor(N))) +
geom_vline(xintercept = 2.45, colour = "red", linetype = "dashed") +
geom_hline(yintercept = 0.9, linetype = "dashed") +
geom_line(data = full.data %>%
group_by(N) %>%
do({
tibble(error = seq(min(.$error), max(.$error),length.out=100),
prob.ed.n = pchip(.$error, .$prob.ed.n, error))
}),
size = 1) +
scale_x_continuous(labels = full.data$error, breaks = full.data$error, expand = c(0, 0.05)) +
scale_y_continuous(expand = expansion(add = c(0.01, 0.01))) +
scale_color_brewer(palette = "Dark2") +
guides(color = guide_legend(reverse=TRUE, nrow = 1)) +
theme_bw() +
theme(legend.key = element_rect(fill = "white", colour = "black"),
legend.direction= "horizontal",
legend.position=c(0.8,0.05)
)
#arrange plot and grid side-by-side
grid.arrange(plot, table, nrow = 1, widths = c(4,1))
A simple approach is to use the legend labels themselves as the table. Here I demonstrate using knitr::kable to automatically format the table column widths:
library(knitr)
table = summary.table %>%
rename(`Prb FR` = prob.fr, `Prb ED` = prob.ed.n) %>%
kable %>%
gsub('|', ' ', ., fixed = T) %>%
strsplit('\n') %>%
trimws
header = table[[1]]
header = paste0(header, '\n', paste0(rep('─', nchar(header)), collapse =''))
table = table[-(1:2)]
table = do.call(rbind, table)[,1]
table = data.frame(N=summary.table$N, lab = table)
plot_data = full.data %>%
group_by(N) %>%
do({
tibble(error = seq(min(.$error), max(.$error),length.out=100),
prob.ed.n = pchip(.$error, .$prob.ed.n, error))
}) %>%
left_join(table)
ggplot(plot_data, aes(x = error, y = prob.ed.n, group = N, colour = lab)) +
geom_line() +
guides(color = guide_legend(header, reverse=TRUE,
label.position = "left",
title.theme = element_text(size=8, family='mono'),
label.theme = element_text(size=8, family='mono'))) +
theme(
legend.key = element_rect(fill = NA, colour = NA),
legend.spacing.y = unit(0, "pt"),
legend.key.height = unit(10, "pt"),
legend.background = element_blank())
This is an interesting problem. The short answer: Yes, it's possible. But I don't see a way around hard coding the position of table and legend, which is ugly.
The suggestion below requires hard coding in three places. I am using {ggpubr} for the table, and {cowplot} for the stitching.
Another problem arises from the legend key spacing for vertical legends. This is still a rather unresolved issue for other keys than polygons, to my knowledge. The associated GitHub issue is closed The legend spacing is not a problem any more. Ask teunbrand, and he knows the answer.
Some other relevant comments in the code.
library(tidyverse)
library(ggpubr)
library(cowplot)
#>
#> Attaching package: 'cowplot'
#> The following object is masked from 'package:ggpubr':
#>
#> get_legend
full.data <- structure(list(error = c(
0, 1, 2, 3, 4, 5, 6, 0, 1, 2, 3, 4,
5, 6, 0, 1, 2, 3, 4, 5, 6, 0, 1, 2, 3, 4, 5, 6, 0, 1, 2, 3, 4,
5, 6, 0, 1, 2, 3, 4, 5, 6
), prob.ed.n = c(
0, 0, 0.2, 0.5, 0.8,
1, 1, 0, 0, 0.3, 0.7, 1, 1, 1, 0, 0.1, 0.4, 0.9, 1, 1, 1, 0,
0.1, 0.5, 0.9, 1, 1, 1, 0, 0.1, 0.6, 1, 1, 1, 1, 0, 0.1, 0.6,
1, 1, 1, 1
), N = c(
1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 2,
3, 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 5, 5, 5, 5, 5, 5, 5,
6, 6, 6, 6, 6, 6, 6
)), row.names = c(NA, -42L), class = "data.frame")
summary.table <-
structure(list(
prob.fr = c("1.62%", "1.35%", "1.09%", "0.81%", "0.54%", "0.27%"),
prob.ed.n = c("87.4%", "82.2%", "74.8%", "64.4%", "49.8%", "29.2%"),
N = c(6, 5, 4, 3, 2, 1)
), row.names = c(NA, -6L), class = "data.frame")
## Hack 1 - create some space for the new legend
spacer <- paste(rep(" ", 6), collapse = "")
my_table <-
summary.table %>%
mutate(N = paste(spacer, N))
p1 <-
ggplot(full.data, aes(x = error, y = prob.ed.n, group = N, colour = as.factor(N))) +
geom_vline(xintercept = 2.45, colour = "red", linetype = "dashed") +
geom_hline(yintercept = 0.9, linetype = "dashed") +
geom_line(
data = full.data %>%
group_by(N) %>%
do({
tibble(
error = seq(min(.$error), max(.$error), length.out = 100),
prob.ed.n = signal::pchip(.$error, .$prob.ed.n, error)
)
}),
size = 1
) +
## remove the legend labels. You have them in the table already.
scale_color_brewer(NULL, palette = "Dark2", labels = rep("", length(unique(full.data$N)))) +
## remove all the legend specs! I've also removed the not so important reverse scale
## I have removed fill and color to make it aesthetically more pleasing
theme(
legend.key = element_rect(fill = NA, colour = NA),
## hack 2 - hard code legend key spacing
legend.spacing.y = unit(1.8, "pt"),
legend.background = element_blank()
) +
## make y spacing work
guides(color = guide_legend(byrow = TRUE))
## create the plot elements
p_leg <- cowplot::get_legend(p1)
p2 <- ggtexttable(my_table, rows = NULL)
## we don't want the legend twice
p <- p1 + theme(legend.position = "none")
## hack 3 - hard code the plot element positions
ggdraw(p, xlim = c(0, 1.7)) +
draw_plot(p2, x = .8) +
draw_plot(p_leg, x = .97, y = 0.975, vjust = 1)
Created on 2021-12-31 by the reprex package (v2.0.1)
My solution is not quite what you're looking for, but conveys the information and would be much easier to produce and to cope with graphs of differing numbers of lines. I've coloured the boxes with the colours from the lines, rather than adding a coloured line.
NB: Legend kept to show the match between line colours and filled boxes.
The full code:
library(ggplot2)
library(gridExtra)
library(dplyr)
library(formattable)
library(signal)
#dataset for ggplot
full.data <- structure(list(error = c(0, 1, 2, 3, 4, 5, 6, 0, 1, 2, 3, 4,
5, 6, 0, 1, 2, 3, 4, 5, 6, 0, 1, 2, 3, 4, 5, 6, 0, 1, 2, 3, 4,
5, 6, 0, 1, 2, 3, 4, 5, 6), prob.ed.n = c(0, 0, 0.2, 0.5, 0.8,
1, 1, 0, 0, 0.3, 0.7, 1, 1, 1, 0, 0.1, 0.4, 0.9, 1, 1, 1, 0,
0.1, 0.5, 0.9, 1, 1, 1, 0, 0.1, 0.6, 1, 1, 1, 1, 0, 0.1, 0.6,
1, 1, 1, 1), N = c(1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 2,
3, 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 5, 5, 5, 5, 5, 5, 5,
6, 6, 6, 6, 6, 6, 6)), row.names = c(NA, -42L), class = "data.frame")
#summary table
summary.table <- structure(list(prob.fr = c("1.62%", "1.35%", "1.09%", "0.81%", "0.54%", "0.27%"),
prob.ed.n = c("87.4%", "82.2%", "74.8%", "64.4%", "49.8%", "29.2%"),
N = c(6, 5, 4, 3, 2, 1)), row.names = c(NA,-6L), class = "data.frame")
# table object to beincluded with ggplot
table <- tableGrob(summary.table %>%
rename(
`Prb FR` = prob.fr,
`Prb ED` = prob.ed.n,
), rows = NULL)
# Change cells to match the line colours
# Id the colour codes
color_range <- RColorBrewer::brewer.pal(8, "Dark2") # Find the colours being used in the graph
# Function to find the cell in a tableGrob
find_cell <- function(table, row, col, name="core-fg"){
l <- table$layout
which(l$t==row & l$l==col & l$name==name)
}
# Fill the cells with the appropriate colour
for(i in 1:nrow(summary.table)) {
cell_ref <- find_cell(table, i+1, 3, "core-bg")
table$grobs[cell_ref][[1]][["gp"]] <- grid::gpar(fill=color_range[nrow(summary.table)+1-i], col = color_range[nrow(summary.table)+1-i], lwd=5)
}
#plot
plot <- ggplot(full.data, aes(x = error, y = prob.ed.n, group = N, colour = as.factor(N))) +
geom_vline(xintercept = 2.45, colour = "red", linetype = "dashed") +
geom_hline(yintercept = 0.9, linetype = "dashed") +
geom_line(data = full.data %>%
group_by(N) %>%
do({
tibble(error = seq(min(.$error), max(.$error),length.out=100),
prob.ed.n = pchip(.$error, .$prob.ed.n, error))
}),
size = 1) +
scale_x_continuous(labels = full.data$error, breaks = full.data$error, expand = c(0, 0.05)) +
scale_y_continuous(expand = expansion(add = c(0.01, 0.01))) +
scale_color_brewer(palette = "Dark2") +
guides(color = guide_legend(reverse=TRUE, nrow = 1)) +
theme_minimal() +
theme(legend.key = element_rect(fill = "white", colour = "black"),
legend.direction= "horizontal",
legend.position=c(0.8,0.05)
)
#arrange plot and grid side-by-side
grid.arrange(plot, table, nrow = 1, widths = c(4,1))
Let's suppose we have the following plot, which is simplified for brevity from the example code and has a vertical legend.
library(ggplot2)
library(gridExtra)
library(dplyr)
library(formattable)
library(signal)
# Omitted full code, same as in question
# full.data <- structure(...)
# summary.table <- structure(...)
# table <- tableGrob(...)
# Simplified plot
plot <- ggplot(full.data, aes(x = error, y = prob.ed.n, group = N, colour = as.factor(N))) +
geom_line(data = full.data %>%
group_by(N) %>%
do({
tibble(error = seq(min(.$error), max(.$error),length.out=100),
prob.ed.n = pchip(.$error, .$prob.ed.n, error))
}),
size = 1) +
guides(color = guide_legend(reverse=TRUE)) +
theme(legend.key = element_rect(fill = "white", colour = "black"))
plot
We can write the following function to place the legend keys into the table. It is a bit unwieldy because gtable and grid code is often not very elegant, but it should do the job. By default, it replaces the last column in the tableGrob output with the keys of the first legend.
Note that this only handles vertical legends, not horizontal ones. Also, it is a bit naive in assuming the table and legend fit together in their natural order: it doesn't do any fancy label matching and assumes the order in the table and legend are the same.
library(grid)
library(gtable)
#' #param tableGrob The output of the `gridExtra::tableGrob()` function.
#' #param plot A ggplot2 object with a single, vertical legend
#' #param replace_col An `integer(1)` with the column number in the
#' table to replace with keys. Defaults to the last one.
#' #param key_padding The amount of extra space to surround keys with,
#' as a `grid::unit()` object.
#'
#' #return A modified version of the `tableGrob` argument
add_legend_column <- function(
tableGrob,
plot,
replace_col = ncol(tableGrob),
key_padding = unit(5.5, "pt")
) {
# Getting legend keys
keys <- cowplot::get_legend(plot)
keys <- keys$grobs[[which(keys$layout$name == "guides")[1]]]
keys <- gtable_filter(keys, 'label|key')
idx <- unique(keys$layout$t)
keys <- lapply(idx, function(i) {
x <- keys[i, ]
# Set justification of keys
x$vp$x <- unit(0.5, "npc")
x$vp$justification <- x$vp$valid.just <- c(0.5, 1)
# Set key padding
x <- gtable_add_padding(x, key_padding)
x
})
if (nrow(table) != length(keys) + 1) {
stop("Keys don't fit in the table")
}
# Measure keys
width <- max(do.call(unit.c, lapply(keys, grobWidth)))
width <- max(width, table$widths[replace_col])
height <- do.call(unit.c, lapply(keys, grobHeight))
# Delete foreground content of the column to replace
drop <- table$layout$l == replace_col & table$layout$t != 1
drop <- drop & endsWith(table$layout$name, "-fg")
table$grobs <- table$grobs[!drop]
table$layout <- table$layout[!drop, ]
# Add keys to table
table <- gtable_add_grob(
table, keys, name = "key",
t = seq_along(keys) + 1,
l = replace_col
)
# Set dimensions
table$widths[replace_col] <- width
table$heights[-1] <- unit.pmax(table$heights[-1], height)
return(table)
}
Lastly, we can add the table in our favorite plot composition package as follows. Note that the text size of the legend and the table mismatched, so I've set the legend text size to match the one of the table. Naturally, the plot looks better after you delete the legend that we capture in the table.
library(patchwork)
#>
#> Attaching package: 'patchwork'
#> The following object is masked from 'package:formattable':
#>
#> area
(plot + theme(legend.position = "none")) +
add_legend_column(table, plot + theme(legend.text = element_text(size = 12)))
I have no idea how well this generalises when the plot has > 1 legend or when the tableGrob() has additional options turned on or off, it is the first time I've used this function.
I suggest defining the plot and table seperately and then stitching them together. To get colors for the table, you could extract the scale_color_brewer values from the ggplot object and dynamically define your table theme. To stitch, use your favorite multiplot graphics tool, like gridExtra::grid.arrange().
The difference between this answer and the above answer (https://stackoverflow.com/a/70581378/7941188) is I'm extracting the scale colors directly from the ggplot object to define the colors in the accompanying table. This makes sure the colors are matched up, and theoretically you could use this approach with multiple scales/legends.
Do you want the typical ggplot legend keys? Or is coloring the background of a cell sufficient? EDIT: I updated my answer to show how you could use unicode symbols to approximate ggplot legend keys.
library(ggplot2)
library(gridExtra)
library(signal)
ldata <- full.data %>%
group_by(N) %>%
do({
tibble(error = seq(min(.$error), max(.$error),length.out=100),
prob.ed.n = pchip(.$error, .$prob.ed.n, error))
})
#plot
p <- ggplot(full.data, aes(x = error, y = prob.ed.n, group = N, colour = as.factor(N))) +
geom_vline(xintercept = 2.45, colour = "red", linetype = "dashed") +
geom_hline(yintercept = 0.9, linetype = "dashed") +
geom_line(data = ldata, size = 1) +
scale_x_continuous(labels = full.data$error, breaks = full.data$error, expand = c(0, 0.05)) +
scale_y_continuous(expand = expansion(add = c(0.01, 0.01))) +
scale_color_brewer(palette = "Dark2") +
theme_bw() +
theme(legend.position = "none")
# Get scale data from ggplot object
pb <- ggplot_build(p)
scale_cols <- unique(pb$data[[3]][,c("colour", "group")])
table2 <- merge(table, scale_cols, by.x = "N", by.y = "group", sort = FALSE)
table2$N2 <- "\u2015"
table2 <- table2[,c("N", "N2", "Prb FR", "Prb ED", "colour")]
# Define vectors of fills and colors for table
fills <- c(table2$colour, rep("grey90", nrow(table2)*4))
cols <- c(rep("black", nrow(table2)*1), table2$colour, rep("black", nrow(table2)*3))
bgcols <- c(rep("white", nrow(table2)*5))
tt <- ttheme_default(core=list(bg_params = list(fill=fills, col=bgcols), fg_params = list(col=cols)))
t <- tableGrob(table2, theme = tt, rows = NULL)
# Combine plot and table
grid.arrange(p, t[,c(1:4)], nrow = 1, ncol = 2, widths=c(2,0.5))
In my scatterplot, there is some empty space left and I haven't managed to reduce it manually or with the xlim() command nor with scale_x_discrete(limits=()). My code:
ggplot(data = doppelratings2_mit_ID,
aes(x = R1, y = R3)) +
geom_jitter(shape = 1, width = 0.1, height = 0.1) +
geom_smooth()+
xlab("Rater 1") +
ylab("Rater 3") +
ggtitle("Korrelation zwischen Rater 1 und 3", paste("n = 17 Texte ")) +
theme_bw(12)+
geom_abline(intercept = 0, slope = 1)+
scale_x_discrete(breaks = 1:5, labels = tick_names_5, limits = c(1:5))+
scale_y_discrete(breaks = 1:6, labels = tick_names_6, limits = c(1:6))
And the data:
> dput(doppelratings2_mit_ID_für_Stackoverflow)
structure(list(ID = c(6584209, 6598108, 6584103, 6552101, 6608303,
6656213, 9734115, 9554201, 9554108, 9604202, 6660108, 6520103,
6726215, 6574106, 9762121, 9688202, 9576108), R1 = c(2, 3, 2,
3, 3, 2, 3, 4, 4, 5, 4, 4, 2, 2, 3, 4, 4), R3 = c(2, 3, 3, 3,
2, 2, 3, 5, 5, 6, 4, 4, 2, 2, 3, 3, 4)), row.names = c(NA, -17L
), class = c("tbl_df", "tbl", "data.frame"))
Thanks for your help!
You can try
ggplot(data = d,
aes(x = R1, y = R3)) +
geom_jitter(shape = 1, width = 0.1, height = 0.1) +
geom_smooth()+
xlab("Rater 1") +
ylab("Rater 3") +
ggtitle("Korrelation zwischen Rater 1 und 3", paste("n = 17 Texte ")) +
theme_bw(12)+
geom_abline(intercept = 0, slope = 1) +
scale_x_continuous(breaks = min(d$R1):max(d$R1), labels = LETTERS[1:length(min(d$R1):max(d$R1))]) +
scale_y_continuous(breaks = min(d$R3):max(d$R3), labels = LETTERS[1:length(min(d$R3):max(d$R3))])
Then you can add + coord_cartesian(ylim=c(min(d$R3),6)) to change the limits and to recieve this plot.
I want to plot some hexagons with ggplot2 in different colors.
When I try it as the code below I get squashed hexagons
library(ggplot2)
coords <-
data.frame(x=c(1.11803398874989,0.559016994374948,-0.559016994374947,-1.11803398874989,-0.559016994374948,0.559016994374947,2.23606797749979,1.1180339887499,-1.11803398874989,-2.23606797749979,-1.1180339887499,1.11803398874989,1.73205080756888,1.22464679914735e-16),
y=c(0,0.968245836551854,0.968245836551854,1.36919674566051e-16,-0.968245836551854,-0.968245836551855,0,1.93649167310371,1.93649167310371,2.73839349132101e-16,-1.93649167310371,-1.93649167310371,1,2),
kind=c(rep("blue",12),"red","blue"))
ggplot (data = coords, aes (x = round(x,digits =13), y = round(y,digits=13), fill = kind , group = 1)) +
geom_hex (colour = "red", stat = StatIdentity) +
scale_x_continuous(expand = 0 : 1) +
scale_y_continuous(expand = c (0, 2)) +
coord_equal ()
however when I try to plot only the first 12 hexagons I don't have any problems
# fine result
ggplot (data = coords[1:12,], aes (x = round(x,digits =13), y = round(y,digits=13), fill = kind , group = 1)) +
geom_hex (colour = "red", stat = StatIdentity) +
scale_x_continuous(expand = 0 : 1) +
scale_y_continuous(expand = c (0, 2)) +
coord_equal ()
Also when I do not round the values I get an empty plot.
What could be the problem?
Thanks
I just wanted to draw 19 hexagons that do not overlap. For that purpose I was able to draw it as the following:
coords <-
data.frame(
x = c(2, 3, 4, 5, 6, 7, 8, 1, 2, 3, 4, 5, 6, 7, 8, 9, 3, 5, 7),
y = c(2, 1, 2, 1, 2, 1, 2, 3, 4, 3, 4, 3, 4, 3, 4, 3, 5, 5, 5),
kind=c(rep("blue",12),"red","blue","red","blue",rep("blue",3))
)
ggplot (data = coords, aes (x = x, y = y, fill = kind , group = 1)) +
geom_hex (colour = "red", stat = StatIdentity) +
scale_x_continuous(expand = c(0:1)) +
scale_y_continuous(expand = c(0,2))
It seems that it is better to avoid floats.
I have a vector
var = c(5, 3, 6, 0, 1, 1, 1, 0, 4, 2, 1, 3, 3, 6, 3, 15, 1, 0, 2, 3,
1, 0, 0, 3, 2, 3, 2, 2, 2, 4, 4, 0, 1, 0, 2, 2, 5, 3, 3, 1, 0,
1, 1, 6, 4, 3, 0, 7, 4, 2, 3, 3, 0, 1, 1, 3, 4, 5, 2, 1, 3, 10,
13, 3, 1, 4, 5, 3, 1, 1, 5, 4, 2, 1, 6, 1, 2, 3, 5, 8, 3, 1,
7, 4, 0, 1, 7, 1, 3, 4, 3, 5, 3, 2, 1, 1, 9, 2, 0, 4, 3, 5)
I am plotting the distribution of the histogram using ggplot and drawing a vertical line of the median. The median of var equals 3(doubled checked using python numpy)
groupMedian <- median(var)
print(groupMedian)
df <- data.table(x = var)
df <- df[, .N, by=x]
df$x <- factor(df$x, levels=c(0:25))
p <- ggplot(df, aes(x=x, y=N)) +
geom_bar(stat="identity", width=1.0,
colour = "darkgreen",
fill = 'lightslateblue')
p <- p + labs(title = "Var Histogram",
x = "x",
y = "Frequency") +
scale_x_discrete(drop=FALSE) +
geom_vline(xintercept=groupMedian,
colour = 'red', size = 2)
p = p + coord_cartesian(ylim=c(0, 50)) +
scale_y_continuous(breaks=seq(0, 50, 2))
p = p + theme(panel.grid.major =
element_line(colour = "black", linetype = "dotted") )
ggsave("barplot.png", p, width=8, height=4, dpi=120)
print(p)
The median is 3 but the line is placed at 2.
I also tried using
p = p+ geom_vline(data=var,
aes(xintercept = median),
colour = 'red', size = 2 )
You can let ggplot2 do the aggregation for you and just you geom_histogram() instead. This seems to provide the gist of what you're after:
#load data.table
library(data.table)
df <- data.table(x = var)
groupMedian <- median(var)
ggplot(df, aes(x)) +
geom_histogram(binwidth = 1,
colour = "darkgreen",
fill = "lightslateblue",
origin = -0.5) + #this effectively centers the x-axis under the bins
geom_vline(xintercept = groupMedian,
colour = "red",
size = 2) +
scale_x_continuous(breaks = seq(0,25),
limits = c(0,25))
Giving you something like this: