Step 0. get done w/o extending
library(tidyverse)
## ── Attaching core tidyverse packages ──────────────────────── tidyverse 2.0.0 ──
## ✔ dplyr 1.1.0 ✔ readr 2.1.4
## ✔ forcats 1.0.0 ✔ stringr 1.5.0
## ✔ ggplot2 3.4.1 ✔ tibble 3.2.0
## ✔ lubridate 1.9.2 ✔ tidyr 1.3.0
## ✔ purrr 1.0.1
## ── Conflicts ────────────────────────────────────────── tidyverse_conflicts() ──
## ✖ dplyr::filter() masks stats::filter()
## ✖ dplyr::lag() masks stats::lag()
## ℹ Use the conflicted package (<http://conflicted.r-lib.org/>) to force all conflicts to become errors
stdz <- function(x){
var_mean <- mean(x)
var_sd <- sd(x)
(x-var_mean)/var_sd
}
cars %>%
mutate(x = stdz(speed), y = stdz(dist)) ->
prep
lm(y~x, data = prep) ->
model
prep %>%
mutate(y0 = y) %>%
mutate(y = model$fitted.values) %>%
mutate(ymin = model$fitted.values) %>%
mutate(yend = y0) %>%
mutate(ymax = y0) %>%
mutate(xmin = x) %>%
mutate(xend = x) %>%
mutate(xmax = x + ( ymax- ymin)) %>%
ggplot()+
aes(x, y, xmin = xmin, ymin = ymin, xmax = xmax, ymax = ymax) +
geom_point() +
coord_equal() +
geom_rect()
Step 1. Compute group
compute_group_lm_fitted<- function(data, scales){
model<-lm(formula= y ~ x, data = data)
data %>%
mutate(y0 = y) %>%
mutate(y = model$fitted.values) %>%
mutate(ymin = model$fitted.values) %>%
mutate(yend = y0) %>%
mutate(ymax = y0) %>%
mutate(xmin = x) %>%
mutate(xend = x) %>%
mutate(xmax = x + ( ymax- ymin))
}
# test out the function
cars %>%
# rename to explicitly state the x and y inputs
rename(x = speed, y = dist) %>%
compute_group_lm_fitted()
## x y y0 ymin yend ymax xmin xend xmax
## 1 4 -1.849460 2 -1.849460 2 2 4 4 7.8494599
## 2 4 -1.849460 10 -1.849460 10 10 4 4 15.8494599
## 3 7 9.947766 4 9.947766 4 4 7 7 1.0522336
## 4 7 9.947766 22 9.947766 22 22 7 7 19.0522336
## 5 8 13.880175 16 13.880175 16 16 8 8 10.1198248
## 6 9 17.812584 10 17.812584 10 10 9 9 1.1874161
## 7 10 21.744993 18 21.744993 18 18 10 10 6.2550073
## 8 10 21.744993 26 21.744993 26 26 10 10 14.2550073
## 9 10 21.744993 34 21.744993 34 34 10 10 22.2550073
## 10 11 25.677401 17 25.677401 17 17 11 11 2.3225985
## 11 11 25.677401 28 25.677401 28 28 11 11 13.3225985
## 12 12 29.609810 14 29.609810 14 14 12 12 -3.6098102
## 13 12 29.609810 20 29.609810 20 20 12 12 2.3901898
## 14 12 29.609810 24 29.609810 24 24 12 12 6.3901898
## 15 12 29.609810 28 29.609810 28 28 12 12 10.3901898
## 16 13 33.542219 26 33.542219 26 26 13 13 5.4577810
## 17 13 33.542219 34 33.542219 34 34 13 13 13.4577810
## 18 13 33.542219 34 33.542219 34 34 13 13 13.4577810
## 19 13 33.542219 46 33.542219 46 46 13 13 25.4577810
## 20 14 37.474628 26 37.474628 26 26 14 14 2.5253723
## 21 14 37.474628 36 37.474628 36 36 14 14 12.5253723
## 22 14 37.474628 60 37.474628 60 60 14 14 36.5253723
## 23 14 37.474628 80 37.474628 80 80 14 14 56.5253723
## 24 15 41.407036 20 41.407036 20 20 15 15 -6.4070365
## 25 15 41.407036 26 41.407036 26 26 15 15 -0.4070365
## 26 15 41.407036 54 41.407036 54 54 15 15 27.5929635
## 27 16 45.339445 32 45.339445 32 32 16 16 2.6605547
## 28 16 45.339445 40 45.339445 40 40 16 16 10.6605547
## 29 17 49.271854 32 49.271854 32 32 17 17 -0.2718540
## 30 17 49.271854 40 49.271854 40 40 17 17 7.7281460
## 31 17 49.271854 50 49.271854 50 50 17 17 17.7281460
## 32 18 53.204263 42 53.204263 42 42 18 18 6.7957372
## 33 18 53.204263 56 53.204263 56 56 18 18 20.7957372
## 34 18 53.204263 76 53.204263 76 76 18 18 40.7957372
## 35 18 53.204263 84 53.204263 84 84 18 18 48.7957372
## 36 19 57.136672 36 57.136672 36 36 19 19 -2.1366715
## 37 19 57.136672 46 57.136672 46 46 19 19 7.8633285
## 38 19 57.136672 68 57.136672 68 68 19 19 29.8633285
## 39 20 61.069080 32 61.069080 32 32 20 20 -9.0690803
## 40 20 61.069080 48 61.069080 48 48 20 20 6.9309197
## 41 20 61.069080 52 61.069080 52 52 20 20 10.9309197
## 42 20 61.069080 56 61.069080 56 56 20 20 14.9309197
## 43 20 61.069080 64 61.069080 64 64 20 20 22.9309197
## 44 22 68.933898 66 68.933898 66 66 22 22 19.0661022
## 45 23 72.866307 54 72.866307 54 54 23 23 4.1336934
## 46 24 76.798715 70 76.798715 70 70 24 24 17.2012847
## 47 24 76.798715 92 76.798715 92 92 24 24 39.2012847
## 48 24 76.798715 93 76.798715 93 93 24 24 40.2012847
## 49 24 76.798715 120 76.798715 120 120 24 24 67.2012847
## 50 25 80.731124 85 80.731124 85 85 25 25 29.2688759
Step 2. pass to ggproto
StatLmFitted<-ggplot2::ggproto(`_class` = "StatLmFitted",
`_inherit` = ggplot2::Stat,
required_aes = c("x", "y"),
compute_group = compute_group_lm_fitted)
Step 3. pass to geom function.
geom_lm_residual_sq <- function(mapping = NULL, data = NULL,
position = "identity", na.rm = FALSE,
show.legend = NA,
inherit.aes = TRUE, ...) {
ggplot2::layer(
stat = StatLmFitted, # proto object from step 2
geom = ggplot2::GeomRect, # inherit other behavior
data = data,
mapping = mapping,
position = position,
show.legend = show.legend,
inherit.aes = inherit.aes,
params = list(na.rm = na.rm, ...)
)
}
Step 4. Enjoy
library(ggxmean)
# not a great result
library(tidyverse)
ggplot(cars) +
aes(speed, dist) +
geom_point() +
geom_lm() +
geom_lm_fitted(color = "blue") +
geom_lm_residual_sq(alpha = .2)
# better
last_plot() +
coord_equal()
# best
last_plot() +
aes(stdz(speed), stdz(dist))
# coord_sd_equal() Could this be a useful thing to this problem or another problem
look at small data
ggplot(anscombe) +
aes(x = x1, y = y1) +
geom_point() +
geom_lm() +
geom_lm_fitted(color = "blue") +
geom_lm_residual_sq(alpha = .2)
last_plot() +
coord_equal()
last_plot() +
aes(stdz(x1), stdz(y1))
