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



    vals = CAR(args);
    snr = CADR(args);
    snc = CADDR(args);
    byrow = asLogical(CADR(CDDR(args)));
    if (byrow == NA_INTEGER)
	error(_("matrix: invalid byrow value"));
 
    /* R wrapper does as.vector
    if (isVector(vals) || isList(vals)) {
	if (length(vals) < 0)  (sic! cannot happen)
	   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);
    if (nr == NA_INTEGER) /* This is < 0 */
	error(_("matrix: invalid nrow value (too large or NA)"));
    if (nr < 0)
	error(_("matrix: invalid nrow value (< 0)"));
    nc = asInteger(snc);
    if (nc < 0)
	error(_("matrix: invalid ncol value (< 0)"));
    if (nc == NA_INTEGER)
	error(_("matrix: invalid ncol value (too large or NA)"));
    if (nc < 0)
	error(_("matrix: invalid ncol value (< 0)"));
 
    if(lendat > 0 ) {
	if (lendat > 1 && (nr * nc) % lendat != 0) {
	    if (((lendat > nr) && (lendat / nr) * nr != lendat) ||
		((lendat < nr) && (nr / lendat) * lendat != nr))
		warning(_("data length [%d] is not a sub-multiple or multiple of the number of rows [%d] in matrix"), lendat, nr);
	    else if (((lendat > nc) && (lendat / nc) * nc != lendat) ||
		     ((lendat < nc) && (nc / lendat) * lendat != nc))
		warning(_("data length [%d] is not a sub-multiple or multiple of the number of columns [%d] in matrix"), lendat, nc);
	}
	else if ((lendat > 1) && (nr * nc == 0)){
	    warning(_("data length exceeds size of matrix"));
	}
    }
 
    if ((double)nr * (double)nc > INT_MAX)
	error(_("matrix: too many elements specified"));
 
    PROTECT(snr = allocMatrix(TYPEOF(vals), nr, nc));
    if(lendat) {
	if (isVector(vals))
	    copyMatrix(snr, vals, byrow);

{
    SEXP s, t;
    int n;
 
    if (nrow < 0 || ncol < 0)
	error(_("negative extents to matrix"));
    if ((double)nrow * (double)ncol > INT_MAX)
	error(_("allocMatrix: too many elements specified"));
    n = nrow * ncol;
    PROTECT(s = allocVector(mode, n));
    PROTECT(t = allocVector(INTSXP, 2));
    INTEGER(t)[0] = nrow;
    INTEGER(t)[1] = ncol;

 
    dn = n = 1;
    for (i = 0; i < LENGTH(dims); i++) {
	dn *= INTEGER(dims)[i];
	if(dn > INT_MAX)
	    error(_("allocArray: too many elements specified by dims"));
	n *= INTEGER(dims)[i];
    }
 
    PROTECT(dims = duplicate(dims));
    PROTECT(array = allocVector(mode, n));

{
    SEXP ans;
    R_len_t len;
 
    if (length(args) != 1)
	error(_("incorrect number of args to length"));
 
    if( isObject(CAR(args)) && DispatchOrEval(call, op, "length", args,
					      rho, &ans, 0, 1))
      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);

    }
 
    sym = isNull(y);
    if (sym && (PRIMVAL(op) == 1)) y = x;
    if ( !(isNumeric(x) || isComplex(x)) || !(isNumeric(y) || isComplex(y)) )
	errorcall(call, _("requires numeric matrix/vector arguments"));
 
    xdims = getAttrib(x, R_DimSymbol);
    ydims = getAttrib(y, R_DimSymbol);
    ldx = length(xdims);
    ldy = length(ydims);

    }
    /* nr[ow](.) and nc[ol](.) are now defined for x and y */
 
    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 */
}
 
/*
 New version of aperm, using strides for speed.

 
    checkArity(op, args);
 
    a = CAR(args);
    if (!isArray(a))
	errorcall(call, _("invalid first argument, must be an array"));
 
    PROTECT(dimsa = getAttrib(a, R_DimSymbol));
    n = LENGTH(dimsa);
 
    /* check the permutation */

	    pp[i] = n-1-i;
    } else if (length(perm) == n) {
	for (i=0; i<n; i++)
	    pp[i] = INTEGER(perm)[i] - 1; /* no offset! */
    } else
	errorcall(call, _("'perm' is of wrong length"));
 
    iip = (int *) R_alloc(n, sizeof(int));
    for (i=0; i<n; iip[i++] = 0);
    for (i=0; i<n; i++)
	if (pp[i] >= 0 && pp[i] < n)
	    iip[pp[i]]++;
	else
	    errorcall(call, _("value out of range in 'perm'"));
    for (i=0; i<n; i++)
	if (iip[i]==0)
	    errorcall(call, _("invalid permutation ('perm')"));
 
    /* create the stride object and permute */
 
    stride = (int *) R_alloc(n, sizeof(int));
 

    x = CAR(args); args = CDR(args);
    n = asInteger(CAR(args)); args = CDR(args);
    p = asInteger(CAR(args)); args = CDR(args);
    NaRm = asLogical(CAR(args));
    if (n == NA_INTEGER || n <= 0)
	errorcall(call, _("invalid value of n"));
    if (p == NA_INTEGER || p <= 0)
	errorcall(call, _("invalid value of p"));
    if (NaRm == NA_LOGICAL) errorcall(call, _("invalid value of na.rm"));
    keepNA = !NaRm;
 
    OP = PRIMVAL(op);
    switch (type = TYPEOF(x)) {
    case LGLSXP: break;
    case INTSXP: break;
    case REALSXP: break;
    default:
	errorcall(call, _("'x' must be numeric"));
    }
 
    if (OP == 0 || OP == 1) { /* columns */
	cnt = n;
	PROTECT(ans = allocVector(REALSXP, p));

Rev 32380	Rev 32860
Line 66...	Line 66...
66	`vals = CAR(args);`	66	`vals = CAR(args);`
67	`snr = CADR(args);`	67	`snr = CADR(args);`
68	`snc = CADDR(args);`	68	`snc = CADDR(args);`
69	`byrow = asLogical(CADR(CDDR(args)));`	69	`byrow = asLogical(CADR(CDDR(args)));`
70	`if (byrow == NA_INTEGER)`	70	`if (byrow == NA_INTEGER)`
71	`error("matrix: invalid byrow value");`	71	`error(_("matrix: invalid byrow value"));`
72		72
73	`/* R wrapper does as.vector`	73	`/* R wrapper does as.vector`
74	`if (isVector(vals) \|\| isList(vals)) {`	74	`if (isVector(vals) \|\| isList(vals)) {`
75	`if (length(vals) < 0) (sic! cannot happen)`	75	`if (length(vals) < 0) (sic! cannot happen)`
76	`errorcall(call, "argument has length zero");`	76	`errorcall(call, "argument has length zero");`
77	`}`	77	`}`
78	`else errorcall(call, "invalid matrix element type"); */`	78	`else errorcall(call, "invalid matrix element type"); */`
79		79
80	`if (!isNumeric(snr) \|\| !isNumeric(snc))`	80	`if (!isNumeric(snr) \|\| !isNumeric(snc))`
81	`error("non-numeric matrix extent");`	81	`error(_("non-numeric matrix extent"));`
82		82
83	`lendat = length(vals);`	83	`lendat = length(vals);`
84	`nr = asInteger(snr);`	84	`nr = asInteger(snr);`
85	`if (nr == NA_INTEGER) /* This is < 0 */`	85	`if (nr == NA_INTEGER) /* This is < 0 */`
86	`error("matrix: invalid nrow value (too large or NA)");`	86	`error(_("matrix: invalid nrow value (too large or NA)"));`
87	`if (nr < 0)`	87	`if (nr < 0)`
88	`error("matrix: invalid nrow value (< 0)");`	88	`error(_("matrix: invalid nrow value (< 0)"));`
89	`nc = asInteger(snc);`	89	`nc = asInteger(snc);`
90	`if (nc < 0)`	90	`if (nc < 0)`
91	`error("matrix: invalid ncol value (< 0)");`	91	`error(_("matrix: invalid ncol value (< 0)"));`
92	`if (nc == NA_INTEGER)`	92	`if (nc == NA_INTEGER)`
93	`error("matrix: invalid ncol value (too large or NA)");`	93	`error(_("matrix: invalid ncol value (too large or NA)"));`
94	`if (nc < 0)`	94	`if (nc < 0)`
95	`error("matrix: invalid ncol value (< 0)");`	95	`error(_("matrix: invalid ncol value (< 0)"));`
96		96
97	`if(lendat > 0 ) {`	97	`if(lendat > 0 ) {`
98	`if (lendat > 1 && (nr * nc) % lendat != 0) {`	98	`if (lendat > 1 && (nr * nc) % lendat != 0) {`
99	`if (((lendat > nr) && (lendat / nr) * nr != lendat) \|\|`	99	`if (((lendat > nr) && (lendat / nr) * nr != lendat) \|\|`
100	`((lendat < nr) && (nr / lendat) * lendat != nr))`	100	`((lendat < nr) && (nr / lendat) * lendat != nr))`
101	`warning("data length [%d] is not a sub-multiple or multiple of the number of rows [%d] in matrix", lendat, nr);`	101	`warning(_("data length [%d] is not a sub-multiple or multiple of the number of rows [%d] in matrix"), lendat, nr);`
102	`else if (((lendat > nc) && (lendat / nc) * nc != lendat) \|\|`	102	`else if (((lendat > nc) && (lendat / nc) * nc != lendat) \|\|`
103	`((lendat < nc) && (nc / lendat) * lendat != nc))`	103	`((lendat < nc) && (nc / lendat) * lendat != nc))`
104	`warning("data length [%d] is not a sub-multiple or multiple of the number of columns [%d] in matrix", lendat, nc);`	104	`warning(_("data length [%d] is not a sub-multiple or multiple of the number of columns [%d] in matrix"), lendat, nc);`
105	`}`	105	`}`
106	`else if ((lendat > 1) && (nr * nc == 0)){`	106	`else if ((lendat > 1) && (nr * nc == 0)){`
107	`warning("data length exceeds size of matrix");`	107	`warning(_("data length exceeds size of matrix"));`
108	`}`	108	`}`
109	`}`	109	`}`
110		110
111	`if ((double)nr * (double)nc > INT_MAX)`	111	`if ((double)nr * (double)nc > INT_MAX)`
112	`error("matrix: too many elements specified");`	112	`error(_("matrix: too many elements specified"));`
113		113
114	`PROTECT(snr = allocMatrix(TYPEOF(vals), nr, nc));`	114	`PROTECT(snr = allocMatrix(TYPEOF(vals), nr, nc));`
115	`if(lendat) {`	115	`if(lendat) {`
116	`if (isVector(vals))`	116	`if (isVector(vals))`
117	`copyMatrix(snr, vals, byrow);`	117	`copyMatrix(snr, vals, byrow);`
Line 169...	Line 169...
169	`{`	169	`{`
170	`SEXP s, t;`	170	`SEXP s, t;`
171	`int n;`	171	`int n;`
172		172
173	`if (nrow < 0 \|\| ncol < 0)`	173	`if (nrow < 0 \|\| ncol < 0)`
174	`error("negative extents to matrix");`	174	`error(_("negative extents to matrix"));`
175	`if ((double)nrow * (double)ncol > INT_MAX)`	175	`if ((double)nrow * (double)ncol > INT_MAX)`
176	`error("allocMatrix: too many elements specified");`	176	`error(_("allocMatrix: too many elements specified"));`
177	`n = nrow * ncol;`	177	`n = nrow * ncol;`
178	`PROTECT(s = allocVector(mode, n));`	178	`PROTECT(s = allocVector(mode, n));`
179	`PROTECT(t = allocVector(INTSXP, 2));`	179	`PROTECT(t = allocVector(INTSXP, 2));`
180	`INTEGER(t)[0] = nrow;`	180	`INTEGER(t)[0] = nrow;`
181	`INTEGER(t)[1] = ncol;`	181	`INTEGER(t)[1] = ncol;`
Line 193...	Line 193...
193		193
194	`dn = n = 1;`	194	`dn = n = 1;`
195	`for (i = 0; i < LENGTH(dims); i++) {`	195	`for (i = 0; i < LENGTH(dims); i++) {`
196	`dn *= INTEGER(dims)[i];`	196	`dn *= INTEGER(dims)[i];`
197	`if(dn > INT_MAX)`	197	`if(dn > INT_MAX)`
198	`error("allocArray: too many elements specified by dims");`	198	`error(_("allocArray: too many elements specified by dims"));`
199	`n *= INTEGER(dims)[i];`	199	`n *= INTEGER(dims)[i];`
200	`}`	200	`}`
201		201
202	`PROTECT(dims = duplicate(dims));`	202	`PROTECT(dims = duplicate(dims));`
203	`PROTECT(array = allocVector(mode, n));`	203	`PROTECT(array = allocVector(mode, n));`
Line 338...	Line 338...
338	`{`	338	`{`
339	`SEXP ans;`	339	`SEXP ans;`
340	`R_len_t len;`	340	`R_len_t len;`
341		341
342	`if (length(args) != 1)`	342	`if (length(args) != 1)`
343	`error("incorrect number of args to length");`	343	`error(_("incorrect number of args to length"));`
344		344
345	`if( isObject(CAR(args)) && DispatchOrEval(call, op, "length", args,`	345	`if( isObject(CAR(args)) && DispatchOrEval(call, op, "length", args,`
346	`rho, &ans, 0, 1))`	346	`rho, &ans, 0, 1))`
347	`return(ans);`	347	`return(ans);`
348		348
Line 357...	Line 357...
357	`{`	357	`{`
358	`SEXP ans;`	358	`SEXP ans;`
359	`int i, j, nr, nc;`	359	`int i, j, nr, nc;`
360		360
361	`if (length(args) != 1)`	361	`if (length(args) != 1)`
362	`error("incorrect number of args to row/col");`	362	`error(_("incorrect number of args to row/col"));`
363	`if (!isMatrix(CAR(args)))`	363	`if (!isMatrix(CAR(args)))`
364	`error("a matrix is required as arg to row/col");`	364	`error(_("a matrix is required as arg to row/col"));`
365		365
366	`nr = nrows(CAR(args));`	366	`nr = nrows(CAR(args));`
367	`nc = ncols(CAR(args));`	367	`nc = ncols(CAR(args));`
368		368
369	`ans = allocMatrix(INTSXP, nr, nc);`	369	`ans = allocMatrix(INTSXP, nr, nc);`
Line 530...	Line 530...
530	`}`	530	`}`
531		531
532	`sym = isNull(y);`	532	`sym = isNull(y);`
533	`if (sym && (PRIMVAL(op) == 1)) y = x;`	533	`if (sym && (PRIMVAL(op) == 1)) y = x;`
534	`if ( !(isNumeric(x) \|\| isComplex(x)) \|\| !(isNumeric(y) \|\| isComplex(y)) )`	534	`if ( !(isNumeric(x) \|\| isComplex(x)) \|\| !(isNumeric(y) \|\| isComplex(y)) )`
535	`errorcall(call, "requires numeric matrix/vector arguments");`	535	`errorcall(call, _("requires numeric matrix/vector arguments"));`
536		536
537	`xdims = getAttrib(x, R_DimSymbol);`	537	`xdims = getAttrib(x, R_DimSymbol);`
538	`ydims = getAttrib(y, R_DimSymbol);`	538	`ydims = getAttrib(y, R_DimSymbol);`
539	`ldx = length(xdims);`	539	`ldx = length(xdims);`
540	`ldy = length(ydims);`	540	`ldy = length(ydims);`
Line 603...	Line 603...
603	`}`	603	`}`
604	`/* nr[ow](.) and nc[ol](.) are now defined for x and y */`	604	`/* nr[ow](.) and nc[ol](.) are now defined for x and y */`
605		605
606	`if (PRIMVAL(op) == 0) {`	606	`if (PRIMVAL(op) == 0) {`
607	`if (ncx != nry)`	607	`if (ncx != nry)`
608	`errorcall(call, "non-conformable arguments");`	608	`errorcall(call, _("non-conformable arguments"));`
609	`}`	609	`}`
610	`else {`	610	`else {`
611	`if (nrx != nry)`	611	`if (nrx != nry)`
612	`errorcall(call, "non-conformable arguments");`	612	`errorcall(call, _("non-conformable arguments"));`
613	`}`	613	`}`
614		614
615	`if (isComplex(CAR(args)) \|\| isComplex(CADR(args)))`	615	`if (isComplex(CAR(args)) \|\| isComplex(CADR(args)))`
616	`mode = CPLXSXP;`	616	`mode = CPLXSXP;`
617	`else`	617	`else`
Line 829...	Line 829...
829	`}`	829	`}`
830	`copyMostAttrib(a, r);`	830	`copyMostAttrib(a, r);`
831	`UNPROTECT(1);`	831	`UNPROTECT(1);`
832	`return r;`	832	`return r;`
833	`not_matrix:`	833	`not_matrix:`
834	`errorcall(call, "argument is not a matrix");`	834	`errorcall(call, _("argument is not a matrix"));`
835	`return call;/* never used; just for -Wall */`	835	`return call;/* never used; just for -Wall */`
836	`}`	836	`}`
837		837
838	`/*`	838	`/*`
839	`New version of aperm, using strides for speed.`	839	`New version of aperm, using strides for speed.`
Line 867...	Line 867...
867		867
868	`checkArity(op, args);`	868	`checkArity(op, args);`
869		869
870	`a = CAR(args);`	870	`a = CAR(args);`
871	`if (!isArray(a))`	871	`if (!isArray(a))`
872	`errorcall(call,"invalid first argument, must be an array");`	872	`errorcall(call, _("invalid first argument, must be an array"));`
873		873
874	`PROTECT(dimsa = getAttrib(a, R_DimSymbol));`	874	`PROTECT(dimsa = getAttrib(a, R_DimSymbol));`
875	`n = LENGTH(dimsa);`	875	`n = LENGTH(dimsa);`
876		876
877	`/* check the permutation */`	877	`/* check the permutation */`
Line 884...	Line 884...
884	`pp[i] = n-1-i;`	884	`pp[i] = n-1-i;`
885	`} else if (length(perm) == n) {`	885	`} else if (length(perm) == n) {`
886	`for (i=0; i<n; i++)`	886	`for (i=0; i<n; i++)`
887	`pp[i] = INTEGER(perm)[i] - 1; /* no offset! */`	887	`pp[i] = INTEGER(perm)[i] - 1; /* no offset! */`
888	`} else`	888	`} else`
889	errorcall(call, "`perm' is of wrong length");	889	`errorcall(call, _("'perm' is of wrong length"));`
890		890
891	`iip = (int *) R_alloc(n, sizeof(int));`	891	`iip = (int *) R_alloc(n, sizeof(int));`
892	`for (i=0; i<n; iip[i++] = 0);`	892	`for (i=0; i<n; iip[i++] = 0);`
893	`for (i=0; i<n; i++)`	893	`for (i=0; i<n; i++)`
894	`if (pp[i] >= 0 && pp[i] < n)`	894	`if (pp[i] >= 0 && pp[i] < n)`
895	`iip[pp[i]]++;`	895	`iip[pp[i]]++;`
896	`else`	896	`else`
897	errorcall(call, "value of out range in `perm'");	897	`errorcall(call, _("value out of range in 'perm'"));`
898	`for (i=0; i<n; i++)`	898	`for (i=0; i<n; i++)`
899	`if (iip[i]==0)`	899	`if (iip[i]==0)`
900	errorcall(call, "invalid permutation (`perm')");	900	`errorcall(call, _("invalid permutation ('perm')"));`
901		901
902	`/* create the stride object and permute */`	902	`/* create the stride object and permute */`
903		903
904	`stride = (int *) R_alloc(n, sizeof(int));`	904	`stride = (int *) R_alloc(n, sizeof(int));`
905		905
Line 1023...	Line 1023...
1023	`x = CAR(args); args = CDR(args);`	1023	`x = CAR(args); args = CDR(args);`
1024	`n = asInteger(CAR(args)); args = CDR(args);`	1024	`n = asInteger(CAR(args)); args = CDR(args);`
1025	`p = asInteger(CAR(args)); args = CDR(args);`	1025	`p = asInteger(CAR(args)); args = CDR(args);`
1026	`NaRm = asLogical(CAR(args));`	1026	`NaRm = asLogical(CAR(args));`
1027	`if (n == NA_INTEGER \|\| n <= 0)`	1027	`if (n == NA_INTEGER \|\| n <= 0)`
1028	`errorcall(call, "invalid value of n");`	1028	`errorcall(call, _("invalid value of n"));`
1029	`if (p == NA_INTEGER \|\| p <= 0)`	1029	`if (p == NA_INTEGER \|\| p <= 0)`
1030	`errorcall(call, "invalid value of p");`	1030	`errorcall(call, _("invalid value of p"));`
1031	`if (NaRm == NA_LOGICAL) errorcall(call, "invalid value of na.rm");`	1031	`if (NaRm == NA_LOGICAL) errorcall(call, _("invalid value of na.rm"));`
1032	`keepNA = !NaRm;`	1032	`keepNA = !NaRm;`
1033		1033
1034	`OP = PRIMVAL(op);`	1034	`OP = PRIMVAL(op);`
1035	`switch (type = TYPEOF(x)) {`	1035	`switch (type = TYPEOF(x)) {`
1036	`case LGLSXP: break;`	1036	`case LGLSXP: break;`
1037	`case INTSXP: break;`	1037	`case INTSXP: break;`
1038	`case REALSXP: break;`	1038	`case REALSXP: break;`
1039	`default:`	1039	`default:`
1040	errorcall(call, "`x' must be numeric");	1040	`errorcall(call, _("'x' must be numeric"));`
1041	`}`	1041	`}`
1042		1042
1043	`if (OP == 0 \|\| OP == 1) { /* columns */`	1043	`if (OP == 0 \|\| OP == 1) { /* columns */`
1044	`cnt = n;`	1044	`cnt = n;`
1045	`PROTECT(ans = allocVector(REALSXP, p));`	1045	`PROTECT(ans = allocVector(REALSXP, p));`

The R Project SVN R

(root)/trunk/src/main/array.c @ 28362 – Rev 32380 → 32860