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))
Could you please help me how to generate the 3D plot something as below?
dat <- tibble::tribble(
~subject, ~response, ~duration,
'1', 10, 20,
'2', -7, 30,
'3', 5, 20,
'4', 7, 50,
'5', -5, 40
)
Here's something a little closer to the original using plot3D
First draw the box, axes, title and plane:
library(plot3D)
persp3D(c(min(as.numeric(dat$subject)) - 1, max(as.numeric(dat$subject)) + 1),
c(0, max(dat$duration)),d = 50, phi = 30, theta = 55, xlab = "subject",
ylab = "Duration", zlab = "Response", ticktype = "detailed",
matrix(rep(range(dat$response), 2), 2, 2), lwd = 3,
col.panel = "gray95", colkey = FALSE, bty = "u")
title("Tumor response and duration", cex.main = 2)
rect3D(min(as.numeric(dat$subject)) - 1, 0, min(dat$response),
max(as.numeric(dat$subject)) + 1,
max(dat$duration), NULL,
col = "#e7e7e7", add = TRUE)
rect3D(min(as.numeric(dat$subject)) - 1, 0, min(dat$response),
NULL,
max(dat$duration),
max(dat$response),
col = "#e0e0e0", add = TRUE)
rect3D(min(as.numeric(dat$subject)) - 1, max(dat$duration), min(dat$response),
max(as.numeric(dat$subject)) + 1, NULL,
max(dat$response),
col = "#f0f0f0", add = TRUE)
rect3D(min(as.numeric(dat$subject)) - 1, 0, 0,
max(as.numeric(dat$subject)) + 1,
max(dat$duration), NULL,
col = "#FFFFFF20", border = "gray50", add = TRUE)
Now the bars using rect3D
for(i in seq(nrow(dat))) {
rect3D(as.numeric(dat$subject[i]) - 0.2, 0, 0,
as.numeric(dat$subject[i]) + 0.2, dat$duration[i], NULL,
col = "#7c95ca", add = TRUE)
}
for(i in seq(nrow(dat))) {
rect3D(as.numeric(dat$subject[i]) - 0.2, 0, 0,
as.numeric(dat$subject[i]) + 0.2, NULL,
dat$response[i],
col = "#de7e6f", add = TRUE)
}
Finally, add the box outlines:
lines3D(c(min(as.numeric(dat$subject)) - 1, max(as.numeric(dat$subject)) + 1),
c(0, 0), rep(max(dat$response), 2), lty = 2, add = TRUE, col = "black")
lines3D(rep(max(as.numeric(dat$subject)) + 1, 2),
c(0, max(dat$duration)), rep(max(dat$response), 2),
lty = 2, add = TRUE, col = "black")
lines3D(rep(max(as.numeric(dat$subject)) + 1, 2),
c(0, 0), range(dat$response),
lty = 2, add = TRUE, col = "black")
lines3D(c(rep(min(as.numeric(dat$subject)) - 1, 3),
rep(max(as.numeric(dat$subject)) + 1, 3),
min(as.numeric(dat$subject)) - 1),
c(0, 0, rep(max(dat$duration), 3), 0, 0),
c(min(dat$response), rep(max(dat$response), 3),
rep(min(dat$response),3)),add = TRUE, col = "black", lwd = 5)
However, as others have pointed out in the comments, although such a plot is superficially impressive, it is actually less useful than displaying the data in a more familiar, elegant 2-D plot. Such a plot is also far easier to create, and contains all the same information in a more readable format
library(ggplot2)
ggplot(dat, aes(response, duration)) +
geom_point(size = 6, aes(color = "(subject id)"), alpha = 0.5) +
geom_text(aes(label = subject), nudge_x = 0.5, nudge_y = 1) +
geom_hline(yintercept = 0) +
geom_vline(xintercept = 0) +
ggtitle("Tumor response versus duration") +
scale_color_manual(NULL, values = "navy") +
theme_minimal(base_size = 20) +
theme(plot.margin = margin(20, 20, 50, 20),
plot.title = element_text(size = 32, color = "gray20",
margin = margin(10, 10, 50, 10)))
I think you'll have to write that yourself. Here are a couple of half-hearted attempts; you'll need to clean them up a lot.
library(scatterplot3d)
dat <- tibble::tribble(
~subject, ~response, ~duration,
'1', 10, 20,
'2', -7, 30,
'3', 5, 20,
'4', 7, 50,
'5', -5, 40
)
rectx <- c(-0.4, 0.4, 0.4, -0.4, -0.4, NA)
recty <- c(0, 0, 1, 1, 0, NA)
rectangles <- data.frame(x = numeric(), y = numeric(), z = numeric() )
for (i in seq_len(nrow(dat))) {
subj <- as.numeric(dat$subject[i])
rectangles <- rbind(rectangles,
data.frame(x = rectx + subj,
y = 0,
z = recty*dat$response[i]),
data.frame(x = rectx + subj,
y = recty*dat$duration[i],
z = 0))
}
with(dat, scatterplot3d(x = rectangles,
type= "l",
xlab = "Subject",
ylab = "Duration",
zlab = "Response"))
i <- seq_len(nrow(rectangles))
drop <- which(is.na(rectangles[i, 1]) )
drop <- c(drop, drop-1)
rectangles <- rectangles[!(i %in% drop),]
library(rgl)
open3d()
#> glX
#> 1
quads3d(rectangles, col = c(rep("red",4), rep("blue", 4)))
aspect3d(1,1,1)
decorate3d(xlab = "Subject",
ylab = "Duration",
zlab = "Response")
Created on 2023-01-07 with reprex v2.0.2
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 have my data
varechem <-
structure(
list(
`POX-C` = c(
869.153225806452,
841.409274193548,
720.344758064516,
828.798387096774,
904.46370967742,
773.310483870968,
793.487903225806,
874.197580645161,
900.932661290323,
778.354838709677
),
`B-glucosidase` = c(
1.90612612612613,
1.60509009009009,
1.42864864864865,
1.82355855855856,
1.76761261261261,
1.34855855855856,
1.37504504504504,
1.5863963963964,
1.1290990990991,
1.4686036036036
),
Protein = c(
6284.21052631579,
6250.52631578947,
6103.15789473684,
6280,
6275.78947368421,
4368.42105263158,
1240,
6191.57894736842,
5745.26315789474,
6970.52631578947
)
),
row.names = c(
"M.T1.R1.S1.16S.S50",
"M.T1.R1.S2.16S.S62",
"M.T1.R1.S3.16S.S74",
"M.T1.R2.S1.16S.S86",
"M.T1.R2.S2.16S.S3",
"M.T1.R2.S3.16S.S15",
"M.T1.R3.S1.16S.S27",
"M.T1.R3.S2.16S.S39",
"M.T1.R3.S3.16S.S51",
"M.T1.R4.S1.16S.S63"
),
class = "data.frame"
)
varespec <-
structure(
list(
A = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1),
B = c(1,
1, 1, 1, 1, 1, 1, 1, 1, 1),
C = c(1, 1, 1, 2, 1, 1, 1, 1, 1,
3),
D = c(2, 1, 1, 1, 1, 1, 1, 1, 1, 1),
E = c(1, 1, 1, 1, 1,
3, 1, 1, 1, 1),
F = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1),
G = c(1,
1, 11, 20, 15, 13, 23, 9, 1, 16),
H = c(2, 1, 1, 4, 1, 1, 1,
1, 1, 1),
I = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1),
J = c(9, 3, 20,
21, 16, 19, 22, 13, 12, 26)
),
row.names = c(
"M.T1.R1.S1.16S.S50",
"M.T1.R1.S2.16S.S62",
"M.T1.R1.S3.16S.S74",
"M.T1.R2.S1.16S.S86",
"M.T1.R2.S2.16S.S3",
"M.T1.R2.S3.16S.S15",
"M.T1.R3.S1.16S.S27",
"M.T1.R3.S2.16S.S39",
"M.T1.R3.S3.16S.S51",
"M.T1.R4.S1.16S.S63"
),
class = "data.frame"
)
I have my codes:
library(vegan); library(ggplot2)
sol <- cca(varespec, varechem)
scrs <- scores(sol, display = c("sp", "wa", "lc", "bp", "cn"))
df_sites <- data.frame(scrs$sites)
df_sites$Sites <- gsub("\\..*", "", rownames(varechem))
df_sites$Sites <- factor(df_sites$Sites)
# rownames(df_sites) <- gsub("[*].*$", "",rownames(df_sites))
colnames(df_sites) <- c("x", "y", "Sites")
#Draw sites
p <- ggplot()
p <-
p + geom_point(
data = df_sites,
aes(x, y, colour = Sites),
shape = "diamond",
size = 2
)
p <- p + scale_colour_manual(values = c("blue"), guide = FALSE)
p
#Draw biplots
multiplier <- vegan:::ordiArrowMul(scrs$biplot)
df_arrows <- scrs$biplot * multiplier
colnames(df_arrows) <- c("x", "y")
df_arrows = as.data.frame(df_arrows)
#adding arrows for chemicals (environment variables)
pa <-
p + geom_segment(
data = df_arrows,
aes(
x = 0,
y = 0,
xend = x,
yend = y
),
arrow = arrow(length = unit(0.3, "cm")),
arrow.fill = "black"
)
pa
###adjust the position of the labels or shapes
df_arrows <- as.data.frame(df_arrows * 1.1)
df_arrows$Chemicals <- factor(rownames(df_arrows))
cp <-
pa + geom_point(data = df_arrows,
aes(x, y, group = Chemicals, shape = Chemicals),
size = 4) + scale_shape_manual(values = 1:nlevels(df_arrows$Chemicals))
#### # Draw species
df_species <- as.data.frame(scrs$species)
colnames(df_species) <- c("x", "y")
significant_taxa <- c("A", "D")
df_species$significant <-
ifelse(rownames(df_species) %in% significant_taxa, "Sig", "Not-sig")
df_species$significant <- as.character(df_species$significant)
get.colour <- c("red", "orange")
# scp <- cp + geom_point(data = df_species, aes(x, y), size = 0.5)
#relevel factor so "Sig" will appear first in the legend
df_species$significant <-
factor(df_species$significant, levels = c("Sig", "Not-sig"))
df_species$coloured <- "black"
df_species$coloured [match(significant_taxa, rownames(df_species))] <-
get.colour
df_species$coloured <- as.factor(df_species$coloured)
This is where I need help. I need to put two colours for siginficant values
(Sig only) from df_species$coloured and get their labels from the dataframe
rownames(df_species) which is A and D in their respective font colours. So I
would like to put two colours and text associated with that A and D. How
can I do this?
scp <- cp + geom_point(data = df_species, aes(x, y, group = significant, size = significant)) +
scale_size_manual(values = c(4.5, 0.2))
scp
I think I have a solution. I added an extra column to df_species to create the labels in the plot.
df_species <- df_species %>%
mutate(labels = rownames(df_species))
The plot: (This part is updated based on the comment of the OP.)
scp <- ggplot() +
geom_point(data = df_species,
aes(x = x,
y = y,
colour = coloured,
size = significant)) +
geom_text(data = subset(df_species, significant == "Sig"),
aes(x = x,
y = y,
label = labels,
colour = coloured),
hjust = 1,
vjust = -1,
show.legend = FALSE) +
scale_colour_manual(values = c("black" = "black", "red" = "red", "orange" = "orange")) +
scale_size_manual(values = c(4.5, 0.2)) +
geom_point(data = df_sites,
aes(x = x,
y = y,
fill = Sites),
size = 2,
pch = 23) + # with this shape you can use fill
scale_fill_manual(values = c("M" = "blue")) +
geom_point(data = df_arrows,
aes(x = x,
y = y,
group = Chemicals,
shape = Chemicals),
size = 4) +
scale_shape_manual(values = 1:nlevels(df_arrows$Chemicals)) +
geom_segment(data = df_arrows,
aes(x = 0,
y = 0,
xend = x,
yend = y),
arrow = arrow(length = unit(0.3, "cm")),
arrow.fill = "black")
scp
It took a bit of playing around, but I hope this is what you where looking for. :-) I added everything together. For me this was a bit easier to get the overview. The position / order of the scale_* functions is important.
Continuing on from my previous bspline question
If this is my curve:
data <- tibble (
x = c(10, 15, 17, 17, 20, 22, 22, 23, 25, 25, 27, 29),
y = c(5, 7, 4, 4, 0, 5, 5, 6, 5, 5, 4, 5.5),
g = c("A", "A", "A", "B", "B", "B", "C", "C", "C", "D","D","D"),
pt = c(0, 0, 1, 0, 0, 1, 0, 0, 1, 0, 0, 1)
)
ggplot(data) +
stat_bspline2(aes(x=x, y=y, color = ..group.., group = g), size = 4, n = 300, geom = "bspline0") +
scale_color_gradientn(colours = c("red", "pink", "green", "white"), guide = F)
How do I add dots to selected points on the curve?
Here's how not to do it:
ggplot(data) +
stat_bspline2(aes(x=x, y=y, color = ..group.., group = g), size = 4, n = 300, geom = "bspline0") +
scale_color_gradientn(colours = c("red", "pink", "green", "white"), guide = F) +
stat_bspline2(data = pt, aes(x = x, y = x, color = ..group.., group = pt), n = 12, geom = "point", size = 9)
)
It isn't perfect, but it works. Add some columns with the positions of the points you want (I'm assuming that if pt = 1, you want the point plotted)
data <- data %>%
mutate(pt_x = ifelse(pt == 1, x, NA),
pt_y = ifelse(pt == 1, y, NA))
ggplot(data) +
stat_bspline2(aes(x=x, y=y, color = ..group.., group = g), size = 4, n = 300, geom = "bspline0") +
scale_color_gradientn(colours = c("red", "pink", "green", "white"), guide = F) +
geom_point(aes(pt_x, pt_y))