Rでアニメーションその1

注:本記事は「趣味」の範囲で作成しております。多分、アニメーションを作成したいなら、あえてRでやらなくてもよいと思います。

なぜアニメーション？

ワシントンポストのシミュレーションに感動したのと、Pythonで再現してみたという記事を見かけて、どこまでできるかわからないけどやってみようと思い立ちました。

情報検索

そもそも、アニメーションをRで作ることができるのか・・・

Googleで検索すると、GGanimate等の有名どころのパッケージはでてくるが、どうもぴんと来ない。

そんな中、こんなサイトを発見

まずは、このサイトの写経を(若干Tidyverseで書き換えながら)行いつつ、「ボールが跳ねる」動画を作成することを本記事では目指すことにします。

ボールをはねさせよう！

データの準備

library(tidyverse)

#ボールの特徴と位置を表すtibbleを作成
df <- tibble(
  v0      = 100,         #初期速度
  theta   = 1.4,         #角度(ラジアン)
  gravity = 5,           #重力
  adj     = 0,           #跳ねる効果を作成
  decay   = 0.8,         #ボールの跳ね具合
  color   = "steelblue", #ボールの色
  cex     = 2,           #ボールのサイズ
  t       = 0,           #ボールの時刻
  xpos    = 0,           #現在のx軸上の位置(更新される)
  ypos    = 0,           #現在のy軸上の位置(更新される)
)

このtibbleを時間経過とともに更新して、pngで画像を保存する関数

snapshot <- function(df, ct, outdir = "bouncing") {
  dir.create(outdir)
  tval <- 0.3

  # open PNG device
  png(filename = sprintf("%s/bounce%04d.png", outdir, ct), 
      width = 960, 
      height = 540)

  # remove any margin
  par(mar = c(0, 0, 0, 0))
  # create blank canvas
  plot(c(0, 0), 
       type = "n", 
       col = "white", 
       xlim = c(-1, 960), 
       ylim = c(-5, 540), 
       yaxt = "n", 
       ann = FALSE, 
       xaxt = "n", 
       bty = "n")

  # add baseline calculate new position using projectile formula
  # df$ypos <- df$v0 * df$t * sin(df$theta) - (df$gravity * (df$t^2))
  # df$xpos <- df$v0 * df$t * cos(df$theta) + df$adj

  df <- df %>% 
    mutate(
      ypos = v0 * t * sin(theta) - (gravity * t^2),
      xpos = v0 * t * cos(theta) + adj
    )

  # draw the point(s)
  points(df$xpos, df$ypos, type = "p", cex = df$cex, pch = 16, col = df$color)

  # check for anything bouncing
  for (x in seq(nrow(df))) {
      if (df$ypos[x] < 0) {
          # reset the bounce
          df$adj[x] <- df$xpos[x]
          df$v0[x] <- df$v0[x] * df$decay[x]
          df$t[x] <- -tval
      }
  }
  # if stuck, settle it.
  df$v0 <- ifelse(df$v0 < 0.01, 0, df$v0)
  df$t <- df$t + tval
  dev.off()
  df
}

#snapshotを実行
for (i in seq(280)) {
    df <- snapshot(df, i, outdir = "oneball")
    print(str_glue("{i}/280"))
}

おお、oneballフォルダの中に、280個のpngファイルができた！

これを、動画形式に変換するためには、参考にしたWebサイトではavconvという
プログラムでpngファイルをmp4に変換していたんですが、ここもRのパッケージで
完結したいところ・・・

(参考にした記事では、システム関数を利用して、コマンドラインでの処理を実施している。)

system("avconv -f image2 -y -i oneball/bounce%04d.png  -r 25 -b 50000000 -s 1920x1080 -an oneball.mp4")

ググってみると・・・

発見しました。FFMPEG(有名どころ)のラッパーとなる、avパッケージ。

普通にCRANにあるので、簡単にインストールできます。

install.packages("av")
library(av)

input_files <- list.files("oneball", full.names = TRUE)

av_encode_video(input = input_files, output = "test1.mp4")

できた！

pngを出力せずにmp4を出力してみる。

ということで、png多量に生成して、mp4を生成するという手順は問題なくできることが
確認できたので、次は、avパッケージにある、直接アニメーションを生成できる関数と、
ggplotを使って描画することを試みる。

これは特段難しい話ではないので、さくっと。
今回写経したsnapshot関数は、点の時間経過に伴うシミュレーションと、pngの出力を同時に賄っていたので、その部分も切り分ける。

reset_df <- function(){
  df <- tibble(
    v0      = 100,         #initial velocity
    theta   = 1.4,         #angle in radians
    gravity = 5,           #this is just picked for the sclale
    adj     = 0,           #used in the bouncing effect
    decay   = 0.8,         #the bounciness of the ball
    color   = "steelblue", #color of the ball
    cex     = 2,           #size of the ball
    t       = 0,           #time position of this ball
    xpos    = 0,           #current x position (will be updated)
    ypos    = 0,           #current y position (will be updated)
  )
 return(df) 
}

generate_picture <- function(df, xrange = 1200, yrange = 900){

  range_xy_ratio <- xrange/yrange

  gg <- ggplot(df) + 
    geom_point(aes(x = xpos, y = ypos, color = color, size = cex)) +
    labs(x = NULL, y = NULL) +
    scale_x_continuous(breaks = NULL, minor_breaks = NULL) +
    scale_y_continuous(breaks = NULL, minor_breaks = NULL) +
    theme(legend.position = "none", 
          panel.background = element_rect(fill = "white", colour = "white")) +
    coord_cartesian(xlim = c(0,xrange), ylim = c(0,yrange))

  return(gg)
}

generate_picture(df)

これで、グラフの描画はOK。シミュレーション部分を書いてみる。

df <- reset_df()

simulate_ball <- function(df, time_lapse=0.3){
  #new t value
  df <- df %>% mutate(t = t + time_lapse)

  #calculate new position
  df <- df %>% 
    mutate(
      ypos = v0 * t * sin(theta) - (gravity * t^2),
      xpos = v0 * t * cos(theta) + adj
    )

  # check for anything bouncing
  for (x in seq(nrow(df))) {
      if (df$ypos[x] < 0) {
          # reset the bounce
          df$adj[x] <- df$xpos[x]
          df$v0[x] <- df$v0[x] * df$decay[x]
          df$t[x] <- -time_lapse
      }
  }
  # if stuck, settle it.
  df$v0 <- ifelse(df$v0 < 0.01, 0, df$v0)
  df$t <- df$t + time_lapse

  return(df)
}

for(i in 1:5){
  print(i)
  df <- df %>% simulate_ball(.,time_lapse = 0.3)
  generate_picture(df) %>% print()
}

OK！あとは、これをav関数で直接mp4に変換する！
(と意気込んだのは良いものの、フレームレートの設定等を色々といじくる必要があったので、
結局、pngでまず吐き出しておいて、それを処理する方がよさげでした。次のようなスクリプトでも動画はできるはできましたけどね。)

av::av_capture_graphics(expr = {
  df <- reset_df()
  for(i in 1:280){
    print(i)
    df <- df %>% simulate_ball(.,time_lapse = 0.3)
    generate_picture(df) %>% print()
  }
}, output = "test2.mp4", framerate = 40)

次は、ワシントンポストのシミュレーションを再現できるかこころみます。