[Rd] bug with mapply() on an S4 object

[Hervé Pagès]

Some formatting issues when copy/pasting the patch in the body of the
email so I've attached the diff file.

Cheers,
H.

On 11/27/2012 04:56 PM, Hervé Pagès wrote:
> Hi,
>
> Here is a patch for this (against current R-devel). The "caching" of
> the .Primitive for 'length' is taken from seq_along() C code (in
> R-devel/src/main/seq.c).
>
> hpages at thinkpad:~/svn/R$ svn diff R-devel
> Index: R-devel/src/main/mapply.c
> ===================================================================
> --- R-devel/src/main/mapply.c    (revision 61172)
> +++ R-devel/src/main/mapply.c    (working copy)
> @@ -32,14 +32,39 @@
>       int i, j, m, named, zero = 0;
>       R_xlen_t *lengths, *counters, longest = 0;
>       SEXP vnames, fcall = R_NilValue,  mindex, nindex, tmp1, tmp2, ans;
> +    static SEXP length_op = NULL;
>
> +    /* Store the .Primitive for 'length' for DispatchOrEval to use. */
> +    if (length_op == NULL) {
> +    SEXP R_lengthSymbol = install("length");
> +    length_op = eval(R_lengthSymbol, R_BaseEnv);
> +    if (TYPEOF(length_op) != BUILTINSXP) {
> +        length_op = NULL;
> +        error("'length' is not a BUILTIN");
> +    }
> +    R_PreserveObject(length_op);
> +    }
> +
>       m = length(varyingArgs);
>       vnames = PROTECT(getAttrib(varyingArgs, R_NamesSymbol));
>       named = vnames != R_NilValue;
>
>       lengths = (R_xlen_t *)  R_alloc(m, sizeof(R_xlen_t));
>       for(i = 0; i < m; i++){
> -    lengths[i] = xlength(VECTOR_ELT(varyingArgs, i));
> +    int dispatch_ok = 0;
> +    tmp1 = VECTOR_ELT(varyingArgs, i);
> +    if (isObject(tmp1)) {
> +        /* Looks like DispatchOrEval() needs a pairlist. We reproduce what
> +           pairlist(tmp1) would do i.e. tmp2 <- as.pairlist(list(tmp1)).
> +           Is there a more direct way to go from tmp1 to tmp2? */
> +        PROTECT(tmp2 = allocVector(VECSXP, 1));
> +        SET_VECTOR_ELT(tmp2, 0, tmp1);
> +        PROTECT(tmp2 = coerceVector(tmp2, LISTSXP));
> +        dispatch_ok = DispatchOrEval(call, length_op, "length",
> +                     tmp2, rho, &ans, 0, 1);
> +        UNPROTECT(2);
> +    }
> +    lengths[i] = dispatch_ok ? asInteger(ans) : xlength(tmp1);
>       if(lengths[i] == 0) zero++;
>       if (lengths[i] > longest) longest = lengths[i];
>       }
>
> Hopefully the bug can be fixed. Thanks!
> H.
>
>
> On 11/14/2012 09:42 PM, Hervé Pagès wrote:
>> Hi,
>>
>> Starting with ordinary vectors, so we know what to expect:
>>
>>    > mapply(function(x, y) {x * y}, 101:106, rep(1:3, 2))
>>    [1] 101 204 309 104 210 318
>>
>>    > mapply(function(x, y) {x * y}, 101:106, 1:3)
>>    [1] 101 204 309 104 210 318
>>
>> Now with an S4 object:
>>
>>    setClass("A", representation(aa="integer"))
>>    a <- new("A", aa=101:106)
>>
>>    > length(a)
>>    [1] 1
>>
>> Implementing length():
>>
>>    setMethod("length", "A", function(x) length(x at aa))
>>
>> Testing length():
>>
>>    > length(a)  # sanity check
>>    [1] 6
>>
>> No [[ yet for those objects so the following error is expected:
>>
>>    > mapply(function(x, y) {x * y}, a, rep(1:3, 2))
>>    Error in dots[[1L]][[1L]] : this S4 class is not subsettable
>>
>> Implementing [[:
>>
>>    setMethod("[[", "A", function(x, i, j, ...) x at aa[[i]])
>>
>> Testing [[:
>>
>>    > a[[1]]
>>    [1] 101
>>    > a[[5]]
>>    [1] 105
>>
>> Trying mapply again:
>>
>>    > mapply(function(x, y) {x * y}, a, rep(1:3, 2))
>>    [1] 101 202 303 101 202 303
>>
>> Wrong. It looks like internally a[[1]] is always used instead of a[[i]].
>>
>> The real problem it seems is that 'a' is treated as if it was of
>> length 1:
>>
>>    > mapply(function(x, y) {x * y}, a, 1:3)
>>    [1] 101 202 303
>>    > mapply(function(x, y) {x * y}, a, 5)
>>    [1] 505
>>
>> In other words, internal dispatch works for [[ but not for length().
>>
>> Thanks,
>> H.
>>
>

-- 
Hervé Pagès

Program in Computational Biology
Division of Public Health Sciences
Fred Hutchinson Cancer Research Center
1100 Fairview Ave. N, M1-B514
P.O. Box 19024
Seattle, WA 98109-1024

E-mail: hpages at fhcrc.org
Phone:  (206) 667-5791
Fax:    (206) 667-1319
-------------- next part --------------
A non-text attachment was scrubbed...
Name: mapply.diff
Type: text/x-patch
Size: 1657 bytes
Desc: not available
URL: <https://stat.ethz.ch/pipermail/r-devel/attachments/20121127/0c37502e/attachment.bin>