Rでアニメーションを簡単に作る

ez.R

# ez.R -- 暫定版（中途半端）

# TODO
# 1. CURD操作に、削除、リネーム、コピーを付ける
# 2. SEとNSEの関数をちゃんと作る。
# 3. オブジェクトのセーブを付ける。
# 4. 上書きを予防するようにする。


# animationパッケージを一緒に使うことが多い
# 余計なお世話か？
if (!require('animation')) {
  install.packages('animation')
}


# print汎用関数のメソッド
# キータイプ節約用
print.interactiveCommand <- function(x) {
  val <- x()
  if (!is.null(val)) print(val)
}

#
# 初期化
# ------

ez.init <- function() {
  if (exists(".ez", envir=.GlobalEnv)) {
    remove(".ez", envir=.GlobalEnv)
  }
  .GlobalEnv$.ez <- new.env()
  .GlobalEnv$.ez$scene <- new.env()
  .GlobalEnv$.ez$currentExpr <- quote(NULL)
  .GlobalEnv$.ez$currentSitu <- ez.situ()
  .GlobalEnv$.ez$aniMode <- FALSE
}

# 注意： 初期化の実行はコードの最後


#
# CRUD操作 Create （コンストラクタ）
# ---------------------------------

ez.scene <-  function(expr = NULL, situ = NULL) {
  structure(
    list(
      expr = expr,
      situ = if (is.null(situ)) ez.situ() else situ
      ),
    class = "ez.scene"
    )
}

ez.situ <-
  function(
    varname = "t",
    from = 0,
    to = 1,
    div = 5,
    step = NULL,
    setup = NULL,
    tearDown = NULL,
    ready = NULL,
    pause = ez.pause
    )
{
  stopifnot(is.character(varname))
  
  if (is.null(step)) {
    step <- (to - from)/div
    nFrames <- div + 1
  } else {
#    browser()
    nn <- (to - from)/step
    if (nn%%1 == 0) {
      nFrames <- nn + 1
    } else {
      nFrames <- floor(nn)
    }
  }
  structure(
    list(
      varname = varname,
      from = from,
      to = to,
      step = step,
      nFrames = nFrames,
      setup = setup,
      tearDown = tearDown,
      ready = ready,
      pause = pause
      ),
    class = "ez.situ"
    )
}


#
# CRUD操作 Read
# -------------

ez.ls <- function() {
  ls(.GlobalEnv$.ez$scene)
}
class(ez.ls) <- "interactiveCommand"

ez.get <- function(name = '.') {
  name <- substitute(name)
  name <- as.character(name)

  ez.get_(name)
}
class(ez.get) <- "interactiveCommand"

ez.get_ <- function(name = '.') {
  if (name == '.') {
    scene <- ez.currentScene()
  } else {
    scene <- .GlobalEnv$.ez$scene[[name]]
  }
  scene
}

ez.currentExpr <- function() .GlobalEnv$.ez$currentExpr
class(ez.currentExpr) <- "interactiveCommand"

ez.currentSitu <- function() .GlobalEnv$.ez$currentSitu
class(ez.currentSitu) <- "interactiveCommand"

ez.currentScene <- function() ez.scene(ez.currentExpr(), ez.currentSitu())
class(ez.currentScene) <- "interactiveCommand"


#
# CRUD操作 Update
# -------------

ez.set <- function(name, expr = NULL , situ = NULL) {
  # setup name
  name <- substitute(name)
  stopifnot(is.name(name) || is.character(name))
  name <- as.character(name)
  # setup expr
  expr <- substitute(expr)
  expr <- if (is.null(expr)) ez.currentExpr() else expr
  # setup situ
  situ <- if (is.null(situ)) ez.currentSitu() else situ
  
  assign(name, ez.scene(expr, situ), envir = .GlobalEnv$.ez$scene)
}

ez.prepare <- function(name) {
  name <- substitute(name)
  name <- as.character(name)
  ez.prepare_(name)
}

ez.prepare_ <- function(name) {
  scene <- ez.get_(name)
  .GlobalEnv$.ez$currentExpr <- scene$expr
  .GlobalEnv$.ez$currentSitu <- scene$situ
}

ez.modifySitu <-
  function(
    name = '.',
    varname,
    from,
    to,
    div, # 引数のみ
    step,
    setup,
    tearDown,
    ready,
    pause
    )
{

  stopifnot(is.name(name) || is.character(name))
  name <- as.character(name)
  if (name == '.') {
    situ <- ez.currentSitu()
  } else {
    situ <- ez.get(name)$situ
  }
  stopifnot(!is.null(situ))

  if (!missing(varname)) {
#    browser()
    stopifnot(is.character(varname))
    varname <- varname
  } else {
    varname <- situ$varname
  }
  
  from <- if(missing(from)) situ$from else from
  to <- if(missing(to)) situ$to else to
  if (missing(step) && !missing(div)) {
    step <- (to - from)/div
  } else {
    step <- if(missing(step)) situ$step else step
  }

  newSitu <- ez.situ(
#  list(
    varname = varname,
    from = from,
    to = to,
    step = step,
    setup = if(missing(setup)) situ$setup else setup,
    tearDown = if(missing(tearDown)) situ$tearDown else tearDown,
    ready = if(missing(ready)) situ$ready else ready,
    pause = if(missing(pause)) situ$pause else pause
    )

  if (name == '.') {
    .GlobalEnv$.ez$currentSitu <- newSitu
  } else {
    .GlobalEnv$.ez$scene[[name]]$situ <- newSitu
  }
  newSitu
}

#
# その他の操作
# -------------

# オブジェクトをファイルにセーブする
ez.save <- function(filename = NULL) {
  filename <-
    if (!is.null(filename)) {
      filename
    } else {
      format(Sys.time(), "ez-%Y%m%d_%H%M%S.RData")
    }
  message("saving ez-environment to '", filename, "'")
  # .GlobalEnv$.ez だとうまくいかない、何故？
  save(.ez, file = filename)
}

#
# 実行
# -----

ez.do <- function(nameOrExpr = NULL, situ = NULL) {
  nameOrExpr <- substitute(nameOrExpr)
  if (is.null(nameOrExpr)) {
    expr <- .ez$currentExpr
    situ <- if (is.null(situ)) .ez$currentSitu else situ
  } else if (is.name(nameOrExpr) || is.character(nameOrExpr)) {
    name <- as.character(nameOrExpr)
    scene <- .ez$scene[[name]]
    if (is.null(scene)) stop(name, " is not defined")
    expr <- scene$expr
    situ <- scene$situ
  } else if (is.call(nameOrExpr)) {
    expr <- nameOrExpr
    situ <- if (is.null(situ)) .ez$currentSitu else situ
  } else {
    stop("bad arguments")
  }

  .ez.replay(
    expr = expr,
    situ = situ
    )
  .GlobalEnv$.ez$currentExpr <- expr
  .GlobalEnv$.ez$currentSitu <- situ
  dummy <- NULL
}
class(ez.do) <- "interactiveCommand"


.ez.replay <- function(expr, situ)  {
  varname <- situ$varname
  from <- situ$from
  to <- situ$to
  step <- situ$step
  nFrames <- situ$nFrames
  ready <- if (is.function(situ$ready)) situ$ready else function() {dummy <- 0}
  pause <- if (is.function(situ$pause)) situ$pause else function() {dummy <- 0}

  if (is.function(situ$setup)) situ$setup()
  
  valenv <- list(from)
  names(valenv) <- c(varname)
  for (i in 1:nFrames) {
    ready()
    eval(expr, valenv)
    pause()
    valenv[[1]] <- valenv[[1]] + step
  }

  if (is.function(situ$tearDown)) situ$tearDown()
}

#
# アニメーション
# --------------

ez.ani <- function(flag=TRUE, output.old = FALSE, restore = NULL) {
  situ <- ez.currentSitu()
  oldReady <- situ$ready
  oldPause <- situ$pause
  if (flag) {
    ez.modifySitu(ready = dev.hold, pause=ani.pause)
    .GlobalEnv$.ez$aniMode <- TRUE
  } else {
    newReady <- if (is.null(restore)) NULL else restore$ready
    newPause <- if (is.null(restore)) NULL else restore$pause
    ez.modifySitu(ready = newReady, pause=newPause)
    .GlobalEnv$.ez$aniMode <- FALSE
  }
  if (output.old) {
    list(
      ready = oldReady,
      pause = oldPause
      )
  }
}


ez.video <- function(name = '.', video.name = "animation.mp4")  {
  name <- substitute(name)
  name <- as.character(name)
  if (name != '.') {
    video.name <- paste(name, ".mp4", sep="")
  }
  ez.prepare(name)
  old <- ez.ani(TRUE, output.old = TRUE)
  saveVideo(ez.do(),
            video.name = video.name,
            ffmpeg = "C:/Installed/ffmpeg/bin/ffmpeg.exe"
            )
  ez.ani(FALSE, restore = old)
}
class(ez.video) <- "interactiveCommand" 

#
# 補助的関数
# ----------

ez.pause <- function() {
  dummy <- readline("Hit Enter: ")
}

#
# 初期化の実行
# ------------

if (!exists(".ez")) {
  ez.init()
}

#
# ショートカット別名
# ------------------
  
do <- ez.do
cexpr <- ez.currentExpr
csitu <- ez.currentSitu
cscene <- ez.currentScene