The R Project SVN – R – Diff – /trunk/src/main/array.c



/*
 *  R : A Computer Language for Statistical Data Analysis
 *  Copyright (C) 1995, 1996  Robert Gentleman and Ross Ihaka
 *
 *  This program is free software; you can redistribute it and/or modify
 *  it under the terms of the GNU General Public License as published by
 *  the Free Software Foundation; either version 2 of the License, or

/* attribute.  Note that this function mutates x. */
/* Duplication should occur before this is called. */
 
SEXP DropDims(SEXP x)
{
    SEXP q, dims, dimnames, newnames = R_NilValue;
    int i, n, ndims;
 
    PROTECT(x);
    dims = getAttrib(x, R_DimSymbol);
    dimnames = getAttrib(x, R_DimNamesSymbol);

	return x;
    }
 
    if (n <= 1) {
	/* We have reduced to a vector result. */
 
	if (dimnames != R_NilValue) {
	    n = length(dims);
	    if (TYPEOF(dimnames) == VECSXP) {
		for (i = 0; i < n; i++) {
		    if (INTEGER(dims)[i] != 1) {

	setAttrib(x, R_NamesSymbol, newnames);
	UNPROTECT(1);
    }
    else {
	/* We have a lower dimensional array. */
	SEXP newdims;
	PROTECT(newdims = allocVector(INTSXP, n));
	for (i = 0, n = 0; i < ndims; i++)
	    if (INTEGER(dims)[i] != 1)
		INTEGER(newdims)[n++] = INTEGER(dims)[i];
	if (dimnames != R_NilValue) {
	    int havenames = 0;
	    for (i = 0; i < ndims; i++)
		if (INTEGER(dims)[i] != 1 && VECTOR(dimnames)[i] != R_NilValue)
		    havenames = 1;
	    if (havenames) {
		newnames = allocVector(VECSXP, n);
		for (i = 0, n= 0; i < ndims; i++) {
		    if (INTEGER(dims)[i] != 1)
			VECTOR(newnames)[n++] = VECTOR(dimnames)[i];
		}
	    }
	    else dimnames = R_NilValue;
	}
	PROTECT(dimnames);
	setAttrib(x, R_DimNamesSymbol, R_NilValue);
	setAttrib(x, R_DimSymbol, newdims);
	if (dimnames != R_NilValue)
	    setAttrib(x, R_DimNamesSymbol, newnames);
 
	UNPROTECT(2);
    }
    UNPROTECT(1);
    return x;
}

Rev 2213	Rev 2506
Line 1...	Line 1...
1	`/*`	1	`/*`
2	`* R : A Computer Langage for Statistical Data Analysis`	2	`* R : A Computer Language for Statistical Data Analysis`
3	`* Copyright (C) 1995, 1996 Robert Gentleman and Ross Ihaka`	3	`* Copyright (C) 1995, 1996 Robert Gentleman and Ross Ihaka`
4	`*`	4	`*`
5	`* This program is free software; you can redistribute it and/or modify`	5	`* This program is free software; you can redistribute it and/or modify`
6	`* it under the terms of the GNU General Public License as published by`	6	`* it under the terms of the GNU General Public License as published by`
7	`* the Free Software Foundation; either version 2 of the License, or`	7	`* the Free Software Foundation; either version 2 of the License, or`
Line 139...	Line 139...
139	`/* attribute. Note that this function mutates x. */`	139	`/* attribute. Note that this function mutates x. */`
140	`/* Duplication should occur before this is called. */`	140	`/* Duplication should occur before this is called. */`
141		141
142	`SEXP DropDims(SEXP x)`	142	`SEXP DropDims(SEXP x)`
143	`{`	143	`{`
144	`SEXP q, dims, dimnames;`	144	`SEXP q, dims, dimnames, newnames = R_NilValue;`
145	`int i, n, ndims;`	145	`int i, n, ndims;`
146		146
147	`PROTECT(x);`	147	`PROTECT(x);`
148	`dims = getAttrib(x, R_DimSymbol);`	148	`dims = getAttrib(x, R_DimSymbol);`
149	`dimnames = getAttrib(x, R_DimNamesSymbol);`	149	`dimnames = getAttrib(x, R_DimNamesSymbol);`
Line 166...	Line 166...
166	`return x;`	166	`return x;`
167	`}`	167	`}`
168		168
169	`if (n <= 1) {`	169	`if (n <= 1) {`
170	`/* We have reduced to a vector result. */`	170	`/* We have reduced to a vector result. */`
171	`SEXP newnames = R_NilValue;`	-
172	`if (dimnames != R_NilValue) {`	171	`if (dimnames != R_NilValue) {`
173	`n = length(dims);`	172	`n = length(dims);`
174	`if (TYPEOF(dimnames) == VECSXP) {`	173	`if (TYPEOF(dimnames) == VECSXP) {`
175	`for (i = 0; i < n; i++) {`	174	`for (i = 0; i < n; i++) {`
176	`if (INTEGER(dims)[i] != 1) {`	175	`if (INTEGER(dims)[i] != 1) {`
Line 196...	Line 195...
196	`setAttrib(x, R_NamesSymbol, newnames);`	195	`setAttrib(x, R_NamesSymbol, newnames);`
197	`UNPROTECT(1);`	196	`UNPROTECT(1);`
198	`}`	197	`}`
199	`else {`	198	`else {`
200	`/* We have a lower dimensional array. */`	199	`/* We have a lower dimensional array. */`
201	`SEXP newdims, newdimnames;`	200	`SEXP newdims;`
202	`PROTECT(newdims = allocVector(INTSXP, n));`	201	`PROTECT(newdims = allocVector(INTSXP, n));`
203	`for (i = 0, n = 0; i < ndims; i++)`	202	`for (i = 0, n = 0; i < ndims; i++)`
204	`if (INTEGER(dims)[i] != 1)`	203	`if (INTEGER(dims)[i] != 1)`
205	`INTEGER(newdims)[n++] = INTEGER(dims)[i];`	204	`INTEGER(newdims)[n++] = INTEGER(dims)[i];`
206	`if (dimnames != R_NilValue) {`	205	`if (dimnames != R_NilValue) {`
207	`int havenames = 0;`	206	`int havenames = 0;`
208	`for (i = 0; i < ndims; i++)`	207	`for (i = 0; i < ndims; i++)`
209	`if (INTEGER(dims)[i] != 1 && VECTOR(dimnames)[i] != R_NilValue)`	208	`if (INTEGER(dims)[i] != 1 && VECTOR(dimnames)[i] != R_NilValue)`
210	`havenames = 1;`	209	`havenames = 1;`
211	`if (havenames) {`	210	`if (havenames) {`
212	`newdimnames = allocVector(VECSXP, n);`	211	`newnames = allocVector(VECSXP, n);`
213	`for (i = 0, n= 0; i < ndims; i++) {`	212	`for (i = 0, n= 0; i < ndims; i++) {`
214	`if (INTEGER(dims)[i] != 1)`	213	`if (INTEGER(dims)[i] != 1)`
215	`VECTOR(newdimnames)[n++] = VECTOR(dimnames)[i];`	214	`VECTOR(newnames)[n++] = VECTOR(dimnames)[i];`
216	`}`	215	`}`
217	`}`	216	`}`
218	`else dimnames = R_NilValue;`	217	`else dimnames = R_NilValue;`
219	`}`	218	`}`
220	`PROTECT(dimnames);`	219	`PROTECT(dimnames);`
221	`setAttrib(x, R_DimNamesSymbol, R_NilValue);`	220	`setAttrib(x, R_DimNamesSymbol, R_NilValue);`
222	`setAttrib(x, R_DimSymbol, newdims);`	221	`setAttrib(x, R_DimSymbol, newdims);`
223	`if (dimnames != R_NilValue) {`	222	`if (dimnames != R_NilValue)`
224	`setAttrib(x, R_DimNamesSymbol, newdimnames);`	223	`setAttrib(x, R_DimNamesSymbol, newnames);`
225	`}`	-
226	`UNPROTECT(2);`	224	`UNPROTECT(2);`
227	`}`	225	`}`
228	`UNPROTECT(1);`	226	`UNPROTECT(1);`
229	`return x;`	227	`return x;`
230	`}`	228	`}`

The R Project SVN R

(root)/trunk/src/main/array.c @ 28362 – Rev 2213 → 2506