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)
return array;
}
/* DropDims strips away redundant dimensioning information. */
/* If there is an appropriate dimnames attribute the correct */
/* element is extracted and attached to the vector as a names */
/* attribute. Note that this function mutates x. */
/* Duplication should occur before this is called. */
/* DropDims strips away redundant dimensioning information. If there
is an appropriate dimnames attribute the correct element is
extracted and attached to the vector as a names attribute. Note
that this function mutates x. Duplication should occur before this
is called. */
SEXP DropDims(SEXP x)
{
......
......@@ -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)
{
int i, j, ii, jj, n;
SEXP dimnames, dimnamesnames, r, result;
SEXP dimnames, r, result;
int mode = TYPEOF(x);
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)
SEXP newdimnames;
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 */
PROTECT(newdimnames = allocVector(VECSXP, k));
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)
}
/* else leave as NULL for 0-length dims */
}
SEXP dimnamesnames;
PROTECT(dimnamesnames = getAttrib(dimnames, R_NamesSymbol));
setAttrib(newdimnames, R_NamesSymbol, dimnamesnames);
UNPROTECT(1);
}
else
PROTECT(newdimnames = R_NilValue);
......@@ -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 (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++) {
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;
else if (!suppress_drop[w]) {
w = -1;
break;
}
}
......@@ -2078,7 +2078,7 @@ static SEXP ArraySubset(SEXP x, SEXP s, SEXP call, int drop, SEXP xdims, int k)
UNPROTECT(1); /* newdims */
}
UNPROTECT(k+7); /* ... + result, dimnames, dimnamesnames, newdimnames,
UNPROTECT(k+6); /* ... + result, dimnames, newdimnames,
x, s, xdims */
R_scalar_stack = sv_scalar_stack;
......
......@@ -84,3 +84,63 @@ dn <- dimnames(a3)
dn[2] <- list(NULL)
dimnames(a3) <- dn
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)
Copyright (C) 2012 The R Foundation for Statistical Computing
pqR version 2.15.1 (2018-00-00), based on R 2.15.0 (2012-03-30)
R 2.15.0 is Copyright (C) 2012 The R Foundation for Statistical Computing
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)
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
'help.start()' for an HTML browser interface to help.
Type 'q()' to quit R.
No helper threads, task merging enabled, uncompressed pointers.
> ## array subsetting tests
> ##
> ## Tests should be written to raise an error on test failure
......@@ -103,3 +112,63 @@ Type 'q()' to quit R.
> dimnames(a3) <- dn
> 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