Групповые общие методы для Ops (для временных рядов)

Question

Я пытаюсь определить наследование класса Ops для класса S3, который представляет собой список и имеет временной ряд внутри списка.

      tsnewobject_a <- structure(list(data=ts(1:10,frequency=4,start=2010)),
                           class="newclass")
tsnewobject_b <- structure(list(data=ts(10:1,frequency=4,start=2010)),
                           class="newclass")

## Step 1 : with S3 only (note : I don't want to modify Ops.ts)

Ops.newclass <- function(e1,e2) {
  if (inherits(e1,"newclass")) e1 <- e1$data
  if (inherits(e2,"newclass")) e2 <- e2$data
  get(.Generic)(e1,e2)
}

tsnewobject_a+tsnewobject_b
#      Qtr1 Qtr2 Qtr3 Qtr4
# 2010   11   11   11   11
# 2011   11   11   11   11
# 2012   11   11 

# It works !

tsnewobject_a+1
#      Qtr1 Qtr2 Qtr3 Qtr4
# 2010    2    3    4    5
# 2011    6    7    8    9
# 2012   10   11 

# It works !

1+tsnewobject_a
#      Qtr1 Qtr2 Qtr3 Qtr4
# 2010    2    3    4    5
# 2011    6    7    8    9
# 2012   10   11 

# It works !

tsnewobject_a+ts(1:10,frequency=4,start=2010)
# Error in tsnewobject_a + ts(1:10, frequency = 4, start = 2010) : 
#   non-numeric argument to binary operator
# In addition: Warning message:
# Incompatible methods ("Ops.newclass", "Ops.ts") for "+" 

# It doesn't work (it's expected)

ts(1:10,frequency=4,start=2010)+tsnewobject_a
# Error in ts(1:10, frequency = 4, start = 2010) + tsnewobject_a : 
#   non-numeric argument to binary operator
# In addition: Warning message:
# Incompatible methods ("Ops.ts", "Ops.newclass") for "+" 

# It doesn't work (it's expected)

Из-за двойной отправки S3 простой метод не работает. И поскольку я не хочу переопределять Ops.ts (это для пакета), мне нужно что-то найти.

      ## Step 2 : setOldClass to complete S3 with a small s4 fix

setOldClass("newclass")
setMethod("Ops",signature = c("newclass","ts"),function(e1,e2) callGeneric(e1$data,e2))
setMethod("Ops",signature = c("ts","newclass"),function(e1,e2) callGeneric(e1,e2$data))

tsnewobject_a+ts(1:10,frequency=4,start=2010)

# Error in tsnewobject_a + ts(1:10, frequency = 4, start = 2010) : 
#   non-numeric argument to binary operator
# In addition: Warning message:
# Incompatible methods ("Ops.newclass", "Ops.ts") for "+" 

# Still doesn't work

ts(1:10,frequency=4,start=2010)+tsnewobject_a

# Error in ts(1:10, frequency = 4, start = 2010) + tsnewobject_a : 
#   non-numeric argument to binary operator
# In addition: Warning message:
# Incompatible methods ("Ops.ts", "Ops.newclass") for "+" 

# Still doesn't work

Мне это кажется странным, так как Ops является общим для группы S4. Разве он не должен вызывать доступные методы S4, а затем, если их нет, перейти к S3? Что происходит и как это можно исправить?

Answer 1

ЧленыOpsгруппы являются внутренне общими. Отправка осуществляется функцией C-уровняDispatchGroup, который ищет методы S4, только если один или оба аргумента являются объектом S4.setOldClass("newclass")не делаетisS4(<newclass>)true, поэтому ваши методы S4 никогда не отправляются:

      setOldClass("newclass")
isS4(structure(0, class = "newclass"))
## [1] FALSE

Чтобы это работало, определитеnewclassкак подкласс S4ts, который уже имеет определение S4 в методах пакета :

      showClass("ts") # has slots .Data, tsp, .S3Class
setClass("newclass", contains = "ts")
showClass("newclass")

setAs("ts", "S3", 
      function(from) {
          if (isS4(from)) 
              structure(from@.Data, tsp = from@tsp, class = "ts") 
          else from
      })
setAs("ts", "S4",
      function(from) {
          if (isS4(from)) 
              from 
          else {
              dat. <- as.vector(from)
              tsp. <- tsp(from)
              new("ts", data = dat., start = tsp.[1L], end = tsp.[2L], frequency = tsp.[3L])
          }
      })
setMethod("Ops", c("ts", "ts"), 
          function(e1, e2) {
              callGeneric(if (isS4(e1)) as(e1, "S3") else e1,
                          if (isS4(e2)) as(e2, "S3") else e2)
          })

a <- ts(1:10, start = 2010, frequency = 4)
b <- as(a, "S4")

aa <- a + a
identical(a + b, aa)
## [1] TRUE
identical(b + a, aa)
## [1] TRUE
identical(b + b, aa)
## [1] TRUE

Соответствующую информацию вы найдете в?setOldClass,?S3Part, и?`ts-class`, но все немного разбросано.

---

PS: Я определил свои собственные методы приведения, потому что методы, унаследованные от методов пакета , похоже, не работали так, как описано в документации. Я собираюсь изучить еще немного, на случай, если я ошибаюсь (что часто случается), и в этом случае я отредактирую ответ.