insertSource を S4 メソッドにも使えるようにしてみた ~S4 メソッドの深い闇~

パッケージの開発を効率化するのに methods::insertSource という関数があります。

evalSource               package:methods               R Documentation

Use Function Definitions from a Source File without Reinstalling a
Package

Description:

     Definitions of functions and/or methods from a source file are
     inserted into a package, using the ‘trace’ mechanism. Typically,
     this allows testing or debugging modified versions of a few
     functions without reinstalling a large package.

メソッドにも対応してると謳ってますがこんなの嘘っぱちです。
以下、R 2.15.3 の話です。

S4 に対する insertSource の悲惨さ

S4 で書かれているパッケージとして例えば int64 があるので、これのメソッドを書き換えてみることにします。
例えば次のように int64 に対してソートした時に “int64!” と表示するように変更します。

> file.show("/path/to/int64.R")
setGeneric( "sort" )
setMethod( "sort", "int64", function(x, decreasing = FALSE, ...){
    cat("int64!\n")
    .Call( int64_sort, x, FALSE, decreasing )
} )

insertSource を使ってみます。

> library(int64)
> insertSource("/path/to/int64.R", package = "int64")
Error in assign(this, thisObj, envir = envwhere) : 
  cannot change value of locked binding for '.packageName'

はい、エラーになりました。
これは次のように force = TRUE を指定して int64 の namespace がロックされているのに assign で強制的に書き換えようとしたことが原因です。
メソッドが定義されているファイルを読み込んだ場合にデフォルトで force = TRUE になるのは仕様で、メソッドが定義されていないファイルを読み込んだ場合にデフォルトで force = FALSE になるのがバグのようですが、force = FALSE は明示的に指定した方が良さそうです。

> insertSource("/path/to/int64.R", package = "int64", force = FALSE)
Non-function objects aren't currently inserted (not traceable): .packageName
.__T__sort:base() is not a generic function in the target environment--methods will not be inserted

エラーは回避できました。ただ、変な警告が出ています。
これは getGeneric にはメソッド名 (sort) を指定すべきなのに meta name (.__T__sort:base) を指定してしまっているのが原因です。明らかにバグです。
これを回避するためには書き換えるメソッドを明示的に指定します。

> insertSource("/path/to/int64.R", package = "int64", method = "sort")
Non-function objects aren't currently inserted (not traceable): .packageName

sort の書き換えに関する警告は出なくなりました。では、メソッドを実行しています。

> sort(as.int64(sample(5)))
[1] 1 2 3 4 5

“int64!” と表示されませんね・・・。
原因は読み込んだファイルの setMethod が正しく機能していないからです。
何故機能しないか、機能しないようにしているかを理解するには S4 メソッドの dispatch の仕組みを理解する必要があります。

S4 メソッドの深い闇

insertSource(正確には evalSource)で評価した場合に setMethod が機能しないのは環境のキャッシュが無効になっているからです。
methods::setMethod の最後の方に次のようなコードがあります。setMethod のターゲットになる環境のキャッシュが有効であればメソッドに関するキャッシュを更新します。キャッシュが更新されないと setMethod で定義したメソッドは参照できません。おそらくどこにも保存されないです。

    if (cacheOnAssign(where)) {
        .cacheMethodInTable(fdef, signature, definition, mtable)
        .cacheMethodInTable(fdef, signature, definition)
        if (is.not.base) 
            .addToMetaTable(fdef, signature, definition, where, 
                nSig)
        resetGeneric(f, fdef, mtable, gwhere, deflt)
    }

この意味不明なキャッシュ制御機構は R のリビジョン 52545 で適用された変更で、

$ svn log -c 52545
------------------------------------------------------------------------
r52545 | jmc | 2010-07-17 02:20:37 +0900 (土, 17  7 2010) | 1 line

adding the evalSource mechanism
------------------------------------------------------------------------

というコミットログからも evalSource のために導入されたことがわかります。
また、このコミットで evalSource/insertSource に必要な関数がひと通り導入されているようです。

仕様やコメントがないので真意はわかりませんが、これはオリジナルのメソッドを直接書き換えないようにするための配慮と思われます。
なので、evalSource には cache という引数がありますが、これを TRUE にすることはメソッドを強制的に書き換えることになり、元に戻せなくなります。

S4 の dispath の仕組み

S4 では setGeneric を実行することでメソッドを管理するための環境を作成し、その環境に signature ごとのメソッド定義を管理するための変数 (.AllMTable, .MTable) を定義します。

> environment(sort)
<environment: namespace:base>
> setGeneric("sort")
[1] "sort"
> environment(sort)
<environment: 0x10315b110>
> sort
standardGeneric for "sort" defined from package "base"

function (x, decreasing = FALSE, ...) 
standardGeneric("sort")
<environment: 0x10315b110>
Methods may be defined for arguments: x, decreasing
Use  showMethods("sort")  for currently available ones.
> ls(environment(sort), all.names = TRUE)
[1] ".AllMTable" ".Generic"   ".Methods"   ".MTable"    ".SigArgs"  
[6] ".SigLength"

.MTable (.AllMTable) から対応する signature のメソッドを探して実行するというのが S4 メソッドの dispatch の仕組みのようです。

.MTable には getMethodsForDispatch 関数でアクセスすることができます。

> identical(getMethodsForDispatch(sort), get(".MTable", environment(sort)))
[1] TRUE

.MTable には各 signature に対して1つの関数が割り当てられるようになっています。sort の場合は元々 S3 の sort 関数が定義されていたのに S4 の総称関数として再定義したこともあり、ANY という signature が最初から定義されているようです。

> ls(getMethodsForDispatch(sort))
[1] "ANY"
> setMethod("sort", signature(x = "numeric"), function(x) x)
[1] "sort"
> ls(getMethodsForDispatch(sort))
[1] "ANY"     "numeric"
> getMethodsForDispatch(sort)$numeric
Method Definition:

function (x, decreasing = FALSE, ...) 
{
    .local <- function (x) 
    x
    .local(x, ...)
}

Signatures:
        x        
target  "numeric"
defined "numeric"

何故キャッシュ制御機構が必要なのか?

insertSource でコールしている evalSource は sys.source で環境を指定した上で評価するわけですが、setGeneric はどの環境で評価しようと定義済みのものを使い回します。
よって、getGencric は where に指定した環境から generic を取得したとしても、既存のものと同じものを取得することになります。

> env <- evalSource("/path/to/int64.R")
> identical(getGeneric(sort, where = env), getGeneric(sort, where = globalenv()))
[1] TRUE

キャッシュが有効な場合にコールされている methods:::.cacheMethodInTable は getGeneric で generic を取得し、それに対応する .MTable などを書き換えるのでそれを避けたかったということでしょう。

S4 メソッドの dispatch には .MTable などが使われますが、.__T__sort:base のように各環境用の .MTable 的なものも存在するようです。何のために用意されているのかはよくわかりませんが・・・。
insertSource では .__T__sort:base に新しいメソッドの定義を保存し、.MTable のものと比較し、定義が異なれば trace の仕組みを使って変更するということをしたかったと思われます。

というわけでパッチ書いてみた

S4 についてはあまり理解できてないのであり得ない変更をしているかもしれませんがパッチを書いてみました。

diff -ru methods.orig/R/Methods.R methods/R/Methods.R
--- methods.orig/R/Methods.R	2013-03-24 02:16:45.000000000 +0900
+++ methods/R/Methods.R	2013-03-24 15:06:05.000000000 +0900
@@ -622,6 +622,19 @@
         if(is.not.base)
             .addToMetaTable(fdef, signature, definition, where, nSig)
         resetGeneric(f, fdef, mtable, gwhere, deflt) # Note: gwhere not used by resetGeneric
+    } else {
+        metaName <- paste0(methodsPackageMetaName("T", f), ":")
+        allObjects <- objects(where, all = TRUE)
+        target <- allObjects[grepl(metaName, allObjects, fixed = TRUE)]
+        if (length(target) > 0) {
+            table <- get(target, where)
+        } else {
+            table <- new.env()
+            assign(metaName, table, envir = where)
+        }
+        sig <- .matchSigLength(signature, fdef, fenv, FALSE)
+        label <- .sigLabel(sig)
+        assign(label, definition, envir = table)
     }
     ## assigns the methodslist object
     ## and deals with flags for primitives & for updating group members
diff -ru methods.orig/R/trace.R methods/R/trace.R
--- methods.orig/R/trace.R	2013-03-24 02:16:45.000000000 +0900
+++ methods/R/trace.R	2013-03-24 15:00:36.000000000 +0900
@@ -160,7 +160,7 @@
         def <- .untracedFunction(def)
     if(!is.null(signature)) {
         fdef <- if(is.primitive(def))  getGeneric(what, TRUE, where) else def
-        def <- selectMethod(what, signature, fdef = fdef, optional = TRUE)
+        def <- selectMethod(what, strsplit(signature, "#")[[1]], fdef = fdef, optional = TRUE)
         if(is.null(def)) {
             warning(gettextf("Can't untrace method for %s; no method defined for this signature: %s",
                              sQuote(what),
@@ -169,7 +169,7 @@
             return(def)
         }
         ## pick up signature with package slot from selectMethod
-        signature <- def@target
+        signature <- paste(def@target, collapse = "#")
     }
     if(untrace) {
         if(.traceTraceState) {
@@ -757,7 +757,7 @@
         }
     }
     .mnames <- allMethodTables()
-    if(length(methods) > 0) {
+    if(!missing(methods)) {
         notThere <- sapply(methods,
          function(fname) (length(grep(fname, .mnames, fixed = TRUE)) == 0)
         )
@@ -847,7 +847,7 @@
 .copyMethods <- function(f, tableName, env, envwhere) {
     differs <- function(o1, o2)
         !(is.function(o2) && # o2 can be NULL
-          identical(body(o2), body(o2)) && identical(args(o1), args(o2)))
+          identical(body(o1), body(o2)) && identical(args(o1), args(o2)))
     table <- get(tableName, envir=env)
     fdef <- getGeneric(f, where = envwhere)
     if(!is(fdef, "genericFunction")) {

パッチを適用したファイルの内容を insertSource で反映してみます。

> sources <- c("/path/to/trace.R", "/path/to/Methods.R")
> insertSource(sources, functions = c(".copyMethods", "insertSource", "setMethod", ".TraceWithMethods"))
Modified functions inserted through trace(): .copyMethods, insertSource, setMethod, .TraceWithMethods
> library(int64)
> insertSource("/path/to/int64.R", package = "int64", force = FALSE)
Non-function objects aren't currently inserted (not traceable): .packageName
Methods inserted for function sort(): int64
> sort(as.int64(sample(5)))
int64!
[1] 1 2 3 4 5

やりましたね!”int64!” が表示されました!!

実際、以下のように trace で内容が変更されていることも確認できます。

> selectMethod(sort, "int64")
Object of class "MethodDefinitionWithTrace", from source
function (x, decreasing = FALSE, ...) 
{
    cat("int64!\n")
    .Call(int64_sort, x, FALSE, decreasing)
}
<environment: namespace:int64>

## (to see original from package, look at object@original)

というわけで、このバグを bugzilla にファイルしました。
bug 15242 – insertSource doesn’t work against S4 methods