Commit bafaa5d4 authored by Radford Neal's avatar Radford Neal

fix bug regarding dropping dimnames for array subsetting, added tests

parent 4b399f4e
...@@ -247,11 +247,11 @@ SEXP allocArray(SEXPTYPE mode, SEXP dims) ...@@ -247,11 +247,11 @@ SEXP allocArray(SEXPTYPE mode, SEXP dims)
return array; return array;
} }
/* DropDims strips away redundant dimensioning information. */ /* DropDims strips away redundant dimensioning information. If there
/* If there is an appropriate dimnames attribute the correct */ is an appropriate dimnames attribute the correct element is
/* element is extracted and attached to the vector as a names */ extracted and attached to the vector as a names attribute. Note
/* attribute. Note that this function mutates x. */ that this function mutates x. Duplication should occur before this
/* Duplication should occur before this is called. */ is called. */
SEXP DropDims(SEXP x) SEXP DropDims(SEXP x)
{ {
......
...@@ -1877,7 +1877,7 @@ static SEXP MatrixSubset(SEXP x, SEXP subs, SEXP call, int drop, int64_t seq) ...@@ -1877,7 +1877,7 @@ static SEXP MatrixSubset(SEXP x, SEXP subs, SEXP call, int drop, int64_t seq)
static SEXP ArraySubset(SEXP x, SEXP s, SEXP call, int drop, SEXP xdims, int k) static SEXP ArraySubset(SEXP x, SEXP s, SEXP call, int drop, SEXP xdims, int k)
{ {
int i, j, ii, jj, n; int i, j, ii, jj, n;
SEXP dimnames, dimnamesnames, r, result; SEXP dimnames, r, result;
int mode = TYPEOF(x); int mode = TYPEOF(x);
int *subs[k], indx[k], nsubs[k], offset[k], suppress_drop[k]; int *subs[k], indx[k], nsubs[k], offset[k], suppress_drop[k];
...@@ -2022,7 +2022,6 @@ static SEXP ArraySubset(SEXP x, SEXP s, SEXP call, int drop, SEXP xdims, int k) ...@@ -2022,7 +2022,6 @@ static SEXP ArraySubset(SEXP x, SEXP s, SEXP call, int drop, SEXP xdims, int k)
SEXP newdimnames; SEXP newdimnames;
PROTECT(dimnames = getAttrib(x, R_DimNamesSymbol)); PROTECT(dimnames = getAttrib(x, R_DimNamesSymbol));
PROTECT(dimnamesnames = getAttrib(dimnames, R_NamesSymbol));
if (TYPEOF(dimnames) == VECSXP) { /* broken code for others in R-2.15.0 */ if (TYPEOF(dimnames) == VECSXP) { /* broken code for others in R-2.15.0 */
PROTECT(newdimnames = allocVector(VECSXP, k)); PROTECT(newdimnames = allocVector(VECSXP, k));
for (i = 0; i < k ; i++) { for (i = 0; i < k ; i++) {
...@@ -2033,7 +2032,10 @@ static SEXP ArraySubset(SEXP x, SEXP s, SEXP call, int drop, SEXP xdims, int k) ...@@ -2033,7 +2032,10 @@ static SEXP ArraySubset(SEXP x, SEXP s, SEXP call, int drop, SEXP xdims, int k)
} }
/* else leave as NULL for 0-length dims */ /* else leave as NULL for 0-length dims */
} }
SEXP dimnamesnames;
PROTECT(dimnamesnames = getAttrib(dimnames, R_NamesSymbol));
setAttrib(newdimnames, R_NamesSymbol, dimnamesnames); setAttrib(newdimnames, R_NamesSymbol, dimnamesnames);
UNPROTECT(1);
} }
else else
PROTECT(newdimnames = R_NilValue); PROTECT(newdimnames = R_NilValue);
...@@ -2048,13 +2050,11 @@ static SEXP ArraySubset(SEXP x, SEXP s, SEXP call, int drop, SEXP xdims, int k) ...@@ -2048,13 +2050,11 @@ static SEXP ArraySubset(SEXP x, SEXP s, SEXP call, int drop, SEXP xdims, int k)
if (rdims <= 1) { /* result is vector without dims, but maybe with names */ if (rdims <= 1) { /* result is vector without dims, but maybe with names */
if (newdimnames != R_NilValue) { if (newdimnames != R_NilValue) {
int w = -1; /* which dimension to take names from, -1 if none */ int w = -1; /* which dimension to take names from, neg if none */
for (i = 0; i < k; i++) { for (i = 0; i < k; i++) {
if (VECTOR_ELT(newdimnames,i) != R_NilValue) { if (VECTOR_ELT(newdimnames,i) != R_NilValue) {
if (w < 0 || nsubs[i] != 1 || suppress_drop[i]) if (nsubs[i] != 1 || suppress_drop[i]) {
w = i; w = i;
else if (!suppress_drop[w]) {
w = -1;
break; break;
} }
} }
...@@ -2078,7 +2078,7 @@ static SEXP ArraySubset(SEXP x, SEXP s, SEXP call, int drop, SEXP xdims, int k) ...@@ -2078,7 +2078,7 @@ static SEXP ArraySubset(SEXP x, SEXP s, SEXP call, int drop, SEXP xdims, int k)
UNPROTECT(1); /* newdims */ UNPROTECT(1); /* newdims */
} }
UNPROTECT(k+7); /* ... + result, dimnames, dimnamesnames, newdimnames, UNPROTECT(k+6); /* ... + result, dimnames, newdimnames,
x, s, xdims */ x, s, xdims */
R_scalar_stack = sv_scalar_stack; R_scalar_stack = sv_scalar_stack;
......
...@@ -84,3 +84,63 @@ dn <- dimnames(a3) ...@@ -84,3 +84,63 @@ dn <- dimnames(a3)
dn[2] <- list(NULL) dn[2] <- list(NULL)
dimnames(a3) <- dn dimnames(a3) <- dn
stopifnot(inherits(try(a3[ss], silent=TRUE), "try-error")) stopifnot(inherits(try(a3[ss], silent=TRUE), "try-error"))
# preservation of names.
a <- 1:24
names(a) <- letters[1:24]
stopifnot(identical(a[],a))
stopifnot(identical(a[3],c(c=3L)))
a <- matrix(1:24,6,4)
dimnames(a) <- list(LETTERS[11:16],letters[1:4])
s <- a[2:3,2:3]
r <- matrix(c(8L,9L,14L,15L),2,2)
dimnames(r) <- list(c("L","M"),c("b","c"))
stopifnot(identical(s,r))
s <- a[2:3,]
r <- matrix(c(2L,3L,8L,9L,14L,15L,20L,21L),2,4)
dimnames(r) <- list(c("L","M"),c("a","b","c","d"))
stopifnot(identical(s,r))
a <- array(1:24,c(2,3,4))
dimnames(a) <- list(LETTERS[1:2],letters[11:13],LETTERS[11:14])
s <- a[2,2:3,3:4]
r <- matrix(c(16L,18L,22L,24L),2,2)
dimnames(r) <- list(c("l","m"),c("M","N"))
stopifnot(identical(s,r))
s <- a[2,2,]
stopifnot(identical(s,c(K=4L,L=10L,M=16L,N=22L)))
a <- matrix(11:13,1,3)
dimnames(a) <- list("X",letters[1:3])
stopifnot(identical(a[1,2],12L))
stopifnot(identical(a[1,2:2],12L))
stopifnot(identical(a[1,2..2],c(b=12L)))
stopifnot(identical(a[1:1,2],12L))
stopifnot(identical(a[1..1,2],c(X=12L)))
stopifnot(identical(a[1,],c(a=11L,b=12L,c=13L)))
a <- array(11:13,c(1,3,1))
dimnames(a) <- list("X",letters[1:3],"Y")
stopifnot(identical(a[1,2,1],12L))
stopifnot(identical(a[1,2:2,1],12L))
stopifnot(identical(a[1,2..2,1],c(b=12L)))
stopifnot(identical(a[1:1,2,1],12L))
stopifnot(identical(a[1..1,2,1],c(X=12L)))
stopifnot(identical(a[1,,1],c(a=11L,b=12L,c=13L)))
a <- provideDimnames(array(5,c(2,5,2,5)))
s <- a[1:2,1:2,1:2,1:2]
r <- provideDimnames(array(5,c(2,2,2,2)))
stopifnot(identical(s,r))
R version 2.15.0 alpha (2012-03-02 r58556) pqR version 2.15.1 (2018-00-00), based on R 2.15.0 (2012-03-30)
Copyright (C) 2012 The R Foundation for Statistical Computing
R 2.15.0 is Copyright (C) 2012 The R Foundation for Statistical Computing
ISBN 3-900051-07-0 ISBN 3-900051-07-0
Modifications to R in pqR are Copyright (C) 2013-2018 Radford M. Neal
Some modules are from R-2.15.1 or later versions distributed by the R Core Team
Platform: x86_64-unknown-linux-gnu (64-bit) Platform: x86_64-unknown-linux-gnu (64-bit)
R is free software and comes with ABSOLUTELY NO WARRANTY. R is free software and comes with ABSOLUTELY NO WARRANTY.
...@@ -16,6 +22,9 @@ Type 'demo()' for some demos, 'help()' for on-line help, or ...@@ -16,6 +22,9 @@ Type 'demo()' for some demos, 'help()' for on-line help, or
'help.start()' for an HTML browser interface to help. 'help.start()' for an HTML browser interface to help.
Type 'q()' to quit R. Type 'q()' to quit R.
No helper threads, task merging enabled, uncompressed pointers.
> ## array subsetting tests > ## array subsetting tests
> ## > ##
> ## Tests should be written to raise an error on test failure > ## Tests should be written to raise an error on test failure
...@@ -103,3 +112,63 @@ Type 'q()' to quit R. ...@@ -103,3 +112,63 @@ Type 'q()' to quit R.
> dimnames(a3) <- dn > dimnames(a3) <- dn
> stopifnot(inherits(try(a3[ss], silent=TRUE), "try-error")) > stopifnot(inherits(try(a3[ss], silent=TRUE), "try-error"))
> >
>
> # preservation of names.
>
> a <- 1:24
> names(a) <- letters[1:24]
>
> stopifnot(identical(a[],a))
> stopifnot(identical(a[3],c(c=3L)))
>
> a <- matrix(1:24,6,4)
> dimnames(a) <- list(LETTERS[11:16],letters[1:4])
>
> s <- a[2:3,2:3]
> r <- matrix(c(8L,9L,14L,15L),2,2)
> dimnames(r) <- list(c("L","M"),c("b","c"))
> stopifnot(identical(s,r))
>
> s <- a[2:3,]
> r <- matrix(c(2L,3L,8L,9L,14L,15L,20L,21L),2,4)
> dimnames(r) <- list(c("L","M"),c("a","b","c","d"))
> stopifnot(identical(s,r))
>
> a <- array(1:24,c(2,3,4))
> dimnames(a) <- list(LETTERS[1:2],letters[11:13],LETTERS[11:14])
>
> s <- a[2,2:3,3:4]
> r <- matrix(c(16L,18L,22L,24L),2,2)
> dimnames(r) <- list(c("l","m"),c("M","N"))
> stopifnot(identical(s,r))
>
> s <- a[2,2,]
> stopifnot(identical(s,c(K=4L,L=10L,M=16L,N=22L)))
>
> a <- matrix(11:13,1,3)
> dimnames(a) <- list("X",letters[1:3])
>
> stopifnot(identical(a[1,2],12L))
> stopifnot(identical(a[1,2:2],12L))
> stopifnot(identical(a[1,2..2],c(b=12L)))
> stopifnot(identical(a[1:1,2],12L))
> stopifnot(identical(a[1..1,2],c(X=12L)))
>
> stopifnot(identical(a[1,],c(a=11L,b=12L,c=13L)))
>
> a <- array(11:13,c(1,3,1))
> dimnames(a) <- list("X",letters[1:3],"Y")
>
> stopifnot(identical(a[1,2,1],12L))
> stopifnot(identical(a[1,2:2,1],12L))
> stopifnot(identical(a[1,2..2,1],c(b=12L)))
> stopifnot(identical(a[1:1,2,1],12L))
> stopifnot(identical(a[1..1,2,1],c(X=12L)))
>
> stopifnot(identical(a[1,,1],c(a=11L,b=12L,c=13L)))
>
> a <- provideDimnames(array(5,c(2,5,2,5)))
> s <- a[1:2,1:2,1:2,1:2]
> r <- provideDimnames(array(5,c(2,2,2,2)))
> stopifnot(identical(s,r))
>
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment