Tweening to demonstrate kernel density bandwidth

First off set a few things up: humpcol is the colour of the KDE - bgcol is the colour of the true distribution. closeup closes the distribution curve to a polygon with a base line on the x axis; this is useful for shading in its area. tweens contains the landmark curves at regularly spaced bandwidths, and the tweened curves in between them. The do.call and rbind combination turn a list of tweened vectors into a matrix.

N <- 8
nn <- 8
library(tweenr)
set.seed(250162)
x <- rnorm(400)
bw <- seq(0.02,0.7,l=N)
results <- vector(N,mode='list')
for(i in 1:N) {
  kd <- density(x,bw=bw[i],from=-3,to=3)
  xx <- kd$x
  results[[i]] <- kd$y
}

tweens <- do.call(rbind,tween_numeric(results,n=nn))
humpcol <- adjustcolor('indianred',alpha.f=0.5)
bgcol <- adjustcolor('dodgerblue',alpha.f=0.5)
nd <- dnorm(xx)
closeup <- function(x,y) {
  xy <- cbind(x,y)
  top <- xy[1,]
  btm <- xy[nrow(xy),]
  top[2] <- btm[2] <- 0
  return(rbind(top,xy,btm))
}

Now the preparation is done (much of it in the tweening) just create an animation by drawing each kde in turn.

for (i in 1:ncol(tweens)) {
  plot(closeup(xx,tweens[,i]),type='n',ylim=c(0,0.6))
  polygon(closeup(xx,nd),border=bgcol,col=bgcol)
  polygon(closeup(xx,tweens[,i]),border=humpcol,col=humpcol)
  
}

Another approach is to tween the KDE bandwidths rather than the KDEs themselves

bwvec <- tween_numeric(c(0.02,0.7),n=25)[[1]]
for (bwi in bwvec) {
  kd <- density(x,bw=bwi,from=-3,to=3)
  plot(closeup(kd$x,kd$y),type='n',ylim=c(0,0.6))
  polygon(closeup(xx,nd),border=bgcol,col=bgcol)
  polygon(closeup(kd$x,kd$y),border=humpcol,col=humpcol)
}

The above isn’t that interesting, not much different from using seq(0.02,0.7,l=25) to generate the bandwidths. It gets more interesting with other easing effects:

bwvec <- tween_numeric(c(0.02,0.7),n=65,ease='bounce-out')[[1]]
for (bwi in bwvec) {
  kd <- density(x,bw=bwi,from=-3,to=3)
  plot(closeup(kd$x,kd$y),type='n',ylim=c(0,0.6))
  polygon(closeup(xx,nd),border=bgcol,col=bgcol)
  polygon(closeup(kd$x,kd$y),border=humpcol,col=humpcol)
}