The R Project SVN R

Rev

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

Rev 26467 Rev 26472
Line 517... Line 517...
517 
    xdims = getAttrib(x, R_DimSymbol);
 517 
    xdims = getAttrib(x, R_DimSymbol);
518 
    ydims = getAttrib(y, R_DimSymbol);
 518 
    ydims = getAttrib(y, R_DimSymbol);
519 
    ldx = length(xdims);
 519 
    ldx = length(xdims);
520 
    ldy = length(ydims);
 520 
    ldy = length(ydims);
521 
 
 521 
 
522 
    if (ldx != 2 && ldy != 2) {
 522 
    if (ldx != 2 && ldy != 2) {		/* x and y non-matrices */
523 
	if (PRIMVAL(op) == 0) {
 523 
	if (PRIMVAL(op) == 0) {
524 
	    nrx = 1;
 524 
	    nrx = 1;
525 
	    ncx = LENGTH(x);
 525 
	    ncx = LENGTH(x);
526 
	}
 526 
	}
527 
	else {
 527 
	else {
Line 529... Line 529...
529 
	    ncx = 1;
 529 
	    ncx = 1;
530 
	}
 530 
	}
531 
	nry = LENGTH(y);
 531 
	nry = LENGTH(y);
532 
	ncy = 1;
 532 
	ncy = 1;
533 
    }
 533 
    }
534 
    else if (ldx != 2) {
 534 
    else if (ldx != 2) {		/* x not a matrix */
535 
	nry = INTEGER(ydims)[0];
 535 
	nry = INTEGER(ydims)[0];
536 
	ncy = INTEGER(ydims)[1];
 536 
	ncy = INTEGER(ydims)[1];
537 
	nrx = 0;
 537 
	nrx = 0;
538 
	ncx = 0;
 538 
	ncx = 0;
539 
	if (PRIMVAL(op) == 0) {
 539 
	if (PRIMVAL(op) == 0) {
540 
	    if (LENGTH(x) == nry) { /* x as row vector */
 540 
	    if (LENGTH(x) == nry) {	/* x as row vector */
541 
		nrx = 1;
 541 
		nrx = 1;
542 
		ncx = LENGTH(x);
 542 
		ncx = LENGTH(x);
543 
	    }
 543 
	    }
544 
	    else if (nry == 1) { /* x as col vector */
 544 
	    else if (nry == 1) {	/* x as col vector */
545 
		nrx = LENGTH(x);
 545 
		nrx = LENGTH(x);
546 
		ncx = 1;
 546 
		ncx = 1;
547 
	    }
 547 
	    }
548 
	}
 548 
	}
549 
	else {
 549 
	else {
550 
	    if (LENGTH(x) == nry) {
 550 
	    if (LENGTH(x) == nry) {	/* x is a row vector */
551 
		nrx = LENGTH(x);
 551 
		nrx = LENGTH(x);
552 
		ncx = 1;
 552 
		ncx = 1;
553 
	    }
 553 
	    }
554 
	}
 554 
	}
555 
    }
 555 
    }
556 
    else if (ldy != 2) {
 556 
    else if (ldy != 2) {		/* y not a matrix */
557 
	nrx = INTEGER(xdims)[0];
 557 
	nrx = INTEGER(xdims)[0];
558 
	ncx = INTEGER(xdims)[1];
 558 
	ncx = INTEGER(xdims)[1];
559 
	nry = 0;
 559 
	nry = 0;
560 
	ncy = 0;
 560 
	ncy = 0;
561 
	if (PRIMVAL(op) == 0) {
 561 
	if (PRIMVAL(op) == 0) {
562 
	    if (LENGTH(y) == ncx) { /* y as col vector */
 562 
	    if (LENGTH(y) == ncx) {	/* y as col vector */
563 
		nry = LENGTH(y);
 563 
		nry = LENGTH(y);
564 
		ncy = 1;
 564 
		ncy = 1;
565 
	    }
 565 
	    }
566 
	    else if (ncx == 1) { /* y as row vector */
 566 
	    else if (ncx == 1) {	/* y as row vector */
567 
		nry = 1;
 567 
		nry = 1;
568 
		ncy = LENGTH(y);
 568 
		ncy = LENGTH(y);
569 
	    }
 569 
	    }
570 
	}
 570 
	}
571 
	else {
 571 
	else {
572 
	    if (LENGTH(y) == nrx) {
 572 
	    if (LENGTH(y) == nrx) {	/* y is a row vector */
573 
		nry = LENGTH(y);
 573 
		nry = LENGTH(y);
574 
		ncy = 1;
 574 
		ncy = 1;
575 
	    }
 575 
	    }
576 
	}
 576 
	}
577 
    }
 577 
    }
578 
    else { /* ldx == ldy == 2 */
 578 
    else {				/* x and y matrices */
579 
	nrx = INTEGER(xdims)[0];
 579 
	nrx = INTEGER(xdims)[0];
580 
	ncx = INTEGER(xdims)[1];
 580 
	ncx = INTEGER(xdims)[1];
581 
	nry = INTEGER(ydims)[0];
 581 
	nry = INTEGER(ydims)[0];
582 
	ncy = INTEGER(ydims)[1];
 582 
	ncy = INTEGER(ydims)[1];
583 
    }
 583 
    }
Line 596... Line 596...
596 
    else
 596 
    else
597 
	mode = REALSXP;
 597 
	mode = REALSXP;
598 
    SETCAR(args, coerceVector(CAR(args), mode));
 598 
    SETCAR(args, coerceVector(CAR(args), mode));
599 
    SETCADR(args, coerceVector(CADR(args), mode));
 599 
    SETCADR(args, coerceVector(CADR(args), mode));
600 
 
 600 
 
601 
    if (PRIMVAL(op) == 0) {
 601 
    if (PRIMVAL(op) == 0) {		       	/* op == 0 : matprod() */
- 
 
 602 
 
602 
	PROTECT(ans = allocMatrix(mode, nrx, ncy));
 603 
	PROTECT(ans = allocMatrix(mode, nrx, ncy));
603 
	if (mode == CPLXSXP)
 604 
	if (mode == CPLXSXP)
604 
	    cmatprod(COMPLEX(CAR(args)), nrx, ncx,
 605 
	    cmatprod(COMPLEX(CAR(args)), nrx, ncx,
605 
		     COMPLEX(CADR(args)), nry, ncy, COMPLEX(ans));
 606 
		     COMPLEX(CADR(args)), nry, ncy, COMPLEX(ans));
606 
	else
 607 
	else
607 
	    matprod(REAL(CAR(args)), nrx, ncx,
 608 
	    matprod(REAL(CAR(args)), nrx, ncx,
608 
		    REAL(CADR(args)), nry, ncy, REAL(ans));
 609 
		    REAL(CADR(args)), nry, ncy, REAL(ans));
- 
 
 610 
 
609 
	PROTECT(xdims = getAttrib(CAR(args), R_DimNamesSymbol));
 611 
	PROTECT(xdims = getAttrib(CAR(args), R_DimNamesSymbol));
610 
	PROTECT(ydims = getAttrib(CADR(args), R_DimNamesSymbol));
 612 
	PROTECT(ydims = getAttrib(CADR(args), R_DimNamesSymbol));
- 
 
 613 
 
611 
	if (xdims != R_NilValue || ydims != R_NilValue) {
 614 
	if (xdims != R_NilValue || ydims != R_NilValue) {
612 
	    SEXP dimnames, dimnamesnames, dn;
 615 
	    SEXP dimnames, dimnamesnames, dn;
613 
	    PROTECT(dimnames = allocVector(VECSXP, 2));
 616 
	    PROTECT(dimnames = allocVector(VECSXP, 2));
614 
	    PROTECT(dimnamesnames = allocVector(STRSXP, 2));
 617 
	    PROTECT(dimnamesnames = allocVector(STRSXP, 2));
615 
	    if (xdims != R_NilValue) {
 618 
	    if (xdims != R_NilValue) {
Line 636... Line 639...
636 
	    setAttrib(dimnames, R_NamesSymbol, dimnamesnames);
 639 
	    setAttrib(dimnames, R_NamesSymbol, dimnamesnames);
637 
	    setAttrib(ans, R_DimNamesSymbol, dimnames);
 640 
	    setAttrib(ans, R_DimNamesSymbol, dimnames);
638 
	    UNPROTECT(2);
 641 
	    UNPROTECT(2);
639 
	}
 642 
	}
640 
    }
 643 
    }
- 
 
 644 
 
641 
    else { /* op == 1: crossprod() */
 645 
    else {					/* op == 1: crossprod() */
- 
 
 646 
 
642 
	PROTECT(ans = allocMatrix(mode, ncx, ncy));
 647 
	PROTECT(ans = allocMatrix(mode, ncx, ncy));
643 
	if (mode == CPLXSXP)
 648 
	if (mode == CPLXSXP)
644 
	    if(sym)
 649 
	    if(sym)
645 
		ccrossprod(COMPLEX(CAR(args)), nrx, ncx,
 650 
		ccrossprod(COMPLEX(CAR(args)), nrx, ncx,
646 
			   COMPLEX(CAR(args)), nry, ncy, COMPLEX(ans));
 651 
			   COMPLEX(CAR(args)), nry, ncy, COMPLEX(ans));
Line 654... Line 659...
654 
	    else
 659 
	    else
655 
#endif
 660 
#endif
656 
		crossprod(REAL(CAR(args)), nrx, ncx,
 661 
		crossprod(REAL(CAR(args)), nrx, ncx,
657 
			  REAL(CADR(args)), nry, ncy, REAL(ans));
 662 
			  REAL(CADR(args)), nry, ncy, REAL(ans));
658 
	}
 663 
	}
- 
 
 664 
 
659 
	PROTECT(xdims = getAttrib(CAR(args), R_DimNamesSymbol));
 665 
	PROTECT(xdims = getAttrib(CAR(args), R_DimNamesSymbol));
660 
	if(sym)
 666 
	if (sym)
661 
	    PROTECT(ydims = xdims);
 667 
	    PROTECT(ydims = xdims);
662 
	else
 668 
	else
663 
	    PROTECT(ydims = getAttrib(CADR(args), R_DimNamesSymbol));
 669 
	    PROTECT(ydims = getAttrib(CADR(args), R_DimNamesSymbol));
- 
 
 670 
 
664 
	if (xdims != R_NilValue || ydims != R_NilValue) {
 671 
	if (xdims != R_NilValue || ydims != R_NilValue) {
665 
	    SEXP dimnames, dimnamesnames, dnx=R_NilValue, dny=R_NilValue;
 672 
	    SEXP dimnames, dimnamesnames, dnx=R_NilValue, dny=R_NilValue;
- 
 
 673 
 
- 
 
 674 
	    /* allocate dimnames and dimnamesnames */
- 
 
 675 
 
666 
	    PROTECT(dimnames = allocVector(VECSXP, 2));
 676 
	    PROTECT(dimnames = allocVector(VECSXP, 2));
667 
	    PROTECT(dimnamesnames = allocVector(STRSXP, 2));
 677 
	    PROTECT(dimnamesnames = allocVector(STRSXP, 2));
- 
 
 678 
 
- 
 
 679 
            /* There was a bug here.  The second element of a */
- 
 
 680 
            /* dimnames list was being accessed for a 1-d array. */
- 
 
 681 
            /* I have just excluded the use of dimnames in this */
- 
 
 682 
            /* case. - ihaka Sep 30, 2003. */
- 
 
 683 
 
668 
	    if (xdims != R_NilValue) {
 684 
	    if (xdims != R_NilValue) {
- 
 
 685 
                if (ldx == 2) {
669 
		dnx = getAttrib(xdims, R_NamesSymbol);
 686 
		    dnx = getAttrib(xdims, R_NamesSymbol);
670 
		SET_VECTOR_ELT(dimnames, 0, VECTOR_ELT(xdims, 1));
 687 
		    SET_VECTOR_ELT(dimnames, 0, VECTOR_ELT(xdims, 1));
671 
		if(!isNull(dnx))
 688 
		    if(!isNull(dnx))
672 
		    SET_STRING_ELT(dimnamesnames, 0, STRING_ELT(dnx, 1));
 689 
			SET_STRING_ELT(dimnamesnames, 0, STRING_ELT(dnx, 1));
- 
 
 690 
		}
673 
	    }
 691 
	    }
- 
 
 692 
 
674 
	    if (ydims != R_NilValue) {
 693 
	    if (ydims != R_NilValue) {
- 
 
 694 
                if (ldy == 2) {
675 
		dny = getAttrib(ydims, R_NamesSymbol);
 695 
		    dny = getAttrib(ydims, R_NamesSymbol);
676 
		SET_VECTOR_ELT(dimnames, 1, VECTOR_ELT(ydims, 1));
 696 
		    SET_VECTOR_ELT(dimnames, 1, VECTOR_ELT(ydims, 1));
677 
		if(!isNull(dny))
 697 
		    if(!isNull(dny))
678 
		    SET_STRING_ELT(dimnamesnames, 1, STRING_ELT(dny, 1));
 698 
			SET_STRING_ELT(dimnamesnames, 1, STRING_ELT(dny, 1));
- 
 
 699 
		}
679 
	    }
 700 
	    }
- 
 
 701 
 
- 
 
 702 
            /* We sometimes attach a dimnames attribute */
- 
 
 703 
            /* whose elements are all NULL ... */
- 
 
 704 
            /* Thus is ugly but causes no real damage. */
- 
 
 705
680 
	    if (!isNull(dnx) || !isNull(dny))
 706 
	    if (!isNull(dnx) || !isNull(dny))
681 
		setAttrib(dimnames, R_NamesSymbol, dimnamesnames);
 707 
		setAttrib(dimnames, R_NamesSymbol, dimnamesnames);
682 
	    setAttrib(ans, R_DimNamesSymbol, dimnames);
 708 
	    setAttrib(ans, R_DimNamesSymbol, dimnames);
683 
	    UNPROTECT(2);
 709 
	    UNPROTECT(2);
684 
	}
 710 
	}