From: Hervé Pagès <hpages_at_fhcrc.org>

Date: Tue, 27 Nov 2012 16:56:59 -0800

Date: Tue, 27 Nov 2012 16:56:59 -0800

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 ______________________________________________ R-devel_at_r-project.org mailing list https://stat.ethz.ch/mailman/listinfo/r-develReceived on Wed 28 Nov 2012 - 01:13:14 GMT

This quarter's messages: by month, or sorted: [ by date ] [ by thread ] [ by subject ] [ by author ]

*
Archive maintained by Robert King, hosted by
the discipline of
statistics at the
University of Newcastle,
Australia.
Archive generated by hypermail 2.2.0, at Wed 28 Nov 2012 - 11:12:03 GMT.
*

*
Mailing list information is available at https://stat.ethz.ch/mailman/listinfo/r-devel.
Please read the posting
guide before posting to the list.
*