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



    snc = CADDR(args);
    byrow = asInteger(CADR(CDDR(args)));
 
    if (isVector(vals) || isList(vals)) {
	if (length(vals) < 0)
	    errorcall(call, "argument has length zero");
    }
    else errorcall(call, "invalid matrix element type");
 
    if (!isNumeric(snr) || !isNumeric(snc))
	error("non-numeric matrix extent");
 
    lendat = length(vals);
    nr = asInteger(snr);
    nc = asInteger(snc);
 
    if (lendat > 1 && (nr * nc) % lendat != 0) {
	if (((lendat > nr) && (lendat / nr) * nr != lendat) ||
	    ((lendat < nr) && (nr / lendat) * lendat != nr))
	    warning("Replacement length not a multiple of the elements to replace in matrix(...)");
	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(...)");
    }
	else if ((lendat > 1) && (nr * nc == 0)){
	  warning("Replacement length not a multiple of the elements to replace in matrix(...)");
	}
	else if (lendat == 0 && nr * nc > 0){
	  error("No data to replace in matrix(...)");
	}
 
    PROTECT(snr = allocMatrix(TYPEOF(vals), nr, nc));
    if (isVector(vals))
	copyMatrix(snr, vals, byrow);

{
    SEXP s, t;
    int n;
 
    if (nrow < 0 || ncol < 0)
	error("negative extents to matrix");
    n = nrow * ncol;
    PROTECT(s = allocVector(mode, n));
    PROTECT(t = allocVector(INTSXP, 2));
    INTEGER(t)[0] = nrow;
    INTEGER(t)[1] = ncol;

 
SEXP do_length(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    SEXP ans;
    if (length(args) != 1)
	error("incorrect number of args to length");
    ans = allocVector(INTSXP, 1);
    INTEGER(ans)[0] = length(CAR(args));
    return ans;
}
 

{
    SEXP ans;
    int i, j, nr, nc;
 
    if (length(args) != 1)
	error("incorrect number of args to row/col");
    if (!isMatrix(CAR(args)))
	error("a matrix is required as arg to row/col");
 
    nr = nrows(CAR(args));
    nc = ncols(CAR(args));
 
    ans = allocMatrix(INTSXP, nr, nc);

    int ldx, ldy, nrx, ncx, nry, ncy, mode;
    SEXP x, y, xdims, ydims, ans;
 
    if (!(isNumeric(CAR(args)) || isComplex(CAR(args))) ||
	!(isNumeric(CADR(args)) || isComplex(CADR(args))))
	error("%%*%% requires numeric matrix/vector arguments");
 
    x = CAR(args);
    y = CADR(args);
    xdims = getAttrib(x, R_DimSymbol);
    ydims = getAttrib(y, R_DimSymbol);

	ncy = INTEGER(ydims)[1];
    }
 
    if (PRIMVAL(op) == 0) {
	if (ncx != nry)
	    errorcall(call, "non-conformable arguments");
    }
    else {
	if (nrx != nry)
	    errorcall(call, "non-conformable arguments");
    }
 
    if (isComplex(CAR(args)) || isComplex(CADR(args)))
	mode = CPLXSXP;
    else

    }
    copyMostAttrib(a, r);
    UNPROTECT(1);
    return r;
 not_matrix:
    errorcall(call, "argument is not a matrix");
    return call;/* never used; just for -Wall */
}
 
 
/* swap works by finding for a index i, the position */

    checkArity(op, args);
 
    a = CAR(args);
    PROTECT(dimsa = getAttrib(a, R_DimSymbol));
    if (dimsa == R_NilValue)
	error("aperm: invalid first argument, must be an array");
 
    PROTECT(perm = coerceVector(CADR(args), INTSXP));
    if (!isVector(perm) || (length(perm) != length(dimsa)))
	error("aperm: invalid second argument, must be a vector");
 
    len = length(a);
 
    PROTECT(dimsr = allocVector(INTSXP, length(dimsa)));
    for (i = 0; i < length(dimsa); i++)

	for (i = 0; i < len; i++) {
	    j = swap(i, dimsa, dimsr, perm, ind1, ind2);
	    VECTOR(r)[j] = VECTOR(a)[i];
	}
    default:
	errorcall(call, "invalid argument");
    }
 
    if (INTEGER(CAR(CDDR(args)))[0])
	setAttrib(r, R_DimSymbol, dimsr);
    else

Rev 5458	Rev 5731
Line 64...	Line 64...
64	`snc = CADDR(args);`	64	`snc = CADDR(args);`
65	`byrow = asInteger(CADR(CDDR(args)));`	65	`byrow = asInteger(CADR(CDDR(args)));`
66		66
67	`if (isVector(vals) \|\| isList(vals)) {`	67	`if (isVector(vals) \|\| isList(vals)) {`
68	`if (length(vals) < 0)`	68	`if (length(vals) < 0)`
69	`errorcall(call, "argument has length zero\n");`	69	`errorcall(call, "argument has length zero");`
70	`}`	70	`}`
71	`else errorcall(call, "invalid matrix element type\n");`	71	`else errorcall(call, "invalid matrix element type");`
72		72
73	`if (!isNumeric(snr) \|\| !isNumeric(snc))`	73	`if (!isNumeric(snr) \|\| !isNumeric(snc))`
74	`error("non-numeric matrix extent\n");`	74	`error("non-numeric matrix extent");`
75		75
76	`lendat = length(vals);`	76	`lendat = length(vals);`
77	`nr = asInteger(snr);`	77	`nr = asInteger(snr);`
78	`nc = asInteger(snc);`	78	`nc = asInteger(snc);`
79		79
80	`if (lendat > 1 && (nr * nc) % lendat != 0) {`	80	`if (lendat > 1 && (nr * nc) % lendat != 0) {`
81	`if (((lendat > nr) && (lendat / nr) * nr != lendat) \|\|`	81	`if (((lendat > nr) && (lendat / nr) * nr != lendat) \|\|`
82	`((lendat < nr) && (nr / lendat) * lendat != nr))`	82	`((lendat < nr) && (nr / lendat) * lendat != nr))`
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(...)");`
84	`else if (((lendat > nc) && (lendat / nc) * nc != lendat) \|\|`	84	`else if (((lendat > nc) && (lendat / nc) * nc != lendat) \|\|`
85	`((lendat < nc) && (nc / lendat) * lendat != nc))`	85	`((lendat < nc) && (nc / lendat) * lendat != nc))`
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(...)");`
87	`}`	87	`}`
88	`else if ((lendat > 1) && (nr * nc == 0)){`	88	`else if ((lendat > 1) && (nr * nc == 0)){`
89	`warning("Replacement length not a multiple of the elements to replace in matrix(...) \n");`	89	`warning("Replacement length not a multiple of the elements to replace in matrix(...)");`
90	`}`	90	`}`
91	`else if (lendat == 0 && nr * nc > 0){`	91	`else if (lendat == 0 && nr * nc > 0){`
92	`error("No data to replace in matrix(...)\n");`	92	`error("No data to replace in matrix(...)");`
93	`}`	93	`}`
94		94
95	`PROTECT(snr = allocMatrix(TYPEOF(vals), nr, nc));`	95	`PROTECT(snr = allocMatrix(TYPEOF(vals), nr, nc));`
96	`if (isVector(vals))`	96	`if (isVector(vals))`
97	`copyMatrix(snr, vals, byrow);`	97	`copyMatrix(snr, vals, byrow);`
Line 106...	Line 106...
106	`{`	106	`{`
107	`SEXP s, t;`	107	`SEXP s, t;`
108	`int n;`	108	`int n;`
109		109
110	`if (nrow < 0 \|\| ncol < 0)`	110	`if (nrow < 0 \|\| ncol < 0)`
111	`error("negative extents to matrix\n");`	111	`error("negative extents to matrix");`
112	`n = nrow * ncol;`	112	`n = nrow * ncol;`
113	`PROTECT(s = allocVector(mode, n));`	113	`PROTECT(s = allocVector(mode, n));`
114	`PROTECT(t = allocVector(INTSXP, 2));`	114	`PROTECT(t = allocVector(INTSXP, 2));`
115	`INTEGER(t)[0] = nrow;`	115	`INTEGER(t)[0] = nrow;`
116	`INTEGER(t)[1] = ncol;`	116	`INTEGER(t)[1] = ncol;`
Line 257...	Line 257...
257		257
258	`SEXP do_length(SEXP call, SEXP op, SEXP args, SEXP rho)`	258	`SEXP do_length(SEXP call, SEXP op, SEXP args, SEXP rho)`
259	`{`	259	`{`
260	`SEXP ans;`	260	`SEXP ans;`
261	`if (length(args) != 1)`	261	`if (length(args) != 1)`
262	`error("incorrect number of args to length\n");`	262	`error("incorrect number of args to length");`
263	`ans = allocVector(INTSXP, 1);`	263	`ans = allocVector(INTSXP, 1);`
264	`INTEGER(ans)[0] = length(CAR(args));`	264	`INTEGER(ans)[0] = length(CAR(args));`
265	`return ans;`	265	`return ans;`
266	`}`	266	`}`
267		267
Line 270...	Line 270...
270	`{`	270	`{`
271	`SEXP ans;`	271	`SEXP ans;`
272	`int i, j, nr, nc;`	272	`int i, j, nr, nc;`
273		273
274	`if (length(args) != 1)`	274	`if (length(args) != 1)`
275	`error("incorrect number of args to row/col\n");`	275	`error("incorrect number of args to row/col");`
276	`if (!isMatrix(CAR(args)))`	276	`if (!isMatrix(CAR(args)))`
277	`error("a matrix is required as arg to row/col\n");`	277	`error("a matrix is required as arg to row/col");`
278		278
279	`nr = nrows(CAR(args));`	279	`nr = nrows(CAR(args));`
280	`nc = ncols(CAR(args));`	280	`nc = ncols(CAR(args));`
281		281
282	`ans = allocMatrix(INTSXP, nr, nc);`	282	`ans = allocMatrix(INTSXP, nr, nc);`
Line 426...	Line 426...
426	`int ldx, ldy, nrx, ncx, nry, ncy, mode;`	426	`int ldx, ldy, nrx, ncx, nry, ncy, mode;`
427	`SEXP x, y, xdims, ydims, ans;`	427	`SEXP x, y, xdims, ydims, ans;`
428		428
429	`if (!(isNumeric(CAR(args)) \|\| isComplex(CAR(args))) \|\|`	429	`if (!(isNumeric(CAR(args)) \|\| isComplex(CAR(args))) \|\|`
430	`!(isNumeric(CADR(args)) \|\| isComplex(CADR(args))))`	430	`!(isNumeric(CADR(args)) \|\| isComplex(CADR(args))))`
431	`error("%%*%% requires numeric matrix/vector arguments\n");`	431	`error("%%*%% requires numeric matrix/vector arguments");`
432		432
433	`x = CAR(args);`	433	`x = CAR(args);`
434	`y = CADR(args);`	434	`y = CADR(args);`
435	`xdims = getAttrib(x, R_DimSymbol);`	435	`xdims = getAttrib(x, R_DimSymbol);`
436	`ydims = getAttrib(y, R_DimSymbol);`	436	`ydims = getAttrib(y, R_DimSymbol);`
Line 508...	Line 508...
508	`ncy = INTEGER(ydims)[1];`	508	`ncy = INTEGER(ydims)[1];`
509	`}`	509	`}`
510		510
511	`if (PRIMVAL(op) == 0) {`	511	`if (PRIMVAL(op) == 0) {`
512	`if (ncx != nry)`	512	`if (ncx != nry)`
513	`errorcall(call, "non-conformable arguments\n");`	513	`errorcall(call, "non-conformable arguments");`
514	`}`	514	`}`
515	`else {`	515	`else {`
516	`if (nrx != nry)`	516	`if (nrx != nry)`
517	`errorcall(call, "non-conformable arguments\n");`	517	`errorcall(call, "non-conformable arguments");`
518	`}`	518	`}`
519		519
520	`if (isComplex(CAR(args)) \|\| isComplex(CADR(args)))`	520	`if (isComplex(CAR(args)) \|\| isComplex(CADR(args)))`
521	`mode = CPLXSXP;`	521	`mode = CPLXSXP;`
522	`else`	522	`else`
Line 647...	Line 647...
647	`}`	647	`}`
648	`copyMostAttrib(a, r);`	648	`copyMostAttrib(a, r);`
649	`UNPROTECT(1);`	649	`UNPROTECT(1);`
650	`return r;`	650	`return r;`
651	`not_matrix:`	651	`not_matrix:`
652	`errorcall(call, "argument is not a matrix\n");`	652	`errorcall(call, "argument is not a matrix");`
653	`return call;/* never used; just for -Wall */`	653	`return call;/* never used; just for -Wall */`
654	`}`	654	`}`
655		655
656		656
657	`/* swap works by finding for a index i, the position */`	657	`/* swap works by finding for a index i, the position */`
Line 691...	Line 691...
691	`checkArity(op, args);`	691	`checkArity(op, args);`
692		692
693	`a = CAR(args);`	693	`a = CAR(args);`
694	`PROTECT(dimsa = getAttrib(a, R_DimSymbol));`	694	`PROTECT(dimsa = getAttrib(a, R_DimSymbol));`
695	`if (dimsa == R_NilValue)`	695	`if (dimsa == R_NilValue)`
696	`error("aperm: invalid first argument, must be an array\n");`	696	`error("aperm: invalid first argument, must be an array");`
697		697
698	`PROTECT(perm = coerceVector(CADR(args), INTSXP));`	698	`PROTECT(perm = coerceVector(CADR(args), INTSXP));`
699	`if (!isVector(perm) \|\| (length(perm) != length(dimsa)))`	699	`if (!isVector(perm) \|\| (length(perm) != length(dimsa)))`
700	`error("aperm: invalid second argument, must be a vector\n");`	700	`error("aperm: invalid second argument, must be a vector");`
701		701
702	`len = length(a);`	702	`len = length(a);`
703		703
704	`PROTECT(dimsr = allocVector(INTSXP, length(dimsa)));`	704	`PROTECT(dimsr = allocVector(INTSXP, length(dimsa)));`
705	`for (i = 0; i < length(dimsa); i++)`	705	`for (i = 0; i < length(dimsa); i++)`
Line 739...	Line 739...
739	`for (i = 0; i < len; i++) {`	739	`for (i = 0; i < len; i++) {`
740	`j = swap(i, dimsa, dimsr, perm, ind1, ind2);`	740	`j = swap(i, dimsa, dimsr, perm, ind1, ind2);`
741	`VECTOR(r)[j] = VECTOR(a)[i];`	741	`VECTOR(r)[j] = VECTOR(a)[i];`
742	`}`	742	`}`
743	`default:`	743	`default:`
744	`errorcall(call, "invalid argument\n");`	744	`errorcall(call, "invalid argument");`
745	`}`	745	`}`
746		746
747	`if (INTEGER(CAR(CDDR(args)))[0])`	747	`if (INTEGER(CAR(CDDR(args)))[0])`
748	`setAttrib(r, R_DimSymbol, dimsr);`	748	`setAttrib(r, R_DimSymbol, dimsr);`
749	`else`	749	`else`

The R Project SVN R

(root)/trunk/src/main/array.c @ 28362 – Rev 5458 → 5731