The R Project SVN R

Rev

Rev 6206 | Rev 7002 | Go to most recent revision | Show entire file | Ignore whitespace | Details | Blame | Last modification | View Log | RSS feed

Rev 6206 Rev 6994
Line 198... Line 198...
198 
	setAttrib(x, R_NamesSymbol, newnames);
 198 
	setAttrib(x, R_NamesSymbol, newnames);
199 
	UNPROTECT(1);
 199 
	UNPROTECT(1);
200 
    }
 200 
    }
201 
    else {
 201 
    else {
202 
	/* We have a lower dimensional array. */
 202 
	/* We have a lower dimensional array. */
203 
	SEXP newdims;
 203 
	SEXP newdims, dnn, newnamesnames = R_NilValue;
- 
 
 204 
	dnn = getAttrib(dimnames, R_NamesSymbol);
204 
	PROTECT(newdims = allocVector(INTSXP, n));
 205 
	PROTECT(newdims = allocVector(INTSXP, n));
205 
	for (i = 0, n = 0; i < ndims; i++)
 206 
	for (i = 0, n = 0; i < ndims; i++)
206 
	    if (INTEGER(dims)[i] != 1)
 207 
	    if (INTEGER(dims)[i] != 1)
207 
		INTEGER(newdims)[n++] = INTEGER(dims)[i];
 208 
		INTEGER(newdims)[n++] = INTEGER(dims)[i];
208 
	if (dimnames != R_NilValue) {
 209 
	if (!isNull(dimnames)) {
209 
	    int havenames = 0;
 210 
	    int havenames = 0;
210 
	    for (i = 0; i < ndims; i++)
 211 
	    for (i = 0; i < ndims; i++)
211 
		if (INTEGER(dims)[i] != 1 && VECTOR(dimnames)[i] != R_NilValue)
 212 
		if (INTEGER(dims)[i] != 1 && VECTOR(dimnames)[i] != R_NilValue)
212 
		    havenames = 1;
 213 
		    havenames = 1;
213 
	    if (havenames) {
 214 
	    if (havenames) {
214 
		PROTECT(newnames = allocVector(VECSXP, n));
 215 
		PROTECT(newnames = allocVector(VECSXP, n));
- 
 
 216 
		PROTECT(newnamesnames = allocVector(STRSXP, n));
215 
		for (i = 0, n= 0; i < ndims; i++) {
 217 
		for (i = 0, n = 0; i < ndims; i++) {
216 
		    if (INTEGER(dims)[i] != 1)
 218 
		    if (INTEGER(dims)[i] != 1) {
- 
 
 219 
			if(!isNull(dnn))
- 
 
 220 
			    STRING(newnamesnames)[n] = STRING(dnn)[i];
217 
			VECTOR(newnames)[n++] = VECTOR(dimnames)[i];
 221 
			VECTOR(newnames)[n++] = VECTOR(dimnames)[i];
- 
 
 222 
		    }
218 
		}
 223 
		}
219 
	    }
 224 
	    }
220 
	    else dimnames = R_NilValue;
 225 
	    else dimnames = R_NilValue;
221 
	}
 226 
	}
222 
	PROTECT(dimnames);
 227 
	PROTECT(dimnames);
223 
	setAttrib(x, R_DimNamesSymbol, R_NilValue);
 228 
	setAttrib(x, R_DimNamesSymbol, R_NilValue);
224 
	setAttrib(x, R_DimSymbol, newdims);
 229 
	setAttrib(x, R_DimSymbol, newdims);
225 
	if (dimnames != R_NilValue)
 230 
	if (dimnames != R_NilValue)
226 
	{
 231 
	{
- 
 
 232 
	    if(!isNull(dnn))
- 
 
 233 
		setAttrib(newnames, R_NamesSymbol, newnamesnames);
227 
	    setAttrib(x, R_DimNamesSymbol, newnames);
 234 
	    setAttrib(x, R_DimNamesSymbol, newnames);
228 
	    UNPROTECT(1);
 235 
	    UNPROTECT(2);
229 
	}
 236 
	}
230 
	UNPROTECT(2);
 237 
	UNPROTECT(2);
231 
    }
 238 
    }
232 
    UNPROTECT(1);
 239 
    UNPROTECT(1);
233 
    return x;
 240 
    return x;
Line 324... Line 331...
324 
	    ;
 331 
	    ;
325 
#endif
 332 
#endif
326 
	}
 333 
	}
327 
}
 334 
}
328 
 
 335 
 
329 
static void cmatprod(complex *x, int nrx, int ncx,
 336 
static void cmatprod(Rcomplex *x, int nrx, int ncx,
330 
		complex *y, int nry, int ncy, complex *z)
 337 
		Rcomplex *y, int nry, int ncy, Rcomplex *z)
331 
{
 338 
{
332 
    int i, j, k;
 339 
    int i, j, k;
333 
    double xij_r, xij_i, yjk_r, yjk_i, sum_i, sum_r;
 340 
    double xij_r, xij_i, yjk_r, yjk_i, sum_i, sum_r;
334 
 
 341 
 
335 
    for (i = 0; i < nrx; i++)
 342 
    for (i = 0; i < nrx; i++)
Line 385... Line 392...
385 
	    ;
 392 
	    ;
386 
#endif
 393 
#endif
387 
	}
 394 
	}
388 
}
 395 
}
389 
 
 396 
 
390 
static void ccrossprod(complex *x, int nrx, int ncx,
 397 
static void ccrossprod(Rcomplex *x, int nrx, int ncx,
391 
		       complex *y, int nry, int ncy, complex *z)
 398 
		       Rcomplex *y, int nry, int ncy, Rcomplex *z)
392 
{
 399 
{
393 
    int i, j, k;
 400 
    int i, j, k;
394 
    double xji_r, xji_i, yjk_r, yjk_i, sum_r, sum_i;
 401 
    double xji_r, xji_i, yjk_r, yjk_i, sum_r, sum_i;
395 
 
 402 
 
396 
    for (i = 0; i < ncx; i++)
 403 
    for (i = 0; i < ncx; i++)
Line 533... Line 540...
533 
	    matprod(REAL(CAR(args)), nrx, ncx,
 540 
	    matprod(REAL(CAR(args)), nrx, ncx,
534 
		    REAL(CADR(args)), nry, ncy, REAL(ans));
 541 
		    REAL(CADR(args)), nry, ncy, REAL(ans));
535 
	PROTECT(xdims = getAttrib(CAR(args), R_DimNamesSymbol));
 542 
	PROTECT(xdims = getAttrib(CAR(args), R_DimNamesSymbol));
536 
	PROTECT(ydims = getAttrib(CADR(args), R_DimNamesSymbol));
 543 
	PROTECT(ydims = getAttrib(CADR(args), R_DimNamesSymbol));
537 
	if (xdims != R_NilValue || ydims != R_NilValue) {
 544 
	if (xdims != R_NilValue || ydims != R_NilValue) {
- 
 
 545 
	    SEXP dimnames, dimnamesnames, dn;
538 
	    SEXP dimnames = allocVector(VECSXP, 2);
 546 
	    PROTECT(dimnames = allocVector(VECSXP, 2));
- 
 
 547 
	    PROTECT(dimnamesnames = allocVector(STRSXP, 2));
539 
	    if (xdims != R_NilValue)
 548 
	    if (xdims != R_NilValue) {
- 
 
 549 
		dn = getAttrib(xdims, R_NamesSymbol);
540 
		VECTOR(dimnames)[0] = VECTOR(xdims)[0];
 550 
		VECTOR(dimnames)[0] = VECTOR(xdims)[0];
- 
 
 551 
		if(!isNull(dn))
- 
 
 552 
		    STRING(dimnamesnames)[0] = STRING(dn)[0];
- 
 
 553 
	    }
541 
	    if (ydims != R_NilValue)
 554 
	    if (ydims != R_NilValue) {
- 
 
 555 
		dn = getAttrib(ydims, R_NamesSymbol);
542 
		VECTOR(dimnames)[1] = VECTOR(ydims)[1];
 556 
		VECTOR(dimnames)[1] = VECTOR(ydims)[1];
- 
 
 557 
		if(!isNull(dn))
- 
 
 558 
		    STRING(dimnamesnames)[1] = STRING(dn)[1];
- 
 
 559 
	    }
- 
 
 560 
	    setAttrib(dimnames, R_NamesSymbol, dimnamesnames);
543 
	    setAttrib(ans, R_DimNamesSymbol, dimnames);
 561 
	    setAttrib(ans, R_DimNamesSymbol, dimnames);
- 
 
 562 
	    UNPROTECT(2);
544 
	}
 563 
	}
545 
    }
 564 
    }
546 
    else {
 565 
    else {
547 
	PROTECT(ans = allocMatrix(mode, ncx, ncy));
 566 
	PROTECT(ans = allocMatrix(mode, ncx, ncy));
548 
	if (mode == CPLXSXP)
 567 
	if (mode == CPLXSXP)
Line 552... Line 571...
552 
	    crossprod(REAL(CAR(args)), nrx, ncx,
 571 
	    crossprod(REAL(CAR(args)), nrx, ncx,
553 
		      REAL(CADR(args)), nry, ncy, REAL(ans));
 572 
		      REAL(CADR(args)), nry, ncy, REAL(ans));
554 
	PROTECT(xdims = getAttrib(CAR(args), R_DimNamesSymbol));
 573 
	PROTECT(xdims = getAttrib(CAR(args), R_DimNamesSymbol));
555 
	PROTECT(ydims = getAttrib(CADR(args), R_DimNamesSymbol));
 574 
	PROTECT(ydims = getAttrib(CADR(args), R_DimNamesSymbol));
556 
	if (xdims != R_NilValue || ydims != R_NilValue) {
 575 
	if (xdims != R_NilValue || ydims != R_NilValue) {
- 
 
 576 
	    SEXP dimnames, dimnamesnames, dnx, dny;
557 
	    SEXP dimnames = allocVector(VECSXP, 2);
 577 
	    PROTECT(dimnames = allocVector(VECSXP, 2));
- 
 
 578 
	    PROTECT(dimnamesnames = allocVector(STRSXP, 2));
558 
	    if (xdims != R_NilValue)
 579 
	    if (xdims != R_NilValue) {
- 
 
 580 
		dnx = getAttrib(xdims, R_NamesSymbol);
559 
		VECTOR(dimnames)[0] = VECTOR(xdims)[1];
 581 
		VECTOR(dimnames)[0] = VECTOR(xdims)[1];
- 
 
 582 
		if(!isNull(dnx))
- 
 
 583 
		    STRING(dimnamesnames)[0] = STRING(dnx)[1];
- 
 
 584 
	    }
560 
	    if (ydims != R_NilValue)
 585 
	    if (ydims != R_NilValue) {
- 
 
 586 
		dny = getAttrib(ydims, R_NamesSymbol);
561 
		VECTOR(dimnames)[1] = VECTOR(ydims)[1];
 587 
		VECTOR(dimnames)[1] = VECTOR(ydims)[1];
- 
 
 588 
		if(!isNull(dny))
- 
 
 589 
		    STRING(dimnamesnames)[1] = STRING(dny)[1];
- 
 
 590 
	    }
- 
 
 591 
	    if(!isNull(dnx) || !isNull(dny))
- 
 
 592 
		setAttrib(dimnames, R_NamesSymbol, dimnamesnames);
562 
	    setAttrib(ans, R_DimNamesSymbol, dimnames);
 593 
	    setAttrib(ans, R_DimNamesSymbol, dimnames);
- 
 
 594 
	    UNPROTECT(2);
563 
	}
 595 
	}
564 
    }
 596 
    }
565 
    UNPROTECT(3);
 597 
    UNPROTECT(3);
566 
    return ans;
 598 
    return ans;
567 
}
 599 
}
568 
 
 600 
 
569 
SEXP do_transpose(SEXP call, SEXP op, SEXP args, SEXP rho)
 601 
SEXP do_transpose(SEXP call, SEXP op, SEXP args, SEXP rho)
570 
{
 602 
{
571 
    SEXP a, r, dims, dimnames, rnames, cnames;
 603 
    SEXP a, r, dims, dimnames, dimnamesnames=R_NilValue,
- 
 
 604 
	ndimnamesnames, rnames, cnames;
572 
    int i, len = 0, ncol=0, nrow=0;
 605 
    int i, len = 0, ncol=0, nrow=0;
573 
 
 606 
 
574 
    checkArity(op, args);
 607 
    checkArity(op, args);
575 
    a = CAR(args);
 608 
    a = CAR(args);
576 
 
 609 
 
Line 597... Line 630...
597 
	    len = length(a);
 630 
	    len = length(a);
598 
	    dimnames = getAttrib(a, R_DimNamesSymbol);
 631 
	    dimnames = getAttrib(a, R_DimNamesSymbol);
599 
	    if (dimnames != R_NilValue) {
 632 
	    if (dimnames != R_NilValue) {
600 
		rnames = VECTOR(dimnames)[0];
 633 
		rnames = VECTOR(dimnames)[0];
601 
		cnames = VECTOR(dimnames)[1];
 634 
		cnames = VECTOR(dimnames)[1];
- 
 
 635 
		dimnamesnames = getAttrib(dimnames, R_NamesSymbol);
602 
	    }
 636 
	    }
603 
	    break;
 637 
	    break;
604 
	default:
 638 
	default:
605 
	    goto not_matrix;
 639 
	    goto not_matrix;
606 
	}
 640 
	}
Line 640... Line 674...
640 
    UNPROTECT(1);
 674 
    UNPROTECT(1);
641 
    if(rnames != R_NilValue || cnames != R_NilValue) {
 675 
    if(rnames != R_NilValue || cnames != R_NilValue) {
642 
	PROTECT(dimnames = allocVector(VECSXP, 2));
 676 
	PROTECT(dimnames = allocVector(VECSXP, 2));
643 
	VECTOR(dimnames)[0] = cnames;
 677 
	VECTOR(dimnames)[0] = cnames;
644 
	VECTOR(dimnames)[1] = rnames;
 678 
	VECTOR(dimnames)[1] = rnames;
- 
 
 679 
	if(!isNull(dimnamesnames)) {
- 
 
 680 
	    PROTECT(ndimnamesnames = allocVector(VECSXP, 2));
- 
 
 681 
	    STRING(ndimnamesnames)[1] = STRING(dimnamesnames)[0];
- 
 
 682 
	    STRING(ndimnamesnames)[0] = STRING(dimnamesnames)[1];
- 
 
 683 
	    setAttrib(dimnames, R_NamesSymbol, ndimnamesnames);
- 
 
 684 
	    UNPROTECT(1);
- 
 
 685 
	}
645 
	setAttrib(r, R_DimNamesSymbol, dimnames);
 686 
	setAttrib(r, R_DimNamesSymbol, dimnames);
646 
	UNPROTECT(1);
 687 
	UNPROTECT(1);
647 
    }
 688 
    }
648 
    copyMostAttrib(a, r);
 689 
    copyMostAttrib(a, r);
649 
    UNPROTECT(1);
 690 
    UNPROTECT(1);