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



		next_ik:
			;
		}
}
 
 
static void ccrossprod(complex *x, int nrx, int ncx, complex *y, int nry, int ncy, complex *z)
{
	int i, j, k;
	double xji_r, xji_i, yjk_r, yjk_i, sum_r, sum_i;
 

			z[i + k * ncx].i = sum_i;
		next_ik:
			;
		}
}
 
 
SEXP do_matprod(SEXP call, SEXP op, SEXP args, SEXP rho)
{
	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\n");
 
	x = CAR(args);
	y = CADR(args);
	xdims = getAttrib(x, R_DimSymbol);

	else {
		if(nrx != nry)
			errorcall(call, "non-conformable arguments\n");
	}
 
 
	if(isComplex(CAR(args)) || isComplex(CADR(args)))
		mode = CPLXSXP;
	else
 
		mode = REALSXP;
	CAR(args) = coerceVector(CAR(args), mode);
	CADR(args) = coerceVector(CADR(args), mode);
 
	if(PRIMVAL(op) == 0) {
		PROTECT(ans = allocMatrix(mode, nrx, ncy));
 
		if(mode == CPLXSXP)
			cmatprod(COMPLEX(CAR(args)), nrx, ncx, COMPLEX(CADR(args)), nry, ncy, COMPLEX(ans));
		else
 
			matprod(REAL(CAR(args)), nrx, ncx, REAL(CADR(args)), nry, ncy, REAL(ans));
		PROTECT(xdims = getAttrib(CAR(args), R_DimNamesSymbol));
		PROTECT(ydims = getAttrib(CADR(args), R_DimNamesSymbol));
		if (xdims != R_NilValue || ydims != R_NilValue) {
			setAttrib(ans, R_DimNamesSymbol, list2(CAR(xdims), CADR(ydims)));
		}
	}
	else {
		PROTECT(ans = allocMatrix(mode, ncx, ncy));
 
		if(mode == CPLXSXP)
			ccrossprod(COMPLEX(CAR(args)), nrx, ncx, COMPLEX(CADR(args)), nry, ncy, COMPLEX(ans));
		else
 
			crossprod(REAL(CAR(args)), nrx, ncx, REAL(CADR(args)), nry, ncy, REAL(ans));
		PROTECT(xdims = getAttrib(CAR(args), R_DimNamesSymbol));
		PROTECT(ydims = getAttrib(CADR(args), R_DimNamesSymbol));
		if (xdims != R_NilValue || ydims != R_NilValue) {
			setAttrib(ans, R_DimNamesSymbol, list2(CADR(xdims), CADR(ydims)));

		break;
	case REALSXP:
		for (i = 0; i < len; i++)
			REAL(r)[i] = REAL(a)[(i / ncol) + (i % ncol) * nrow];
		break;
 
	case CPLXSXP:
		for (i = 0; i < len; i++)
			COMPLEX(r)[i] = COMPLEX(a)[(i / ncol) + (i % ncol) * nrow];
		break;
 
	case STRSXP:
		for (i = 0; i < len; i++)
			STRING(r)[i] = STRING(a)[(i / ncol) + (i % ncol) * nrow];
		break;
	}

		for (i = 0; i < len; i++) {
			j = swap(i, dimsa, dimsr, perm, ind1, ind2);
			REAL(r)[j] = REAL(a)[i];
		}
		break;
 
	case CPLXSXP:
		for (i = 0; i < len; i++) {
			j = swap(i, dimsa, dimsr, perm, ind1, ind2);
			COMPLEX(r)[j] = COMPLEX(a)[i];
		}
		break;
 
	case STRSXP:
		for (i = 0; i < len; i++) {
			j = swap(i, dimsa, dimsr, perm, ind1, ind2);
			STRING(r)[j] = STRING(a)[i];
		}

Rev 785	Rev 968
Line 395...	Line 395...
395	`next_ik:`	395	`next_ik:`
396	`;`	396	`;`
397	`}`	397	`}`
398	`}`	398	`}`
399		399
400	`#ifdef COMPLEX_DATA`	-
401	`static void ccrossprod(complex x, int nrx, int ncx, complex y, int nry, int ncy, complex *z)`	400	`static void ccrossprod(complex x, int nrx, int ncx, complex y, int nry, int ncy, complex *z)`
402	`{`	401	`{`
403	`int i, j, k;`	402	`int i, j, k;`
404	`double xji_r, xji_i, yjk_r, yjk_i, sum_r, sum_i;`	403	`double xji_r, xji_i, yjk_r, yjk_i, sum_r, sum_i;`
405		404
Line 426...	Line 425...
426	`z[i + k * ncx].i = sum_i;`	425	`z[i + k * ncx].i = sum_i;`
427	`next_ik:`	426	`next_ik:`
428	`;`	427	`;`
429	`}`	428	`}`
430	`}`	429	`}`
431	`#endif`	-
432		430
433	`SEXP do_matprod(SEXP call, SEXP op, SEXP args, SEXP rho)`	431	`SEXP do_matprod(SEXP call, SEXP op, SEXP args, SEXP rho)`
434	`{`	432	`{`
435	`int ldx, ldy, nrx, ncx, nry, ncy, mode;`	433	`int ldx, ldy, nrx, ncx, nry, ncy, mode;`
436	`SEXP x, y, xdims, ydims, ans;`	434	`SEXP x, y, xdims, ydims, ans;`
437		435
438	`#ifdef COMPLEX_DATA`	-
439	`if (!(isNumeric(CAR(args)) \|\| isComplex(CAR(args))) \|\|`	436	`if (!(isNumeric(CAR(args)) \|\| isComplex(CAR(args))) \|\|`
440	`!(isNumeric(CADR(args)) \|\| isComplex(CADR(args))))`	437	`!(isNumeric(CADR(args)) \|\| isComplex(CADR(args))))`
441	`#else`	-
442	`if (!isNumeric(CAR(args)) \|\| !isNumeric(CADR(args)))`	-
443	`#endif`	-
444	`error("%%*%% requires numeric matrix/vector arguments\n");`	438	`error("%%*%% requires numeric matrix/vector arguments\n");`
445		439
446	`x = CAR(args);`	440	`x = CAR(args);`
447	`y = CADR(args);`	441	`y = CADR(args);`
448	`xdims = getAttrib(x, R_DimSymbol);`	442	`xdims = getAttrib(x, R_DimSymbol);`
Line 520...	Line 514...
520	`else {`	514	`else {`
521	`if(nrx != nry)`	515	`if(nrx != nry)`
522	`errorcall(call, "non-conformable arguments\n");`	516	`errorcall(call, "non-conformable arguments\n");`
523	`}`	517	`}`
524		518
525	`#ifdef COMPLEX_DATA`	-
526	`if(isComplex(CAR(args)) \|\| isComplex(CADR(args)))`	519	`if(isComplex(CAR(args)) \|\| isComplex(CADR(args)))`
527	`mode = CPLXSXP;`	520	`mode = CPLXSXP;`
528	`else`	521	`else`
529	`#endif`	-
530	`mode = REALSXP;`	522	`mode = REALSXP;`
531	`CAR(args) = coerceVector(CAR(args), mode);`	523	`CAR(args) = coerceVector(CAR(args), mode);`
532	`CADR(args) = coerceVector(CADR(args), mode);`	524	`CADR(args) = coerceVector(CADR(args), mode);`
533		525
534	`if(PRIMVAL(op) == 0) {`	526	`if(PRIMVAL(op) == 0) {`
535	`PROTECT(ans = allocMatrix(mode, nrx, ncy));`	527	`PROTECT(ans = allocMatrix(mode, nrx, ncy));`
536	`#ifdef COMPLEX_DATA`	-
537	`if(mode == CPLXSXP)`	528	`if(mode == CPLXSXP)`
538	`cmatprod(COMPLEX(CAR(args)), nrx, ncx, COMPLEX(CADR(args)), nry, ncy, COMPLEX(ans));`	529	`cmatprod(COMPLEX(CAR(args)), nrx, ncx, COMPLEX(CADR(args)), nry, ncy, COMPLEX(ans));`
539	`else`	530	`else`
540	`#endif`	-
541	`matprod(REAL(CAR(args)), nrx, ncx, REAL(CADR(args)), nry, ncy, REAL(ans));`	531	`matprod(REAL(CAR(args)), nrx, ncx, REAL(CADR(args)), nry, ncy, REAL(ans));`
542	`PROTECT(xdims = getAttrib(CAR(args), R_DimNamesSymbol));`	532	`PROTECT(xdims = getAttrib(CAR(args), R_DimNamesSymbol));`
543	`PROTECT(ydims = getAttrib(CADR(args), R_DimNamesSymbol));`	533	`PROTECT(ydims = getAttrib(CADR(args), R_DimNamesSymbol));`
544	`if (xdims != R_NilValue \|\| ydims != R_NilValue) {`	534	`if (xdims != R_NilValue \|\| ydims != R_NilValue) {`
545	`setAttrib(ans, R_DimNamesSymbol, list2(CAR(xdims), CADR(ydims)));`	535	`setAttrib(ans, R_DimNamesSymbol, list2(CAR(xdims), CADR(ydims)));`
546	`}`	536	`}`
547	`}`	537	`}`
548	`else {`	538	`else {`
549	`PROTECT(ans = allocMatrix(mode, ncx, ncy));`	539	`PROTECT(ans = allocMatrix(mode, ncx, ncy));`
550	`#ifdef COMPLEX_DATA`	-
551	`if(mode == CPLXSXP)`	540	`if(mode == CPLXSXP)`
552	`ccrossprod(COMPLEX(CAR(args)), nrx, ncx, COMPLEX(CADR(args)), nry, ncy, COMPLEX(ans));`	541	`ccrossprod(COMPLEX(CAR(args)), nrx, ncx, COMPLEX(CADR(args)), nry, ncy, COMPLEX(ans));`
553	`else`	542	`else`
554	`#endif`	-
555	`crossprod(REAL(CAR(args)), nrx, ncx, REAL(CADR(args)), nry, ncy, REAL(ans));`	543	`crossprod(REAL(CAR(args)), nrx, ncx, REAL(CADR(args)), nry, ncy, REAL(ans));`
556	`PROTECT(xdims = getAttrib(CAR(args), R_DimNamesSymbol));`	544	`PROTECT(xdims = getAttrib(CAR(args), R_DimNamesSymbol));`
557	`PROTECT(ydims = getAttrib(CADR(args), R_DimNamesSymbol));`	545	`PROTECT(ydims = getAttrib(CADR(args), R_DimNamesSymbol));`
558	`if (xdims != R_NilValue \|\| ydims != R_NilValue) {`	546	`if (xdims != R_NilValue \|\| ydims != R_NilValue) {`
559	`setAttrib(ans, R_DimNamesSymbol, list2(CADR(xdims), CADR(ydims)));`	547	`setAttrib(ans, R_DimNamesSymbol, list2(CADR(xdims), CADR(ydims)));`
Line 609...	Line 597...
609	`break;`	597	`break;`
610	`case REALSXP:`	598	`case REALSXP:`
611	`for (i = 0; i < len; i++)`	599	`for (i = 0; i < len; i++)`
612	`REAL(r)[i] = REAL(a)[(i / ncol) + (i % ncol) * nrow];`	600	`REAL(r)[i] = REAL(a)[(i / ncol) + (i % ncol) * nrow];`
613	`break;`	601	`break;`
614	`#ifdef COMPLEX_DATA`	-
615	`case CPLXSXP:`	602	`case CPLXSXP:`
616	`for (i = 0; i < len; i++)`	603	`for (i = 0; i < len; i++)`
617	`COMPLEX(r)[i] = COMPLEX(a)[(i / ncol) + (i % ncol) * nrow];`	604	`COMPLEX(r)[i] = COMPLEX(a)[(i / ncol) + (i % ncol) * nrow];`
618	`break;`	605	`break;`
619	`#endif`	-
620	`case STRSXP:`	606	`case STRSXP:`
621	`for (i = 0; i < len; i++)`	607	`for (i = 0; i < len; i++)`
622	`STRING(r)[i] = STRING(a)[(i / ncol) + (i % ncol) * nrow];`	608	`STRING(r)[i] = STRING(a)[(i / ncol) + (i % ncol) * nrow];`
623	`break;`	609	`break;`
624	`}`	610	`}`
Line 724...	Line 710...
724	`for (i = 0; i < len; i++) {`	710	`for (i = 0; i < len; i++) {`
725	`j = swap(i, dimsa, dimsr, perm, ind1, ind2);`	711	`j = swap(i, dimsa, dimsr, perm, ind1, ind2);`
726	`REAL(r)[j] = REAL(a)[i];`	712	`REAL(r)[j] = REAL(a)[i];`
727	`}`	713	`}`
728	`break;`	714	`break;`
729	`#ifdef COMPLEX_DATA`	-
730	`case CPLXSXP:`	715	`case CPLXSXP:`
731	`for (i = 0; i < len; i++) {`	716	`for (i = 0; i < len; i++) {`
732	`j = swap(i, dimsa, dimsr, perm, ind1, ind2);`	717	`j = swap(i, dimsa, dimsr, perm, ind1, ind2);`
733	`COMPLEX(r)[j] = COMPLEX(a)[i];`	718	`COMPLEX(r)[j] = COMPLEX(a)[i];`
734	`}`	719	`}`
735	`break;`	720	`break;`
736	`#endif`	-
737	`case STRSXP:`	721	`case STRSXP:`
738	`for (i = 0; i < len; i++) {`	722	`for (i = 0; i < len; i++) {`
739	`j = swap(i, dimsa, dimsr, perm, ind1, ind2);`	723	`j = swap(i, dimsa, dimsr, perm, ind1, ind2);`
740	`STRING(r)[j] = STRING(a)[i];`	724	`STRING(r)[j] = STRING(a)[i];`
741	`}`	725	`}`

The R Project SVN R

(root)/trunk/src/main/array.c @ 28362 – Rev 785 → 968