通过点阵中的点绘制二次样条

Question

基于这个很棒的问题：How to draw a smooth curve passing through some points

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

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

这是基础图形解决方案的行 - 换行“转换为点阵。 （翻译的直接性由 由 latticeExtra 包提供的+运算符。有关其用法的详细信息，请参阅?layer。）

最后一行调用grid.xspline()， base 图形函数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

这不是一个解决方案，试图在grid.xspline中使用ggplot2的Josh解决方案。我认为在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)

我的想法是使用ggplot2生成的比例，在与散点图相同的面板中创建样条线。我个人认为这很棘手，我希望有人能找到更好的解决方案。

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

我终于根据这个问题的答案找到了解决方案：Quadratic spline

使用包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)
}