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



	return VECTOR(dimnames)[0];
    else if (TYPEOF(dimnames) == LISTSXP)
	return CAR(dimnames);
    else
	return R_NilValue;
}
 
SEXP GetColNames(SEXP dimnames)
{
    if (TYPEOF(dimnames) == VECSXP)
	return VECTOR(dimnames)[1];
    else if (TYPEOF(dimnames) == LISTSXP)
	return CADR(dimnames);
    else
	return R_NilValue;
}
 
SEXP do_matrix(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    SEXP vals, snr, snc;

	    ((lendat < nr) && (nr / lendat) * lendat != nr))
	    warning("Replacement length not a multiple of the elements to replace in matrix(...) \n");
	else if (((lendat > nc) && (lendat / nc) * nc != lendat) ||
		 ((lendat < nc) && (nc / lendat) * lendat != nc))
	    warning("Replacement length not a multiple of the elements to replace in matrix(...) \n");
    }
	else if ((lendat > 1) && (nr * nc == 0)){
	  warning("Replacement length not a multiple of the elements to replace in matrix(...) \n");
	}
	else if (lendat == 0 && nr * nc > 0){
	  error("No data to replace in matrix(...)\n");

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

	UNPROTECT(1);
    }
    else {
	/* We have a lower dimensional array. */
	SEXP newdims, newdimnames;
 
	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) {

	ncx = 0;
	if (PRIMVAL(op) == 0) {
	    if (LENGTH(x) == nry) {
		nrx = 1;
		ncx = LENGTH(x);
	    }
	    else if (LENGTH(x) == ncy) {
		ncx=1;
		nrx=LENGTH(x);
	    }
	    if (nry * ncy == 1) {

Rev 1881	Rev 2213
Line 36...	Line 36...
36	`return VECTOR(dimnames)[0];`	36	`return VECTOR(dimnames)[0];`
37	`else if (TYPEOF(dimnames) == LISTSXP)`	37	`else if (TYPEOF(dimnames) == LISTSXP)`
38	`return CAR(dimnames);`	38	`return CAR(dimnames);`
39	`else`	39	`else`
40	`return R_NilValue;`	40	`return R_NilValue;`
41	`}`	41	`}`
42		42
43	`SEXP GetColNames(SEXP dimnames)`	43	`SEXP GetColNames(SEXP dimnames)`
44	`{`	44	`{`
45	`if (TYPEOF(dimnames) == VECSXP)`	45	`if (TYPEOF(dimnames) == VECSXP)`
46	`return VECTOR(dimnames)[1];`	46	`return VECTOR(dimnames)[1];`
47	`else if (TYPEOF(dimnames) == LISTSXP)`	47	`else if (TYPEOF(dimnames) == LISTSXP)`
48	`return CADR(dimnames);`	48	`return CADR(dimnames);`
49	`else`	49	`else`
50	`return R_NilValue;`	50	`return R_NilValue;`
51	`}`	51	`}`
52		52
53	`SEXP do_matrix(SEXP call, SEXP op, SEXP args, SEXP rho)`	53	`SEXP do_matrix(SEXP call, SEXP op, SEXP args, SEXP rho)`
54	`{`	54	`{`
55	`SEXP vals, snr, snc;`	55	`SEXP vals, snr, snc;`
Line 79...	Line 79...
79	`((lendat < nr) && (nr / lendat) * lendat != nr))`	79	`((lendat < nr) && (nr / lendat) * lendat != nr))`
80	`warning("Replacement length not a multiple of the elements to replace in matrix(...) \n");`	80	`warning("Replacement length not a multiple of the elements to replace in matrix(...) \n");`
81	`else if (((lendat > nc) && (lendat / nc) * nc != lendat) \|\|`	81	`else if (((lendat > nc) && (lendat / nc) * nc != lendat) \|\|`
82	`((lendat < nc) && (nc / lendat) * lendat != nc))`	82	`((lendat < nc) && (nc / lendat) * lendat != nc))`
83	`warning("Replacement length not a multiple of the elements to replace in matrix(...) \n");`	83	`warning("Replacement length not a multiple of the elements to replace in matrix(...) \n");`
84	`}`	84	`}`
85	`else if ((lendat > 1) && (nr * nc == 0)){`	85	`else if ((lendat > 1) && (nr * nc == 0)){`
86	`warning("Replacement length not a multiple of the elements to replace in matrix(...) \n");`	86	`warning("Replacement length not a multiple of the elements to replace in matrix(...) \n");`
87	`}`	87	`}`
88	`else if (lendat == 0 && nr * nc > 0){`	88	`else if (lendat == 0 && nr * nc > 0){`
89	`error("No data to replace in matrix(...)\n");`	89	`error("No data to replace in matrix(...)\n");`
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 p, q, dims, dimnames;`	144	`SEXP q, dims, dimnames;`
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 197...	Line 197...
197	`UNPROTECT(1);`	197	`UNPROTECT(1);`
198	`}`	198	`}`
199	`else {`	199	`else {`
200	`/* We have a lower dimensional array. */`	200	`/* We have a lower dimensional array. */`
201	`SEXP newdims, newdimnames;`	201	`SEXP newdims, newdimnames;`
202	`int j = 0;`	-
203	`PROTECT(newdims = allocVector(INTSXP, n));`	202	`PROTECT(newdims = allocVector(INTSXP, n));`
204	`for (i = 0, n = 0; i < ndims; i++)`	203	`for (i = 0, n = 0; i < ndims; i++)`
205	`if (INTEGER(dims)[i] != 1)`	204	`if (INTEGER(dims)[i] != 1)`
206	`INTEGER(newdims)[n++] = INTEGER(dims)[i];`	205	`INTEGER(newdims)[n++] = INTEGER(dims)[i];`
207	`if (dimnames != R_NilValue) {`	206	`if (dimnames != R_NilValue) {`
Line 453...	Line 452...
453	`ncx = 0;`	452	`ncx = 0;`
454	`if (PRIMVAL(op) == 0) {`	453	`if (PRIMVAL(op) == 0) {`
455	`if (LENGTH(x) == nry) {`	454	`if (LENGTH(x) == nry) {`
456	`nrx = 1;`	455	`nrx = 1;`
457	`ncx = LENGTH(x);`	456	`ncx = LENGTH(x);`
458	`}`	457	`}`
459	`else if (LENGTH(x) == ncy) {`	458	`else if (LENGTH(x) == ncy) {`
460	`ncx=1;`	459	`ncx=1;`
461	`nrx=LENGTH(x);`	460	`nrx=LENGTH(x);`
462	`}`	461	`}`
463	`if (nry * ncy == 1) {`	462	`if (nry * ncy == 1) {`

The R Project SVN R

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