S4クラス用のgeneric関数でキャッシュを実現する方法を考える

概要

Rが常に値渡しであるために関数の返り値のキャッシュをオブジェクトの中に素直に持てなくて困ったので解決法を考えた。

背景

ある特定のオブジェクトを引数として、もの凄く重たい関数が何回も呼ばれるとする。毎回真面目に計算するのはしんどいので、初回呼び出し時だけはちゃんと計算してその計算結果をオブジェクトの中にキャッシュとして残しておいて、2回目以降はキャッシュを返すだけにしたい。

上手く行かない例

setClass("NotCachedClass", representation(is.cached="logical",
                                          cached.value="POSIXct"))

setMethod("initialize", "NotCachedClass",
          function(.Object, ...){
            .Object@is.cached <- FALSE
            .Object
          })

setGeneric("veryHeavyCalculation",
           function(obj)standardGeneric("veryHeavyCalculation"))
setMethod("veryHeavyCalculation", signature=(obj="NotCachedClass"),
          function(obj){ # <- 呼び出し元の引数のコピーが実引数となる
            if(obj@is.cached){
              cat("using cached value\n")
              obj@cached.value
            }
            else{
              cat("calculating\n")
              ret <- Sys.time()
              obj@is.cached <- TRUE
              obj@cached.value <- ret
              ret
            }
          })

object.a <- new("NotCachedClass")
veryHeavyCalculation(object.a) # 真面目に計算
veryHeavyCalculation(object.a) # 2回目の計算だけど、真面目に計算

素直に考えるとこんな感じで上手く行って欲しいんだけど、これは上手く行かない。何故なら、veryHeavyCalculationの仮引数objの実引数は、グローバル環境に存在しているobject.aそのものではなくて、そのコピーだからだ。つまり、上のプログラムだと、グローバル環境の中のobject.aではなくて、関数呼び出し時に作成されたそのコピーの中にキャッシュが作成される。だから、2回object.aを引数としてveryHeavyCalculationを呼び出しても、object.aの中にはキャッシュが無いので真面目に計算されてしまう。

上手く行く例

オブジェクトの中にクロージャーを持って、その中にキャッシュを持てば良い。

setClass("CachedClass", representation(is.cached="function",
                             get.cache="function",
                             set.cache="function"))
setMethod("initialize", "CachedClass",
          function(.Object, ...){
            cache <- local({
              cached       <- FALSE
              cached.value <- NULL
              is.cached <- function(){
                cached
              }
              get.cache <- function(){
                cached.value
              }
              set.cache <- function(v){
                cached       <<- TRUE
                cached.value <<- v
              }
              function(method){
                if(method=="cached") return(is.cached)
                if(method=="get") return(get.cache)
                if(method=="set") return(set.cache)
              }
            })
            arg = list(...)
            .Object@is.cached <- cache("cached")
            .Object@get.cache <- cache("get")
            .Object@set.cache <- cache("set")
            .Object
          })
setGeneric("veryHeavyCalculation", function(obj)standardGeneric("veryHeavyCalculation"))
setMethod("veryHeavyCalculation",
          signature(obj="CachedClass"),
          function(obj){
            if(obj@is.cached()){
              cat("using cached value\n")
              obj@get.cache()
            }
            else{
              cat("calculating\n")
              ret <- Sys.time()
              obj@set.cache(ret)
              ret
            }
          })

object.a <- new("CachedClass")
veryHeavyCalculation(object.a)
veryHeavyCalculation(object.a)
b <- new("CachedClass")
veryHeavyCalculation(b)