create_spring

library(tidyverse)

create_spring <- function(x, 
                          y, 
                          xend, 
                          yend, 
                          diameter = 1, 
                          tension = 0.75, 
                          n = 50) {
  
  # Validate the input arguments
  if (tension <= 0) {
    rlang::abort("`tension` must be larger than zero.")
  }
  if (diameter == 0) {
    rlang::abort("`diameter` can not be zero.")
  }
  if (n == 0) {
    rlang::abort("`n` must be greater than zero.")
  }
  
  # Calculate the direct length of the spring path
  length <- sqrt((x - xend)^2 + (y - yend)^2)
  
  # Calculate the number of revolutions and points we need
  n_revolutions <- length / (diameter * tension)
  n_points <- n * n_revolutions
  
  # Calculate the sequence of radians and the x and y offset values
  radians <- seq(0, n_revolutions * 2 * pi, length.out = n_points)
  x <- seq(x, xend, length.out = n_points)
  y <- seq(y, yend, length.out = n_points)
  
  # Create and return the transformed data frame
  data.frame(
    x = cos(radians) * diameter/2 + x,
    y = sin(radians) * diameter/2 + y
  )
}

StatSpring (with computed tension proporational to y-dist)

compute_panel_springs <- function(data, 
                           scales, 
                           diameter = 1, 
                           # tension = 0.75, 
                           n = 50) {
    cols_to_keep <- setdiff(names(data), c("x", "y", "xend", "yend"))
    
    
    springs <- lapply(
      seq_len(nrow(data)), 
      function(i) {
        spring_path <- create_spring(
          data$x[i], 
          data$y[i], 
          data$xend[i], 
          data$yend[i], 
          diameter = diameter, 
          tension = .2*abs(data$y[i] - data$yend[i]), 
          n = n
        )
        cbind(spring_path, unclass(data[i, cols_to_keep]))
      }
    )
    do.call(rbind, springs)
  }


setup_data_springs <- function(data, params) {
    if (anyDuplicated(data$group)) {
      data$group <- paste(data$group, seq_len(nrow(data)), sep = "-")
    }
    data
  }

StatSpring <- ggproto("StatSpring", Stat, 
  
  # Edit the input data to ensure the group identifiers are unique
  setup_data = setup_data_springs,
  
  # Construct data for this panel by calling create_spring()
  compute_panel = compute_panel_springs,
  
  # Specify which aesthetics are required input
  required_aes = c("x", "y", "xend", "yend")
)
cars |>
  group_by(speed) |>
  slice(1) |>
  ungroup() |>
  sample_n(10) ->
cars_sample

cars_sample |>
  lm(dist ~ speed, data = _) |>
  predict() |>
  data.frame(predict = _) |>
  bind_cols(cars_sample) |>
  ggplot() + 
  aes(x = speed, xend = speed, y = dist, yend = mean(cars_sample$dist)) + 
  geom_point() +
  geom_path(stat = StatSpring, diameter = .35) + 
  geom_smooth(method = "lm", formula = y ~ 1)  + 
  stat_smooth(method = "lm", geom = "point", xseq = cars_sample$speed,
              color = "blue", formula = y ~ 1)
## Warning: The following aesthetics were dropped during statistical transformation: xend.
## ℹ This can happen when ggplot fails to infer the correct grouping structure in
##   the data.
## ℹ Did you forget to specify a `group` aesthetic or to convert a numerical
##   variable into a factor?
## The following aesthetics were dropped during statistical transformation: xend.
## ℹ This can happen when ggplot fails to infer the correct grouping structure in
##   the data.
## ℹ Did you forget to specify a `group` aesthetic or to convert a numerical
##   variable into a factor?

cars_sample |>
  lm(dist ~ speed, data = _) |>
  predict() |>
  data.frame(predict = _) |>
  bind_cols(cars_sample) |>
  ggplot() + 
  aes(x = speed, xend = speed, y = dist, yend = predict) + 
  geom_point() +
  geom_path(stat = StatSpring, diameter = .35) + 
  geom_smooth(method = "lm")  + 
  stat_smooth(method = "lm", geom = "point", 
              xseq = cars_sample$speed,
              color = "blue")
## `geom_smooth()` using formula = 'y ~ x'
## Warning: The following aesthetics were dropped during statistical transformation: xend
## and yend.
## ℹ This can happen when ggplot fails to infer the correct grouping structure in
##   the data.
## ℹ Did you forget to specify a `group` aesthetic or to convert a numerical
##   variable into a factor?
## `geom_smooth()` using formula = 'y ~ x'
## Warning: The following aesthetics were dropped during statistical transformation: xend
## and yend.
## ℹ This can happen when ggplot fails to infer the correct grouping structure in
##   the data.
## ℹ Did you forget to specify a `group` aesthetic or to convert a numerical
##   variable into a factor?

GeomSpring <- ggproto("GeomSpring", Geom,
  
  # Ensure that each row has a unique group id
  setup_data = function(data, params) {
    if (is.null(data$group)) {
      data$group <- seq_len(nrow(data))
    }
    if (anyDuplicated(data$group)) {
      data$group <- paste(data$group, seq_len(nrow(data)), sep = "-")
    }
    data
  },
  
  # Transform the data inside the draw_panel() method
  draw_panel = function(data, 
                        panel_params, 
                        coord, 
                        n = 50, 
                        arrow = NULL,
                        lineend = "butt", 
                        linejoin = "round", 
                        linemitre = 10,
                        na.rm = FALSE) {
    
    # Transform the input data to specify the spring paths
    cols_to_keep <- setdiff(names(data), c("x", "y", "xend", "yend"))
    springs <- lapply(seq_len(nrow(data)), function(i) {
      spring_path <- create_spring(
        data$x[i], 
        data$y[i], 
        data$xend[i], 
        data$yend[i], 
        data$diameter[i],
        .17*abs(data$y[i]- data$yend[i]), 
        n
      )
      cbind(spring_path, unclass(data[i, cols_to_keep]))
    })
    springs <- do.call(rbind, springs)
    
    # Use the draw_panel() method from GeomPath to do the drawing
    GeomPath$draw_panel(
      data = springs, 
      panel_params = panel_params, 
      coord = coord, 
      arrow = arrow, 
      lineend = lineend, 
      linejoin = linejoin, 
      linemitre = linemitre, 
      na.rm = na.rm
    )
  },
  
  # Specify the default and required aesthetics
  required_aes = c("x", "y", "xend", "yend"),
  default_aes = aes(
    colour = "black", 
    linewidth = 0.5, 
    linetype = 1L, 
    alpha = NA, 
    diameter = 1, 
    tension = 0.75
  )
)


cars_sample |>
  lm(dist ~ speed, data = _) |>
  predict() |>
  data.frame(predict = _) |>
  bind_cols(cars_sample) |>
  ggplot() + 
  aes(x = speed, xend = speed, y = dist, yend = predict) + 
  geom_point() +
  # geom_path(stat = StatSpring, diameter = .35) + 
  stat_identity(geom = GeomSpring) +
  geom_smooth(method = "lm")  
## `geom_smooth()` using formula = 'y ~ x'
## Warning: The following aesthetics were dropped during statistical transformation: xend
## and yend.
## ℹ This can happen when ggplot fails to infer the correct grouping structure in
##   the data.
## ℹ Did you forget to specify a `group` aesthetic or to convert a numerical
##   variable into a factor?

anscombe |> 
  ggplot() + 
  aes(x = x1, y = y1) + 
  geom_point() + 
  geom_smooth() 
## `geom_smooth()` using method = 'loess' and formula = 'y ~ x'

Using verbatim GeomSpring from book

library(ggplot2)
GeomSpring <- ggproto("GeomSpring", Geom,
  
  # Ensure that each row has a unique group id
  setup_data = function(data, params) {
    if (is.null(data$group)) {
      data$group <- seq_len(nrow(data))
    }
    if (anyDuplicated(data$group)) {
      data$group <- paste(data$group, seq_len(nrow(data)), sep = "-")
    }
    data
  },
  
  # Transform the data inside the draw_panel() method
  draw_panel = function(data, 
                        panel_params, 
                        coord, 
                        n = 50, 
                        arrow = NULL,
                        lineend = "butt", 
                        linejoin = "round", 
                        linemitre = 10,
                        na.rm = FALSE) {
    
    # Transform the input data to specify the spring paths
    cols_to_keep <- setdiff(names(data), c("x", "y", "xend", "yend"))
    springs <- lapply(seq_len(nrow(data)), function(i) {
      spring_path <- create_spring(
        data$x[i], 
        data$y[i], 
        data$xend[i], 
        data$yend[i], 
        data$diameter[i],
        data$tension[i], 
        n
      )
      cbind(spring_path, unclass(data[i, cols_to_keep]))
    })
    springs <- do.call(rbind, springs)
    
    # Use the draw_panel() method from GeomPath to do the drawing
    GeomPath$draw_panel(
      data = springs, 
      panel_params = panel_params, 
      coord = coord, 
      arrow = arrow, 
      lineend = lineend, 
      linejoin = linejoin, 
      linemitre = linemitre, 
      na.rm = na.rm
    )
  },
  
  # Specify the default and required aesthetics
  required_aes = c("x", "y", "xend", "yend"),
  default_aes = aes(
    colour = "black", 
    linewidth = 0.5, 
    linetype = 1L, 
    alpha = NA, 
    diameter = 1, 
    tension = 0.75
  )
)


anscombe |> 
  lm(y1 ~ x1, data = _) |>
  predict() |>
  data.frame(predict = _) |>
  bind_cols(anscombe) ->
anscombe1_predicted

anscombe1_predicted |> head()
##     predict x1 x2 x3 x4   y1   y2    y3   y4
## 1  8.001000 10 10 10  8 8.04 9.14  7.46 6.58
## 2  7.000818  8  8  8  8 6.95 8.14  6.77 5.76
## 3  9.501273 13 13 13  8 7.58 8.74 12.74 7.71
## 4  7.500909  9  9  9  8 8.81 8.77  7.11 8.84
## 5  8.501091 11 11 11  8 8.33 9.26  7.81 8.47
## 6 10.001364 14 14 14  8 9.96 8.10  8.84 7.04
anscombe1_predicted |>
  ggplot() + 
  aes(x = x1, y = y1, 
      xend = x1, yend = predict, 
      tension = .3*abs(y1 - predict),
      diameter = .4) + 
  geom_point() + 
  geom_smooth(method = lm) +
  stat_identity(geom = GeomSpring)
## `geom_smooth()` using formula = 'y ~ x'
## Warning: The following aesthetics were dropped during statistical transformation: xend,
## yend, and tension.
## ℹ This can happen when ggplot fails to infer the correct grouping structure in
##   the data.
## ℹ Did you forget to specify a `group` aesthetic or to convert a numerical
##   variable into a factor?

Closing remarks, Other Relevant Work, Caveats