I am trying to automatically position multiple model evaluation parameters in facetted ggplot. This answer has helped me to put the R2 and RMSE in facetted ggplot automatically using the following code
library(caret)
library(tidyverse)
summ <- iris %>%
group_by(Species) %>%
summarise(Rsq = R2(Sepal.Length, Petal.Length),
RMSE = RMSE(Sepal.Length, Petal.Length)) %>%
mutate_if(is.numeric, round, digits=2)
p <- ggplot(data=iris, aes(x = Sepal.Length, y = Petal.Length)) +
geom_point(color="blue",alpha = 1/3) +
facet_wrap(Species ~ ., scales="free") +
geom_smooth(method=lm, fill="black", formula = y ~ x) +
xlab("Sepal Length") +
ylab("Petal Length") + theme_bw() +
theme(panel.grid.major = element_blank(), panel.grid.minor = element_blank())
# Here we create our annotations data frame.
df.annotations <- data.frame()
# Rsq
df.annotations <- rbind(df.annotations,
cbind(as.character(summ$Species),
paste("Rsq", summ$Rsq,
sep = " = ")))
# RMSE
df.annotations <- rbind(df.annotations,
cbind(as.character(summ$Species),
paste("RMSE", summ$RMSE,
sep = " = ")))
# This here is important, especially naming the first column
# Species
colnames(df.annotations) <- c("Species", "label")
vertical_adjustment = ifelse(grepl("Rsq",df.annotations$label),1.5,3)
p + geom_text(data=df.annotations,aes(x=-Inf,y=+Inf,label=label),
hjust = -0.1, vjust = vertical_adjustment, size=3.5)
I have calculated NSE using hydroGOF package like
library(hydroGOF)
summ <- iris %>%
group_by(Species) %>%
summarise(Rsq = R2(Sepal.Length, Petal.Length),
RMSE = RMSE(Sepal.Length, Petal.Length),
NSE = NSE(Sepal.Length, Petal.Length)) %>%
mutate_if(is.numeric, round, digits=2)
Added the NSE to the df.annotations dataframe like
# NSE
df.annotations <- rbind(df.annotations,
cbind(as.character(summ$Species),
paste("NSE", summ$NSE,
sep = " = ")))
Now, how can I place multiple model evaluation parameters in facetted ggplot2?
This is the new part using case_when from dplyr package for aligning vertically:
library(dplyr)
vertical_adjustment = case_when(grepl("Rsq",df.annotations$label) ~ 1.5,
grepl("RMSE",df.annotations$label) ~ 3,
grepl("NSE",df.annotations$label) ~ 4.5)
p + geom_text(data=df.annotations,aes(x=-Inf,y=+Inf,label=label),
hjust = -0.1, vjust = vertical_adjustment, size=3.5)
The whole code:
library(caret)
library(tidyverse)
library(hydroGOF)
summ <- iris %>%
group_by(Species) %>%
summarise(Rsq = R2(Sepal.Length, Petal.Length),
RMSE = RMSE(Sepal.Length, Petal.Length),
NSE = NSE(Sepal.Length, Petal.Length)) %>%
mutate_if(is.numeric, round, digits=2)
p <- ggplot(data=iris, aes(x = Sepal.Length, y = Petal.Length)) +
geom_point(color="blue",alpha = 1/3) +
facet_wrap(Species ~ ., scales="free") +
geom_smooth(method=lm, fill="black", formula = y ~ x) +
xlab("Sepal Length") +
ylab("Petal Length") + theme_bw() +
theme(panel.grid.major = element_blank(), panel.grid.minor = element_blank())
p
# Here we create our annotations data frame.
df.annotations <- data.frame()
# Rsq
df.annotations <- rbind(df.annotations,
cbind(as.character(summ$Species),
paste("Rsq", summ$Rsq,
sep = " = ")))
# RMSE
df.annotations <- rbind(df.annotations,
cbind(as.character(summ$Species),
paste("RMSE", summ$RMSE,
sep = " = ")))
df.annotations <- rbind(df.annotations,
cbind(as.character(summ$Species),
paste("NSE", summ$NSE,
sep = " = ")))
# This here is important, especially naming the first column
# Species
colnames(df.annotations) <- c("Species", "label")
library(dplyr)
vertical_adjustment = case_when(grepl("Rsq",df.annotations$label) ~ 1.5,
grepl("RMSE",df.annotations$label) ~ 3,
grepl("NSE",df.annotations$label) ~ 4.5)
p + geom_text(data=df.annotations,aes(x=-Inf,y=+Inf,label=label),
hjust = -0.1, vjust = vertical_adjustment, size=3.5)
Related
I am trying create a panel chart in ggplot with four variables which all have their own scale for the y axis. I can get the structure of the panel chart to work but am having trouble actually getting each data set onto the gird. I have been following a script I found online. See below however I am getting the following error when I try and use the subset function further down in the script.
Error in .(variable == "Count") : could not find function "."
#load data
#Data source: data analysis-gullies > R Stats Input > Panel Chart
df <- read.csv(file.choose(), header = T)
View(df)
#load library
library(ggplot2)
library(reshape2)
dfm <- melt(df, id.vars =c("Interval"))
View(dfm)
test <- ggplot(dfm, aes(Interval, value, ymin = 0,
ymax = value, colour = "grey20"))+ scale_colour_identity() +
xlim(5,1115)+ facet_grid(variable ~ ., scales = "free", as.table = FALSE)+
theme_bw() + theme(panel.spacing = unit(0, "lines"), axis.title.x = element_blank(),
axis.title.y = element_text())
test
test1 <- test + geom_col(subset = .(variable == "Count"))
test2 <- test1 + geom_col(subset = .(variable == "Length"))
test3 <- test2 + geom_col(subset = .(variable == "Area"))
test4 <- test3 + geom_col(subset = .(variable == "Volume"))
You can use the patchwork package to merge individual ggplot2 objects to get individual axes for each panel:
library(tidyverse)
library(patchwork)
iris %>%
nest(-Species) %>%
mutate(
plt = data %>% map2(Species, ~ {
.x %>%
ggplot(aes(Sepal.Width, Sepal.Length)) +
geom_point() +
labs(title = .y)
})
) %>%
pull(plt) %>%
wrap_plots()
You can also add logic to plot different plots per panel:
library(tidyverse)
library(patchwork)
iris %>%
nest(-Species) %>%
mutate(
plt = data %>% map2(Species, ~ {
if(.y == "setosa") {
.x %>%
ggplot(aes(Sepal.Width, Sepal.Length)) +
geom_point() +
labs(title = .y)
} else {
.x %>%
ggplot(aes(Sepal.Width, Sepal.Length)) +
geom_line() +
labs(title = .y)
}
})
) %>%
pull(plt) %>%
wrap_plots()
If the panel plots are very different from each other (e.g. different variables for the x and y axes), it is recommended to create each plot individually and then call wrap_plots of all the plot objects:
plt1 <- qplot(Sepal.Length, Sepal.Width, data = iris, geom = "point")
plt2 <- qplot(Petal.Length, Petal.Width, data = iris, geom = "line")
wrap_plots(plt1, plt2, nrow = 1)
I am trying to use superscript in geom_text. But I am unable to do that. I am using the following code
library(caret)
library(tidyverse)
summ <- iris %>%
group_by(Species) %>%
summarise(R = cor(Sepal.Length, Petal.Length, use="pairwise.complete.obs"),
RMSE = RMSE(Sepal.Length, Petal.Length)) %>%
mutate_if(is.numeric, round, digits=2)
p <- ggplot(data=iris, aes(x = Sepal.Length, y = Petal.Length)) +
geom_point(color="blue",alpha = 1/3) +
facet_wrap(Species ~ ., scales="free") +
geom_smooth(method=lm, fill="black", formula = y ~ x) +
xlab("Sepal Length") +
ylab("Petal Length") + theme_bw() +
theme(panel.grid.major = element_blank(), panel.grid.minor = element_blank())
# Here we create our annotations data frame.
df.annotations <- data.frame()
# R
df.annotations <- rbind(df.annotations,
cbind(as.character(summ$Species),
paste("R", summ$R,
sep = " = ")))
# RMSE
df.annotations <- rbind(df.annotations,
cbind(as.character(summ$Species),
paste("RMSE", summ$RMSE,
sep = " = ")))
# This here is important, especially naming the first column
# Species
colnames(df.annotations) <- c("Species", "label")
vertical_adjustment = ifelse(grepl("\\bR\\b",df.annotations$label), 1.5, 3)
p + geom_text(data = df.annotations, aes(x=-Inf, y=+Inf, label=label),
hjust = -0.1, vjust = vertical_adjustment, size=3.5)
My expected output is
How can I add the unit for RMSE after the value and superscript 2 after R i.e. R^2? You can also see that there is a slight shift in the alignment of RMSE with respect to R. How can I make them into the same line?
This could be achieved like so:
Set parse=TRUE in geom_text
Make use of ?plotmath to add superscripts to your labels
# Here we create our annotations data frame.
df.annotations <- data.frame(
Species = rep(summ$Species, 2),
label = c(
paste0("~R^{2} == ", summ$R),
paste0("~RMSE == ", summ$RMSE, "~m^{3} ~m^{-3}")
)
)
vertical_adjustment = ifelse(grepl("\\bR\\b", df.annotations$label), 1.5, 3)
p + geom_text(data = df.annotations, aes(x=-Inf, y=+Inf, label=label),
hjust = 0, vjust = vertical_adjustment, size=3.5, parse = TRUE)
Another approach is to use the ggtext package, which enables markdown formatting in ggplot text objects. I find this syntax much easier to use than R's plotmath, especially for things like italics and color:
df.annotations <- data.frame(
Species = rep(summ$Species, 2),
label = c(
paste0("R<sup>2</sup> = ", summ$R),
paste0("RMSE = ", summ$RMSE, "m<sup>3</sup> m<sup>-3</sup>")
)
)
vertical_adjustment = ifelse(grepl("\\bR\\b", df.annotations$label), 1.5, 2.5)
p + geom_richtext(data = df.annotations, aes(x=-Inf, y=+Inf, label=label),
hjust = 0, vjust = vertical_adjustment, size=3.5, label.size = 0)
What I want: to create a function to insert a line break between every letter of a character variable in R.
What I tried: but it didn't work
wrap_letters <- function(x){
z <- substring(x, 1, 1) # Take the first letter of x and save it in z
for(i in 2:stri_length(x)) { #from the second to the length of x
w <- substring(x, i, 1) #take the respective letter and save it to w
z <- paste0(z,"\n", w) #paste z, "\n", w
}
z #return z
}
Reproducible example with data (using ToothGrowth that comes within R):
df <- ToothGrowth %>%
mutate(dose = factor(dose),
supp = case_when(
supp=="OJ" ~ "orange juice",
T ~ "ascorbic acid"),
supp_label = wrap_letters(supp))
Aplication: to vertically write labels in a facet_grid plot: I want to rotate letters to normal position (i.e. horizontal), but to place letters below each other, so they don't take too much width:
bp <- ggplot(df, aes(x=dose, y=len, group=dose)) +
geom_boxplot(aes(fill=dose)) +
theme(
strip.text.y = element_text(angle = 0)
) +
facet_grid(supp_label ~ dose)
bp
Desired result:
df <- ToothGrowth %>%
mutate(dose = factor(dose),
supp_label = case_when(
supp=="OJ" ~ "o\nr\na\nn\ng\ne\n \nj\nu\ni\nc\ne",
T ~ "a\ns\nc\no\nr\nb\ni\nc\n \na\nc\ni\nd"))
bp <- ggplot(df, aes(x=dose, y=len, group=dose)) +
geom_boxplot(aes(fill=dose)) +
scale_y_continuous(position = "right") +
facet_grid(supp_label ~ dose, switch = "y") +
theme(
strip.text.y.left = element_text(angle = 0, size = 12, face = "bold"),
strip.text.x = element_text(angle = 0, size = 12, face = "bold")
)
bp
Note: This is a small reproducible example, I have more categories in my dataframe and I want to make everything reproducible, that is why I need a function.
wrap_letters can be written as :
wrap_letters <- function(x) {
sapply(strsplit(x, ''), paste0, collapse = '\n')
}
You can pass a vector to it and plot.
library(dplyr)
library(ggplot2)
ToothGrowth %>%
mutate(dose = factor(dose),
supp = case_when(supp=="OJ" ~ "orange juice",
TRUE ~ "ascorbic acid"),
supp_label = wrap_letters(supp)) %>%
ggplot(aes(x=dose, y=len, group=dose)) +
geom_boxplot(aes(fill=dose)) +
theme(strip.text.y = element_text(angle = 0)) +
facet_grid(supp_label ~ dose)
We could use a regex method to do this
library(dplyr)
library(stringr)
library(ggplot2)
wrap_letters <- function(x) {
stringr::str_replace_all(x, "(?<=.)(?=.)", "\n")
# or use gsub from base R
# gsub("(?<=.)(?=.)", "\n", x)
}
Now, use the function
ToothGrowth %>%
mutate(dose = factor(dose),
supp = case_when(supp=="OJ" ~ "orange juice",
TRUE ~ "ascorbic acid"),
supp_label = wrap_letters(supp)) %>%
ggplot(aes(x=dose, y=len, group=dose)) +
geom_boxplot(aes(fill=dose)) +
theme(strip.text.y = element_text(angle = 0)) +
facet_grid(supp_label ~ dose)
-output
I would like to label my plot, possibly using the equation method from ggpmisc to give an informative label that links to the colour and equation (then I can remove the legend altogether). For example, in the plot below, I would ideally have the factor levels of 4, 6 and 8 in the equation LHS.
library(tidyverse)
library(ggpmisc)
df_mtcars <- mtcars %>% mutate(factor_cyl = as.factor(cyl))
p <- ggplot(df_mtcars, aes(x = wt, y = mpg, group = factor_cyl, colour= factor_cyl))+
geom_smooth(method="lm")+
geom_point()+
stat_poly_eq(formula = my_formula,
label.x = "centre",
#eq.with.lhs = paste0(expression(y), "~`=`~"),
eq.with.lhs = paste0("Group~factor~level~here", "~Cylinders:", "~italic(hat(y))~`=`~"),
aes(label = paste(..eq.label.., sep = "~~~")),
parse = TRUE)
p
There is a workaround by modifying the plot afterwards using the technique described here, but surely there is something simpler?
p <- ggplot(df_mtcars, aes(x = wt, y = mpg, group = factor_cyl, colour= factor_cyl))+
geom_smooth(method="lm")+
geom_point()+
stat_poly_eq(formula = my_formula,
label.x = "centre",
eq.with.lhs = paste0(expression(y), "~`=`~"),
#eq.with.lhs = paste0("Group~factor~level~here", "~Cylinders:", "~italic(hat(y))~`=`~"),
aes(label = paste(..eq.label.., sep = "~~~")),
parse = TRUE)
p
# Modification of equation LHS technique from:
# https://stackoverflow.com/questions/56376072/convert-gtable-into-ggplot-in-r-ggplot2
temp <- ggplot_build(p)
temp$data[[3]]$label <- temp$data[[3]]$label %>%
fct_relabel(~ str_replace(.x, "y", paste0(c("8","6","4"),"~cylinder:", "~~italic(hat(y))" )))
class(temp)
#convert back to ggplot object
#https://stackoverflow.com/questions/56376072/convert-gtable-into-ggplot-in-r-ggplot2
#install.packages("ggplotify")
library("ggplotify")
q <- as.ggplot(ggplot_gtable(temp))
class(q)
q
This first example puts the label to the right of the equation, and is partly manual. On the other hand it is very simple to code. Why this works is because group is always present in the data as seen by layer functions (statistics and geoms).
library(tidyverse)
library(ggpmisc)
df_mtcars <- mtcars %>% mutate(factor_cyl = as.factor(cyl))
my_formula <- y ~ x
p <- ggplot(df_mtcars, aes(x = wt, y = mpg, group = factor_cyl, colour = factor_cyl)) +
geom_smooth(method="lm")+
geom_point()+
stat_poly_eq(formula = my_formula,
label.x = "centre",
eq.with.lhs = "italic(hat(y))~`=`~",
aes(label = paste(stat(eq.label), "*\", \"*",
c("4", "6", "8")[stat(group)],
"~cylinders.", sep = "")),
label.x.npc = "right",
parse = TRUE) +
scale_colour_discrete(guide = FALSE)
p
In fact with a little bit of additional juggling one can achieve almost an answer to the question. We need to add the lhs by pasting it explicitly in aes() so that we can add also paste text to its left based on a computed variable.
library(tidyverse)
library(ggpmisc)
df_mtcars <- mtcars %>% mutate(factor_cyl = as.factor(cyl))
my_formula <- y ~ x
p <- ggplot(df_mtcars, aes(x = wt, y = mpg, group = factor_cyl, colour = factor_cyl)) +
geom_smooth(method="lm")+
geom_point()+
stat_poly_eq(formula = my_formula,
label.x = "centre",
eq.with.lhs = "",
aes(label = paste("bold(\"", c("4", "6", "8")[stat(group)],
" cylinders: \")*",
"italic(hat(y))~`=`~",
stat(eq.label),
sep = "")),
label.x.npc = "right",
parse = TRUE) +
scale_colour_discrete(guide = FALSE)
p
What about a manual solution where you can add your equation as geom_text ?
Pros: Highly customization / Cons: Need to be manually edited based on your equation
Here, using your example and the linear regression:
library(tidyverse)
df_label <- df_mtcars %>% group_by(factor_cyl) %>%
summarise(Inter = lm(mpg~wt)$coefficients[1],
Coeff = lm(mpg~wt)$coefficients[2]) %>% ungroup() %>%
mutate(ypos = max(df_mtcars$mpg)*(1-0.05*row_number())) %>%
mutate(Label2 = paste(factor_cyl,"~Cylinders:~", "italic(y)==",round(Inter,2),ifelse(Coeff <0,"-","+"),round(abs(Coeff),2),"~italic(x)",sep =""))
# A tibble: 3 x 5
factor_cyl Inter Coeff ypos Label2
<fct> <dbl> <dbl> <dbl> <chr>
1 4 39.6 -5.65 32.2 4~Cylinders:~italic(y)==39.57-5.65~italic(x)
2 6 28.4 -2.78 30.5 6~Cylinders:~italic(y)==28.41-2.78~italic(x)
3 8 23.9 -2.19 28.8 8~Cylinders:~italic(y)==23.87-2.19~italic(x)
Now, you can pass it in ggplot2:
ggplot(df_mtcars,aes(x = wt, y = mpg, group = factor_cyl, colour= factor_cyl))+
geom_smooth(method="lm")+
geom_point()+
geom_text(data = df_label,
aes(x = 2.5, y = ypos,
label = Label2, color = factor_cyl),
hjust = 0, show.legend = FALSE, parse = TRUE)
An alternative to labelling with the equation is to label with the fitted line. Here is an approach adapted from an answer on a related question here
#example of loess for multiple models
#https://stackoverflow.com/a/55127487/4927395
library(tidyverse)
library(ggpmisc)
df_mtcars <- mtcars %>% mutate(cyl = as.factor(cyl))
models <- df_mtcars %>%
tidyr::nest(-cyl) %>%
dplyr::mutate(
# Perform loess calculation on each CpG group
m = purrr::map(data, lm,
formula = mpg ~ wt),
# Retrieve the fitted values from each model
fitted = purrr::map(m, `[[`, "fitted.values")
)
# Apply fitted y's as a new column
results <- models %>%
dplyr::select(-m) %>%
tidyr::unnest()
#find final x values for each group
my_last_points <- results %>% group_by(cyl) %>% summarise(wt = max(wt, na.rm=TRUE))
#Join dataframe of predictions to group labels
my_last_points$pred_y <- left_join(my_last_points, results)
# Plot with loess line for each group
ggplot(results, aes(x = wt, y = mpg, group = cyl, colour = cyl)) +
geom_point(size=1) +
geom_smooth(method="lm",se=FALSE)+
geom_text(data = my_last_points, aes(x=wt+0.4, y=pred_y$fitted, label = paste0(cyl," Cylinders")))+
theme(legend.position = "none")+
stat_poly_eq(formula = "y~x",
label.x = "centre",
eq.with.lhs = paste0(expression(y), "~`=`~"),
aes(label = paste(..eq.label.., sep = "~~~")),
parse = TRUE)
So I would like to use multiple polynomial curves to fit 2 dimensional data,
I am able to plot one polynomial function but I would like to use for example 4 and then plot all of them at the same time using facet_wrap.
Now I am using simple 2 order polynomial:
library(ggplot2)
df <- mtcars
df <- data.frame("x"=df$mpg, "y"=df$hp)
my.formula <- y ~ x + I(x^2)
p <- ggplot(df, aes(x, y)) +
geom_point(shape=21, fill="blue", colour="black", size=2, alpha = 0.7) +
geom_smooth(method = "lm", se = F,
formula = my.formula,
colour = "red")
m <- lm(my.formula, df)
my.eq <- as.character(signif(as.polynomial(coef(m)), 3))
label.text <- paste(gsub("x", "~italic(x)", my.eq, fixed = TRUE),
paste("italic(R)^2",
format(summary(m)$r.squared, digits = 2),
sep = "~`=`~"),
sep = "~~~~")
p + annotate(geom = "text", label = label.text,
family = "serif", hjust = 0, parse = TRUE, size = 4)
lets say we would like to use another formulas such as:
my.formula2 <- y ~ x + I(x^2) + I(x^3)
my.formula4 <- y ~ x + I(x^2) + I(x^3) + I(x^4)
my.formula5 <- y ~ x + I(x^2) + I(x^3) + I(x^4) + I(x^5)
And plot it in the base plot above using facet_wrap so we would have 4 seperate plots and each has to have its own label text and anotation.
Here is an answer that first fits polynomial regression and gets the predicted values, then plots them all with geom_line, not geom_smooth.
library(ggplot2)
df <- mtcars
df <- data.frame("x"=df$mpg, "y"=df$hp)
tmp <- sapply(2:5, function(d){
predict(lm(y ~ poly(x, d), df))
})
df2 <- df
df2 <- cbind(df2, tmp)
rm(tmp)
names(df2)[-(1:2)] <- paste0("degree", 2:5)
long <- reshape2::melt(df2, id.vars = c("x", "y"))
ggplot(long, aes(x, y)) +
geom_point(shape=21, fill="blue", colour="black", size=2, alpha = 0.7) +
geom_line(aes(y = value), colour = "red") +
facet_wrap(~ variable)
Edit.
Another way, without fitting the models previously, is the following, inspired in a RStudio community post.
library(tidyverse)
cbind(df, tmp) %>%
gather(degree, value, -x, -y) %>%
{
reduce2(.init = ggplot(., aes(x = x, y = y)),
.x = .$degree,
.y = .$value,
function(prev, .x, .y) {
force(.y) # The formula below won't evaluate .y by itself
prev + geom_smooth(
data = . %>% filter(degree == .x),
method = "lm",
se = FALSE,
formula = y ~ poly(x, .y))
})
} +
geom_point(fill = "blue", colour = "black",size = 2, alpha = 0.7) +
facet_wrap(~ degree)
It's pretty simple with the stat_function function
I know you said you wanted to use facet_wrap but I would suggest using ggarrange in the ggpubr library
mylm1 <- lm(hp ~ mpg + I(mpg^2), data = df)
mylm2 <- lm(hp ~ mpg + I(mpg^2) + I(mpg^3), data = df)
mylm3 <- lm(hp ~ mpg + I(mpg^2) + I(mpg^3) + I(mpg^4), data = df)
mylm4 <- lm(hp ~ mpg + I(mpg^2) + I(mpg^3) + I(mpg^4) + I(mpg^5), data = df)
b1 <- coef(mylm1)
b2 <- coef(mylm2)
b3 <- coef(mylm3)
b4 <- coef(mylm4)
p1 <- df %>%
ggplot() +
geom_point(aes(x = mpg, y = hp)) +
stat_function(fun = function(x) b1[1] + b1[2]*x + b1[3]*x^2)
p2 <- df %>%
ggplot() +
geom_point(aes(x = mpg, y = hp)) +
stat_function(fun = function(x) b2[1] + b2[2]*x + b2[3]*x^2 + b2[4]*x^3)
p3 <- df %>%
ggplot() +
geom_point(aes(x = mpg, y = hp)) +
stat_function(fun = function(x) b3[1] + b3[2]*x + b3[3]*x^2 + b3[4]*x^3 + b3[5]*x^4)
p4 <- df %>%
ggplot() +
geom_point(aes(x = mpg, y = hp)) +
stat_function(fun = function(x) b4[1] + b4[2]*x + b4[3]*x^2 + b4[4]*x^3 + b4[5]*x^4 + b4[6]*x^5)
library(ggpubr)
ggarrange(p1,p2,p3,p4)