R devel - Dec 2013 - S4 method for '[' with extra arguments: distinguishing between x[i] and x[i, ]

Hi,

I want to implement a '[' for an S4 class, that behaves differently
when called with a single index argument or multiple indexes (possibly
missing), like what happens when subsetting matrices x[i] vs. x[i, ].

I manage to do it using nargs() and checking if drop is missing (see
code below), but when I want to add an extra argument to the method
(before drop), then the parent call somehow changes and always
includes all indexes in the call (even missing ones) and nargs()
always returns the same value.

I thought there might be a generic for a single index (with no j in
the definition) but could not find its definition, and can't see how
setMethod will know for which '[' to define the method. Defining a
method for signature(x = 'A', j = 'missing') has the same issue.

Is there actually a way to do this?
Thank you.

Bests,
Renaud


####
# Code
####

# Class A
setClass('A', contains = 'character')

# No extra argument is fine
setMethod('[', 'A', function(x, i, j, ..., drop = TRUE){
            ca <- match.call()
            mdrop <- missing(drop)
            Nargs <- nargs() - !mdrop
            print(ca)
            print(nargs())
            print(mdrop)
            print(Nargs)
            if( !missing(i) && Nargs < 3 ) TRUE
            else FALSE
        })

testA <- function(){
    a <- new('A')
    tests <- c('a[1]', 'a[1,]', 'a[,1]')
    sapply(tests, function(s){
        message('\n#', s); message('single arg: ',
eval(parse(text = s)))
        s <- sub(']', ', drop = FALSE]', s, fixed = TRUE)
        message('\n#', s); message('single arg: ',
eval(parse(text = s)))
    })
    invisible()
}

testA()

# with extra argument => cannot distinguish the calls
setMethod('[', 'A', function(x, i, j, ..., extra = FALSE, drop =
TRUE){
            ca <- match.call()
            mdrop <- missing(drop)
            Nargs <- nargs() - !mdrop
            print(ca)
            print(nargs())
            print(mdrop)
            print(Nargs)
            if( !missing(i) && Nargs < 3 ) TRUE
            else FALSE
        })

testA()

# System info
sessionInfo()
R.version


####
# RESULTS
####
> # Class A
> setClass('A', contains = 'character')
>
> # No extra argument is fine
> setMethod('[', 'A', function(x, i, j, ..., drop = TRUE){
+             ca <- match.call()
+             mdrop <- missing(drop)
+             Nargs <- nargs() - !mdrop
+             print(ca)
+             print(nargs())
+             print(mdrop)
+             print(Nargs)
+             if( !missing(i) && Nargs < 3 ) TRUE
+             else FALSE
+         })
[1] "["
>
> testA <- function(){
+     a <- new('A')
+     tests <- c('a[1]', 'a[1,]', 'a[,1]')
+     sapply(tests, function(s){
+         message('\n#', s); message('single arg: ',
eval(parse(text = s)))
+         s <- sub(']', ', drop = FALSE]', s, fixed = TRUE)
+         message('\n#', s); message('single arg: ',
eval(parse(text = s)))
+     })
+     invisible()
+ }
>
> testA()
#a[1]
a[i = 1]
[1] 2
[1] TRUE
[1] 2
single arg: TRUE

#a[1, drop = FALSE]
a[i = 1, drop = FALSE]
[1] 3
[1] FALSE
[1] 2
single arg: TRUE

#a[1,]
a[i = 1]
[1] 3
[1] TRUE
[1] 3
single arg: FALSE

#a[1,, drop = FALSE]
a[i = 1, drop = FALSE]
[1] 4
[1] FALSE
[1] 3
single arg: FALSE

#a[,1]
a[j = 1]
[1] 3
[1] TRUE
[1] 3
single arg: FALSE

#a[,1, drop = FALSE]
a[j = 1, drop = FALSE]
[1] 4
[1] FALSE
[1] 3
single arg: FALSE
>
> # with extra argument => cannot distinguish the calls
> setMethod('[', 'A', function(x, i, j, ..., extra = FALSE,
drop = TRUE){
+             ca <- match.call()
+             mdrop <- missing(drop)
+             Nargs <- nargs() - !mdrop
+             print(ca)
+             print(nargs())
+             print(mdrop)
+             print(Nargs)
+             if( !missing(i) && Nargs < 3 ) TRUE
+             else FALSE
+         })
[1] "["
>
> testA()
#a[1]
.local(x = x, i = i, j = j, drop = drop)
[1] 4
[1] FALSE
[1] 3
single arg: FALSE

#a[1, drop = FALSE]
.local(x = x, i = i, j = j, drop = drop)
[1] 4
[1] FALSE
[1] 3
single arg: FALSE

#a[1,]
.local(x = x, i = i, j = j, drop = drop)
[1] 4
[1] FALSE
[1] 3
single arg: FALSE

#a[1,, drop = FALSE]
.local(x = x, i = i, j = j, drop = drop)
[1] 4
[1] FALSE
[1] 3
single arg: FALSE

#a[,1]
.local(x = x, i = i, j = j, drop = drop)
[1] 4
[1] FALSE
[1] 3
single arg: FALSE

#a[,1, drop = FALSE]
.local(x = x, i = i, j = j, drop = drop)
[1] 4
[1] FALSE
[1] 3
single arg: FALSE
>
> # System info
> sessionInfo()
R version 3.0.2 (2013-09-25)
Platform: x86_64-pc-linux-gnu (64-bit)

locale:
 [1] LC_CTYPE=en_US.UTF-8       LC_NUMERIC=C
 [3] LC_TIME=en_US.UTF-8        LC_COLLATE=en_US.UTF-8
 [5] LC_MONETARY=en_US.UTF-8    LC_MESSAGES=en_US.UTF-8
 [7] LC_PAPER=en_US.UTF-8       LC_NAME=C
 [9] LC_ADDRESS=C               LC_TELEPHONE=C
[11] LC_MEASUREMENT=en_US.UTF-8 LC_IDENTIFICATION=C

attached base packages:
[1] stats     graphics  grDevices utils     datasets  methods  
base
> R.version
               _
platform       x86_64-pc-linux-gnu
arch           x86_64
os             linux-gnu
system         x86_64, linux-gnu
status
major          3
minor          0.2
year           2013
month          09
day            25
svn rev        63987
language       R
version.string R version 3.0.2 (2013-09-25)
nickname       Frisbee Sailing
>