Создание расширения ggproto geom

Question

Попытка построить новую функцию geom, которая будет брать выборку точек из набора данных по группам и подгонять ряд локальных регрессий через отдельные подмножества. Это создаст несколько линий локальной регрессии в качестве выборок полного набора данных. В конце концов создание чего-то похожего на это:

Хотя я продолжаю получать ошибки с функцией, которую я построил ниже (с представлением). Любая помощь приветствуется. Спасибо!

library(ggplot2)
library(dplyr)

geom_mline <- function(mapping = NULL, data = NULL, stat = "mline",
                         position = "identity", show.legend = NA,
                         inherit.aes = TRUE, na.rm = TRUE,
                         SPAN = .9, N_size = 50, N_LOESS = 50, ...) {
  layer(
    geom = geomMline,
    mapping = mapping,
    data = data,
    stat = stat,
    position = position,
    show.legend = show.legend,
    inherit.aes = inherit.aes,
    params = list(SPAN=SPAN,
                  N_size=N_size,
                  N_LOESS=N_LOESS,
                  ...)
  )
}

geomMline <- ggproto("geomMline", GeomLine,
                       required_aes = c("x", "y"),
                       default_aes = aes(colour = "black", size = 0.5, linetype = 1, alpha = NA)
)

stat_mline <- function(mapping = NULL, data = NULL, geom = "line",
                         position = "identity", show.legend = NA, inherit.aes = TRUE,
                         SPAN = .9, N_size = 50, N_LOESS = 50, ...) {
  layer(
    stat = StatMline,
    data = data,
    mapping = mapping,
    geom = geom,
    position = position,
    show.legend = show.legend,
    inherit.aes = inherit.aes,
    params = list(SPAN=SPAN,
                  N_size=N_size,
                  N_LOESS=N_LOESS,
                  ...
    )
  )
}

StatMline <- ggproto("StatMline", Stat,

                       required_aes = c("x", "y"),

                       compute_group = function(self, data, scales, params,
                                                SPAN = .9, N_size = 50, N_LOESS = 50) {

                         tf <- tempfile(fileext=".png")
                         png(tf)
                         plot.new()
                         colnames(data) <- c("x", "variable", "y")
                         LOESS_DF <- data.frame(y = seq(min(data$x), 
                                                               max(data$x), 
                                                               length.out = 50))

                         for(i in 1:N_LOESS){
                           # sample N_size points
                           df_sample <- sample_n(data, N_size)
                           # fit a loess
                           xx <- df_sample$x
                           yy <- df_sample$y
                           tp_est <- loess(yy ~ xx , span = SPAN) 
                           # predict accross range of x using loess model
                           loess_vec <- data.frame(
                             predict(tp_est, newdata = 
                                       data.frame(xx = seq(min(data$x), max(data$x), length.out = 500))))
                           colnames(loess_vec) <- as.character(i)
                           # repeat x times
                           LOESS_DF <- cbind(LOESS_DF,loess_vec)
                           #str(LOESS_DF)
                         }

                         invisible(dev.off())
                         unlink(tf)
                         data.frame(reshape2::melt(LOESS_DF, id = "y"))




                       }
)

# dummy data
library(reshape2)


x  <- seq(1,1000,1)
y1 <- rnorm(n = 1000,mean = x*2^1.1, sd = 200)
y2 <- rnorm(n = 1000,mean = x*1, sd = 287.3)
y3 <- rnorm(n = 1000,mean = x*1.1, sd = 100.1)

data <- data.frame(x , y1, y2, y3)

data <- melt(data, id.vars = "x")
str(data)

ggplot(data,aes(x,value,group = variable, color = va

riable))+geom_point()

    ggplot(data = data, aes(x = x, y = value, group=variable, color = variable)) +
  #geom_point(color="black") +
  #geom_smooth(se=FALSE, linetype="dashed", size=0.5) +
  #stat_mline(SPAN = .2, N_size = 50, N_LOESS = 5)
  geom_mline(SPAN = .2, N_size = 50, N_LOESS = 5)

    #data <- subset(data, variable == "y2")

Answer 1

Вы могли бы использовать существующие geom_smooth геом и использование lapply чтобы генерировать geom_smooth вызовы из нескольких случайных выборок из исходного кадра данных. Например:

# Fake data
set.seed(2)
dat = data.frame(x = runif(100, 0, 10))
dat$y = 2*dat$x - 0.5*dat$x^2 - 5 + rnorm(100, 0, 5)

ggplot(dat, aes(x, y)) + 
  geom_point() +
  lapply(1:10, function(i) {
    geom_smooth(data=dat[sample(1:nrow(dat), 20), ], se=FALSE)
    })

Или, сохраняя все это в tidyverse:

library(tidyverse)

ggplot(dat, aes(x, y)) + 
  geom_point() +
  map(1:10, ~geom_smooth(data=dat[sample(1:nrow(dat), 20), ], se=FALSE))

Вот способ построить квантили в пределах ggplot. Я не уверен, возможно ли получить stat_quantile построить ленту. Чтобы получить это, вам, возможно, придется рассчитать квантильную регрессию вне ggplot и добавить использование geom_ribbon добавить значения.

ggplot(dat, aes(x, y)) + 
  geom_point() +
  geom_quantile(quantiles=c(0.1, 0.5, 0.9), formula=y ~ poly(x, 2), 
                aes(color=factor(..quantile..), size=factor(..quantile..))) +
  scale_color_manual(values=c("red","blue","red")) +
  scale_size_manual(values=c(1,2,1)) +
  labs(colour="Quantile") +
  guides(colour=guide_legend(reverse=TRUE), size=FALSE) +
  theme_classic()