r - 通过格子中的点绘制二次样条

Question

基于这个伟大的问题：如何绘制通过一些点的平滑曲线

在格子中如何做到这一点？

plot(rnorm(120), rnorm(120), col="darkblue", pch=16, xlim=c(-3,3), ylim=c(-4,4))
points(rnorm(120,-1,1), rnorm(120,2,1), col="darkred", pch=16)
points(c(-1,-1.5,-3), c(4,2,0), pch=3, cex=3)
xspline(c(-1,-1.5,-3), c(4,2,0), shape = -1)

这是类似的数据，格式更适合lattice绘图：

dat <- data.frame(x=c(rnorm(120), rnorm(120,-1,1)),
                  y=c(rnorm(120), rnorm(120,2,1)),
                  l=factor(rep(c('B','R'),each=120))
)
spl <- data.frame(x=c(-1,-1.5,-3), 
                  y=c(4,2,0)
)

这是链接问题给出的内容，翻译为lattice：

xyplot(y ~ x,
       data=dat,
       groups=l,
       col=c("darkblue", "darkred"),
       pch=16,
       panel = function(x, y, ...) {
         panel.xyplot(x=spl$x, y=spl$y, pch=3, cex=3)
         ## panel.spline(x=spl$x, y=spl$y)              ## Gives an error, need at least four 'x' values
         panel.superpose(x, y, ...,
                         panel.groups = function(x, y, ...) {
                           panel.xyplot(x, y, ...)
                         }
         )
       },
       xlim=c(-3,3), ylim=c(-4,4)
)

Answer 1

这是基本图形解决方案到lattice的逐行“翻译” 。（ latticeExtra包+提供的操作符使翻译的直接性成为可能 。有关其用法的详细信息，请参阅。）?layer

最后一行调用了基本图形函数grid.xspline()的精确网格模拟。xspline()

library(lattice)
library(grid)
library(latticeExtra)

xyplot(rnorm(120)~rnorm(120), pch=16, col="darkblue", 
       xlim = c(-3.1, 3.1), ylim = c(-4.1, 4.1)) +
xyplot(rnorm(120,2,1) ~ rnorm(120,-1,1), pch=16, col="darkred") +
xyplot(c(4,2,0) ~ c(-1,-1.5,-3), pch=3, cex=3) +
layer(grid.xspline(c(-1,-1.5,-3), c(4,2,0), shape = -1, default.units="native"))

（网格的一个特殊细节确实出现在上面的最后一行中：就像它的其他几个低级画线函数一样，grid.xspline()默认为单位而不是许多其他函数默认使用"npc"的通常所需的"native"单位。显然这很容易足以改变——一旦你意识到它！）grid.points()grid.*()

Answer 2

这有点棘手，但有效。

plot(rnorm(120), rnorm(120), col="darkblue", pch=16, xlim=c(-3,3), ylim=c(-4,4))
points(rnorm(120,-1,1), rnorm(120,2,1), col="darkred", pch=16)
points(c(-1,-1.5,-3), c(4,2,0), pch=3, cex=3)

我使用xspline而不产生平局

dd <- xspline(c(-1,-1.5,-3), c(4,2,0), shape = -1,draw=FALSE)

然后我使用产生的积分panel.lines

library(lattice)
xyplot(y ~ x,
       data=dat,
       groups=l,
       col=c("darkblue", "darkred"),
       pch=16,
       panel = function(x, y, ...) {
         panel.xyplot(x=spl$x, y=spl$y, pch=3, cex=3)
         panel.lines(dd$x,dd$y)
         panel.superpose(x, y, ...,
                         panel.groups = function(x, y, ...) {
                           panel.xyplot(x, y, ...)
                         }
         )
       },
       xlim=c(-3,3), ylim=c(-4,4)
)

Answer 3

This is not a solution, by an attempt to use Josh solution with grid.xspline in ggplot2. I think it is interesting to get a parallel between ggplot2/lattice.

## prepare the data
dat <- data.frame(x=c(rnorm(120), rnorm(120,-1,1)),
                 y=c(rnorm(120), rnorm(120,2,1)),
                 l=factor(rep(c('B','R'),each=120))
)
spl <- data.frame(x=c(-2,-1.5,-3), 
                  y=c(4,2,0)
)
## prepare the scatter plot
library(ggplot(2))
p <- ggplot(data=dat,aes(x=x,y=y,color=l))+
  geom_point()+
  geom_point(data=spl,aes(x=x,y=y),color='darkred',size=5)
library(grid)
ff <- ggplot_build(p)

My idea is to use the scales generated by ggplot2, to create the spline in the same panel than the scatterplot. Personally I find this tricky, and I hope that someone comes with a better solution.

xsp.grob <- xsplineGrob(spl$x, spl$y,
                        vp=viewport(xscale =ff$panel$ranges[[1]]$x.range,
                                    yscale = ff$panel$ranges[[1]]$y.range),
                        shape = -1, default.units="native")
p
grid.add(gPath='panel.3-4-3-4',child=xsp.grob)

Answer 4

我终于找到了一个解决方案，基于这个问题的答案： 二次样条

使用包splines

用以下代码替换panel.splines(... )（上面注释掉）：

         local({
           model <- lm(y ~ bs(x, degree=2), data=spl)
           x0 <- seq(min(spl$x), max(spl$x), by=.1)
           panel.lines(x0, predict(model, data.frame(x=x0)))
         })

根据 Josh O'Brien 的出色建议，grid.xspline()可以替换注释掉的panel.splines(...)行，从而得到与上面链接的基本问题中的确切情节（除了边距）：

         grid.xspline(spl$x, spl$y, shape = -1, default.units="native")

Answer 5

这是来自 Deepayan Sarkar 的样条面板的变​​体

panel.smooth.spline <-  function(x, y,
                                 w=NULL, df, spar = NULL, cv = FALSE,
                                 lwd=plot.line$lwd, lty=plot.line$lty,col, 
                                 col.line=plot.line$col,type, ... )
{
  x <- as.numeric(x)
  y <- as.numeric(y)
  ok <- is.finite(x) & is.finite(y)
  if (sum(ok) < 1)
    return()
  if (!missing(col)) {
    if (missing(col.line))
      col.line <- col
  }
  plot.line <- trellis.par.get("plot.line")
  spline <-   smooth.spline(x[ok], y[ok],
                            w=w, df=df, spar = spar, cv = cv)
  pred = predict(spline,x= seq(min(x),max(x),length.out=150))
  panel.lines(x = pred$x, y = pred$y, col = col.line,
              lty = lty, lwd = lwd, ...)
  panel.abline(h=y[which.min(x)],col=col.line,lty=2)
}