/* "%*%" (op = 0), crossprod (op = 1) or tcrossprod (op = 2) */ SEXP attribute_hidden do_earg_matprod(SEXP call, SEXP op, SEXP arg_x, SEXP arg_y, SEXP rho) { int ldx, ldy, nrx, ncx, nry, ncy, mode; SEXP x = arg_x, y = arg_y, xdims, ydims, ans; Rboolean sym; sym = isNull(y); if (sym && (PRIMVAL(op) > 0)) y = x; if ( !(isNumeric(x) || isComplex(x)) || !(isNumeric(y) || isComplex(y)) ) errorcall(call, _("requires numeric/complex matrix/vector arguments")); xdims = getDimAttrib(x); ydims = getDimAttrib(y); ldx = length(xdims); ldy = length(ydims); if (ldx != 2 && ldy != 2) { /* x and y non-matrices */ if (PRIMVAL(op) == 0) { nrx = 1; ncx = LENGTH(x); } else { nrx = LENGTH(x); ncx = 1; } nry = LENGTH(y); ncy = 1; } else if (ldx != 2) { /* x not a matrix */ nry = INTEGER(ydims)[0]; ncy = INTEGER(ydims)[1]; nrx = 0; ncx = 0; if (PRIMVAL(op) == 0) { if (LENGTH(x) == nry) { /* x as row vector */ nrx = 1; ncx = nry; /* == LENGTH(x) */ } else if (nry == 1) { /* x as col vector */ nrx = LENGTH(x); ncx = 1; } } else if (PRIMVAL(op) == 1) { /* crossprod() */ if (LENGTH(x) == nry) { /* x is a col vector */ nrx = nry; /* == LENGTH(x) */ ncx = 1; } /* else if (nry == 1) ... not being too tolerant to treat x as row vector, as t(x) *is* row vector */ } else { /* tcrossprod */ if (LENGTH(x) == ncy) { /* x as row vector */ nrx = 1; ncx = ncy; /* == LENGTH(x) */ } else if (ncy == 1) { /* x as col vector */ nrx = LENGTH(x); ncx = 1; } } } else if (ldy != 2) { /* y not a matrix */ nrx = INTEGER(xdims)[0]; ncx = INTEGER(xdims)[1]; nry = 0; ncy = 0; if (PRIMVAL(op) == 0) { if (LENGTH(y) == ncx) { /* y as col vector */ nry = ncx; ncy = 1; } else if (ncx == 1) { /* y as row vector */ nry = 1; ncy = LENGTH(y); } } else if (PRIMVAL(op) == 1) { /* crossprod() */ if (LENGTH(y) == nrx) { /* y is a col vector */ nry = nrx; ncy = 1; } } else { /* tcrossprod -- y is a col vector */ nry = LENGTH(y); ncy = 1; } } else { /* x and y matrices */ nrx = INTEGER(xdims)[0]; ncx = INTEGER(xdims)[1]; nry = INTEGER(ydims)[0]; ncy = INTEGER(ydims)[1]; } /* nr[ow](.) and nc[ol](.) are now defined for x and y */ if (PRIMVAL(op) == 0) { /* primitive, so use call */ if (ncx != nry) errorcall(call, _("non-conformable arguments")); } else if (PRIMVAL(op) == 1) { if (nrx != nry) error(_("non-conformable arguments")); } else { if (ncx != ncy) error(_("non-conformable arguments")); } if (isComplex(x) || isComplex(y)) mode = CPLXSXP; else mode = REALSXP; x = coerceVector(x, mode); y = coerceVector(y, mode); if (PRIMVAL(op) == 0) { /* op == 0 : matprod() */ PROTECT(ans = allocMatrix(mode, nrx, ncy)); if (mode == CPLXSXP) cmatprod(COMPLEX(x), nrx, ncx, COMPLEX(y), nry, ncy, COMPLEX(ans)); else matprod(REAL(x), nrx, ncx, REAL(y), nry, ncy, REAL(ans)); PROTECT(xdims = getDimNamesAttrib(x)); PROTECT(ydims = getDimNamesAttrib(y)); if (xdims != R_NilValue || ydims != R_NilValue) { SEXP dimnames, dimnamesnames, dnx=R_NilValue, dny=R_NilValue; /* allocate dimnames and dimnamesnames */ PROTECT(dimnames = allocVector(VECSXP, 2)); PROTECT(dimnamesnames = allocVector(STRSXP, 2)); if (xdims != R_NilValue) { if (ldx == 2 || ncx == 1) { SET_VECTOR_ELT(dimnames, 0, VECTOR_ELT(xdims, 0)); dnx = getNamesAttrib(xdims); if(!isNull(dnx)) SET_STRING_ELT(dimnamesnames, 0, STRING_ELT(dnx, 0)); } } #define YDIMS_ET_CETERA \ if (ydims != R_NilValue) { \ if (ldy == 2) { \ SET_VECTOR_ELT(dimnames, 1, VECTOR_ELT(ydims, 1)); \ dny = getNamesAttrib(ydims); \ if(!isNull(dny)) \ SET_STRING_ELT(dimnamesnames, 1, STRING_ELT(dny, 1)); \ } else if (nry == 1) { \ SET_VECTOR_ELT(dimnames, 1, VECTOR_ELT(ydims, 0)); \ dny = getNamesAttrib(ydims); \ if(!isNull(dny)) \ SET_STRING_ELT(dimnamesnames, 1, STRING_ELT(dny, 0)); \ } \ } \ \ /* We sometimes attach a dimnames attribute \ * whose elements are all NULL ... \ * This is ugly but causes no real damage. \ * Now (2.1.0 ff), we don't anymore: */ \ if (VECTOR_ELT(dimnames,0) != R_NilValue || \ VECTOR_ELT(dimnames,1) != R_NilValue) { \ if (dnx != R_NilValue || dny != R_NilValue) \ setAttrib(dimnames, R_NamesSymbol, dimnamesnames); \ setAttrib(ans, R_DimNamesSymbol, dimnames); \ } \ UNPROTECT(2) YDIMS_ET_CETERA; } } else if (PRIMVAL(op) == 1) { /* op == 1: crossprod() */ PROTECT(ans = allocMatrix(mode, ncx, ncy)); if (mode == CPLXSXP) if(sym) ccrossprod(COMPLEX(x), nrx, ncx, COMPLEX(x), nry, ncy, COMPLEX(ans)); else ccrossprod(COMPLEX(x), nrx, ncx, COMPLEX(y), nry, ncy, COMPLEX(ans)); else { if(sym) symcrossprod(REAL(x), nrx, ncx, REAL(ans)); else crossprod(REAL(x), nrx, ncx, REAL(y), nry, ncy, REAL(ans)); } PROTECT(xdims = getDimNamesAttrib(x)); if (sym) PROTECT(ydims = xdims); else PROTECT(ydims = getDimNamesAttrib(y)); if (xdims != R_NilValue || ydims != R_NilValue) { SEXP dimnames, dimnamesnames, dnx=R_NilValue, dny=R_NilValue; /* allocate dimnames and dimnamesnames */ PROTECT(dimnames = allocVector(VECSXP, 2)); PROTECT(dimnamesnames = allocVector(STRSXP, 2)); if (xdims != R_NilValue) { if (ldx == 2) {/* not nrx==1 : .. fixed, ihaka 2003-09-30 */ SET_VECTOR_ELT(dimnames, 0, VECTOR_ELT(xdims, 1)); dnx = getNamesAttrib(xdims); if(!isNull(dnx)) SET_STRING_ELT(dimnamesnames, 0, STRING_ELT(dnx, 1)); } } YDIMS_ET_CETERA; } } else { /* op == 2: tcrossprod() */ PROTECT(ans = allocMatrix(mode, nrx, nry)); if (mode == CPLXSXP) if(sym) tccrossprod(COMPLEX(x), nrx, ncx, COMPLEX(x), nry, ncy, COMPLEX(ans)); else tccrossprod(COMPLEX(x), nrx, ncx, COMPLEX(y), nry, ncy, COMPLEX(ans)); else { if(sym) symtcrossprod(REAL(x), nrx, ncx, REAL(ans)); else tcrossprod(REAL(x), nrx, ncx, REAL(y), nry, ncy, REAL(ans)); } PROTECT(xdims = getDimNamesAttrib(x)); if (sym) PROTECT(ydims = xdims); else PROTECT(ydims = getDimNamesAttrib(y)); if (xdims != R_NilValue || ydims != R_NilValue) { SEXP dimnames, dimnamesnames, dnx=R_NilValue, dny=R_NilValue; /* allocate dimnames and dimnamesnames */ PROTECT(dimnames = allocVector(VECSXP, 2)); PROTECT(dimnamesnames = allocVector(STRSXP, 2)); if (xdims != R_NilValue) { if (ldx == 2) { SET_VECTOR_ELT(dimnames, 0, VECTOR_ELT(xdims, 0)); dnx = getNamesAttrib(xdims); if(!isNull(dnx)) SET_STRING_ELT(dimnamesnames, 0, STRING_ELT(dnx, 0)); } } if (ydims != R_NilValue) { if (ldy == 2) { SET_VECTOR_ELT(dimnames, 1, VECTOR_ELT(ydims, 0)); dny = getNamesAttrib(ydims); if(!isNull(dny)) SET_STRING_ELT(dimnamesnames, 1, STRING_ELT(dny, 0)); } } if (VECTOR_ELT(dimnames,0) != R_NilValue || VECTOR_ELT(dimnames,1) != R_NilValue) { if (dnx != R_NilValue || dny != R_NilValue) setAttrib(dimnames, R_NamesSymbol, dimnamesnames); setAttrib(ans, R_DimNamesSymbol, dimnames); } UNPROTECT(2); } } UNPROTECT(3); return ans; }
/* "%*%" (op = 0), crossprod (op = 1) or tcrossprod (op = 2) */ SEXP attribute_hidden do_matprod(SEXP call, SEXP op, SEXP args, SEXP rho) { int ldx, ldy, nrx, ncx, nry, ncy, mode; SEXP x = CAR(args), y = CADR(args), xdims, ydims, ans; Rboolean sym; if (PRIMVAL(op) == 0 && /* %*% is primitive, the others are .Internal() */ (IS_S4_OBJECT(x) || IS_S4_OBJECT(y)) && R_has_methods(op)) { SEXP s, value; /* Remove argument names to ensure positional matching */ for(s = args; s != R_NilValue; s = CDR(s)) SET_TAG(s, R_NilValue); value = R_possible_dispatch(call, op, args, rho, FALSE); if (value) return value; } sym = isNull(y); if (sym && (PRIMVAL(op) > 0)) y = x; if ( !(isNumeric(x) || isComplex(x)) || !(isNumeric(y) || isComplex(y)) ) errorcall(call, _("requires numeric/complex matrix/vector arguments")); xdims = getAttrib(x, R_DimSymbol); ydims = getAttrib(y, R_DimSymbol); ldx = length(xdims); ldy = length(ydims); if (ldx != 2 && ldy != 2) { /* x and y non-matrices */ // for crossprod, allow two cases: n x n ==> (1,n) x (n,1); 1 x n = (n, 1) x (1, n) if (PRIMVAL(op) == 1 && LENGTH(x) == 1) { nrx = ncx = nry = 1; ncy = LENGTH(y); } else { nry = LENGTH(y); ncy = 1; if (PRIMVAL(op) == 0) { nrx = 1; ncx = LENGTH(x); if(ncx == 1) { // y as row vector ncy = nry; nry = 1; } } else { nrx = LENGTH(x); ncx = 1; } } } else if (ldx != 2) { /* x not a matrix */ nry = INTEGER(ydims)[0]; ncy = INTEGER(ydims)[1]; nrx = 0; ncx = 0; if (PRIMVAL(op) == 0) { if (LENGTH(x) == nry) { /* x as row vector */ nrx = 1; ncx = nry; /* == LENGTH(x) */ } else if (nry == 1) { /* x as col vector */ nrx = LENGTH(x); ncx = 1; } } else if (PRIMVAL(op) == 1) { /* crossprod() */ if (LENGTH(x) == nry) { /* x is a col vector */ nrx = nry; /* == LENGTH(x) */ ncx = 1; } /* else if (nry == 1) ... not being too tolerant to treat x as row vector, as t(x) *is* row vector */ } else { /* tcrossprod */ if (LENGTH(x) == ncy) { /* x as row vector */ nrx = 1; ncx = ncy; /* == LENGTH(x) */ } else if (ncy == 1) { /* x as col vector */ nrx = LENGTH(x); ncx = 1; } } } else if (ldy != 2) { /* y not a matrix */ nrx = INTEGER(xdims)[0]; ncx = INTEGER(xdims)[1]; nry = 0; ncy = 0; if (PRIMVAL(op) == 0) { if (LENGTH(y) == ncx) { /* y as col vector */ nry = ncx; ncy = 1; } else if (ncx == 1) { /* y as row vector */ nry = 1; ncy = LENGTH(y); } } else if (PRIMVAL(op) == 1) { /* crossprod() */ if (LENGTH(y) == nrx) { /* y is a col vector */ nry = nrx; ncy = 1; } else if (nrx == 1) { // y as row vector nry = 1; ncy = LENGTH(y); } } else { // tcrossprod if (nrx == 1) { // y as row vector nry = 1; ncy = LENGTH(y); } else { // y is a col vector nry = LENGTH(y); ncy = 1; } } } else { /* x and y matrices */ nrx = INTEGER(xdims)[0]; ncx = INTEGER(xdims)[1]; nry = INTEGER(ydims)[0]; ncy = INTEGER(ydims)[1]; } /* nr[ow](.) and nc[ol](.) are now defined for x and y */ if (PRIMVAL(op) == 0) { /* primitive, so use call */ if (ncx != nry) errorcall(call, _("non-conformable arguments")); } else if (PRIMVAL(op) == 1) { if (nrx != nry) error(_("non-conformable arguments")); } else { if (ncx != ncy) error(_("non-conformable arguments")); } if (isComplex(CAR(args)) || isComplex(CADR(args))) mode = CPLXSXP; else mode = REALSXP; SETCAR(args, coerceVector(CAR(args), mode)); SETCADR(args, coerceVector(CADR(args), mode)); if (PRIMVAL(op) == 0) { /* op == 0 : matprod() */ 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) { SEXP dimnames, dimnamesnames, dnx=R_NilValue, dny=R_NilValue; /* allocate dimnames and dimnamesnames */ PROTECT(dimnames = allocVector(VECSXP, 2)); PROTECT(dimnamesnames = allocVector(STRSXP, 2)); if (xdims != R_NilValue) { if (ldx == 2 || ncx == 1) { SET_VECTOR_ELT(dimnames, 0, VECTOR_ELT(xdims, 0)); dnx = getAttrib(xdims, R_NamesSymbol); if(!isNull(dnx)) SET_STRING_ELT(dimnamesnames, 0, STRING_ELT(dnx, 0)); } } #define YDIMS_ET_CETERA \ if (ydims != R_NilValue) { \ if (ldy == 2) { \ SET_VECTOR_ELT(dimnames, 1, VECTOR_ELT(ydims, 1)); \ dny = getAttrib(ydims, R_NamesSymbol); \ if(!isNull(dny)) \ SET_STRING_ELT(dimnamesnames, 1, STRING_ELT(dny, 1)); \ } else if (nry == 1) { \ SET_VECTOR_ELT(dimnames, 1, VECTOR_ELT(ydims, 0)); \ dny = getAttrib(ydims, R_NamesSymbol); \ if(!isNull(dny)) \ SET_STRING_ELT(dimnamesnames, 1, STRING_ELT(dny, 0)); \ } \ } \ \ /* We sometimes attach a dimnames attribute \ * whose elements are all NULL ... \ * This is ugly but causes no real damage. \ * Now (2.1.0 ff), we don't anymore: */ \ if (VECTOR_ELT(dimnames,0) != R_NilValue || \ VECTOR_ELT(dimnames,1) != R_NilValue) { \ if (dnx != R_NilValue || dny != R_NilValue) \ setAttrib(dimnames, R_NamesSymbol, dimnamesnames); \ setAttrib(ans, R_DimNamesSymbol, dimnames); \ } \ UNPROTECT(2) YDIMS_ET_CETERA; } } else if (PRIMVAL(op) == 1) { /* op == 1: crossprod() */ PROTECT(ans = allocMatrix(mode, ncx, ncy)); if (mode == CPLXSXP) if(sym) ccrossprod(COMPLEX(CAR(args)), nrx, ncx, COMPLEX(CAR(args)), nry, ncy, COMPLEX(ans)); else ccrossprod(COMPLEX(CAR(args)), nrx, ncx, COMPLEX(CADR(args)), nry, ncy, COMPLEX(ans)); else { if(sym) symcrossprod(REAL(CAR(args)), nrx, ncx, REAL(ans)); else crossprod(REAL(CAR(args)), nrx, ncx, REAL(CADR(args)), nry, ncy, REAL(ans)); } PROTECT(xdims = getAttrib(CAR(args), R_DimNamesSymbol)); if (sym) PROTECT(ydims = xdims); else PROTECT(ydims = getAttrib(CADR(args), R_DimNamesSymbol)); if (xdims != R_NilValue || ydims != R_NilValue) { SEXP dimnames, dimnamesnames, dnx=R_NilValue, dny=R_NilValue; /* allocate dimnames and dimnamesnames */ PROTECT(dimnames = allocVector(VECSXP, 2)); PROTECT(dimnamesnames = allocVector(STRSXP, 2)); if (xdims != R_NilValue) { if (ldx == 2) {/* not nrx==1 : .. fixed, ihaka 2003-09-30 */ SET_VECTOR_ELT(dimnames, 0, VECTOR_ELT(xdims, 1)); dnx = getAttrib(xdims, R_NamesSymbol); if(!isNull(dnx)) SET_STRING_ELT(dimnamesnames, 0, STRING_ELT(dnx, 1)); } } YDIMS_ET_CETERA; } } else { /* op == 2: tcrossprod() */ PROTECT(ans = allocMatrix(mode, nrx, nry)); if (mode == CPLXSXP) if(sym) tccrossprod(COMPLEX(CAR(args)), nrx, ncx, COMPLEX(CAR(args)), nry, ncy, COMPLEX(ans)); else tccrossprod(COMPLEX(CAR(args)), nrx, ncx, COMPLEX(CADR(args)), nry, ncy, COMPLEX(ans)); else { if(sym) symtcrossprod(REAL(CAR(args)), nrx, ncx, REAL(ans)); else tcrossprod(REAL(CAR(args)), nrx, ncx, REAL(CADR(args)), nry, ncy, REAL(ans)); } PROTECT(xdims = getAttrib(CAR(args), R_DimNamesSymbol)); if (sym) PROTECT(ydims = xdims); else PROTECT(ydims = getAttrib(CADR(args), R_DimNamesSymbol)); if (xdims != R_NilValue || ydims != R_NilValue) { SEXP dimnames, dimnamesnames, dnx=R_NilValue, dny=R_NilValue; /* allocate dimnames and dimnamesnames */ PROTECT(dimnames = allocVector(VECSXP, 2)); PROTECT(dimnamesnames = allocVector(STRSXP, 2)); if (xdims != R_NilValue) { if (ldx == 2) { SET_VECTOR_ELT(dimnames, 0, VECTOR_ELT(xdims, 0)); dnx = getAttrib(xdims, R_NamesSymbol); if(!isNull(dnx)) SET_STRING_ELT(dimnamesnames, 0, STRING_ELT(dnx, 0)); } } if (ydims != R_NilValue) { if (ldy == 2) { SET_VECTOR_ELT(dimnames, 1, VECTOR_ELT(ydims, 0)); dny = getAttrib(ydims, R_NamesSymbol); if(!isNull(dny)) SET_STRING_ELT(dimnamesnames, 1, STRING_ELT(dny, 0)); } } if (VECTOR_ELT(dimnames,0) != R_NilValue || VECTOR_ELT(dimnames,1) != R_NilValue) { if (dnx != R_NilValue || dny != R_NilValue) setAttrib(dimnames, R_NamesSymbol, dimnamesnames); setAttrib(ans, R_DimNamesSymbol, dimnames); } UNPROTECT(2); } } UNPROTECT(3); return ans; }