メモ：S3のクラスでS4のメソッドをディスパッチする

R S4

ちょっと気になったのでメモ。

準備

クラス定義をつくる

setClass("Greeting")
.EG <- setClass("EnglishGreeting", contains = "Greeting")
.JG <- setClass("JapaneseGreeting", contains = "Greeting")
.NG <- setClass("NinjaGreeting", contains = "Greeting")

# メソッドを定義してみるテスト
setGeneric("sanzuke", function(x, to) standardGeneric("sanzuke"))
#> [1] "sanzuke"
setMethod("sanzuke", "Greeting", function(x, to) to)
#> [1] "sanzuke"
# EnglishGreetingにはメソッドがない。スーパークラスのメソッドがディスパッチされる。
setMethod("sanzuke", "JapaneseGreeting", function(x, to) paste0(to, "さん"))
#> [1] "sanzuke"
setMethod("sanzuke", "NinjaGreeting", function(x, to) paste0(to, "=サン"))
#> [1] "sanzuke"

# インスタンスをつくる
eg <- .EG()
jg <- .JG()
ng <- .NG()

# どれも予想通り動く
sanzuke(eg, "V8")
#> [1] "V8"
sanzuke(jg, "V8")
#> [1] "V8さん"
sanzuke(ng, "V8")
#> [1] "V8=サン"

# メソッドを定義してみるテストその2、今度はすべてにメソッドがある
setGeneric("doGreet", function(x, to) standardGeneric("doGreet"))
#> [1] "doGreet"
setMethod("doGreet", "Greeting", function(x, to) stop("Not implemented"))
#> [1] "doGreet"
setMethod("doGreet", "EnglishGreeting", function(x, to) cat(glue::glue("Hello, {sanzuke(x, to)}")))
#> [1] "doGreet"
setMethod("doGreet", "JapaneseGreeting", function(x, to) cat(glue::glue("こんにちは、{sanzuke(x, to)}")))
#> [1] "doGreet"
setMethod("doGreet", "NinjaGreeting", function(x, to) cat(glue::glue("ドーモ、{sanzuke(x, to)}")))
#> [1] "doGreet"

doGreet(eg, "V8")
#> Hello, V8
doGreet(jg, "V8")
#> こんにちは、V8さん
doGreet(ng, "V8")
#> ドーモ、V8=サン

S4クラス用に定義されたメソッドをS3クラスでディスパッチする

dummy_ng <- structure(list(), class = "NinjaGreeting")
doGreet(dummy_ng, "V8")
#> ドーモ、V8=サン

# classには`EnglishGreeting`しか書いてないが、ちゃんとGreetingのメソッドをディスパッチできている
dummy_eg <- structure(list(), class = "EnglishGreeting")
doGreet(dummy_eg, "V8")
#> Hello, V8

S3のクラスをシグネチャに使ってS4のメソッドを定義する

# 特殊なS3クラスを作ってみる
nm <- "V8"
class(nm) <- "god_name"

# 警告は出るけどシグネチャとして使える
setMethod("doGreet", c("EnglishGreeting", "god_name"), function(x, to) cat(glue::glue("Praise the {sanzuke(x, to)}!!")))
#> in method for 'doGreet' with signature '"EnglishGreeting","god_name"': no definition for class "god_name"
#> [1] "doGreet"
doGreet(dummy_eg, nm)
#> Praise the V8!!

# setOldClassしておくと警告は出ない
setOldClass("god_name")
setMethod("doGreet", c("EnglishGreeting", "god_name"), function(x, to) cat(glue::glue("Praise the {sanzuke(x, to)}!!")))
#> [1] "doGreet"

参考

このへん？