Multiple Polynomial fits in ggplot using facetwrap - r

Question

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.

Answer 1

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)

Answer 2

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)