void Query::makeComplex() {
if ( isComplex() )
return;
BSONObjBuilder b;
b.append( "query", obj );
obj = b.obj();
}
BSONObj Query::getFilter() const {
bool hasDollar;
if ( ! isComplex( &hasDollar ) )
return obj;
return obj.getObjectField( hasDollar ? "$query" : "query" );
}
void Token::stringify(std::ostream& os, bool varid, bool attributes, bool macro) const
{
if (attributes) {
if (isUnsigned())
os << "unsigned ";
else if (isSigned())
os << "signed ";
if (isComplex())
os << "_Complex ";
if (isLong()) {
if (_tokType == eString || _tokType == eChar)
os << "L";
else
os << "long ";
}
}
if (macro && isExpandedMacro())
os << "$";
if (_str[0] != '\"' || _str.find('\0') == std::string::npos)
os << _str;
else {
for (std::size_t i = 0U; i < _str.size(); ++i) {
if (_str[i] == '\0')
os << "\\0";
else
os << _str[i];
}
}
if (varid && _varId != 0)
os << '@' << _varId;
}
static msg_t check_storage(SEXP x, SEXP mode) {
if (!isNull(mode)) {
const char * const storage = asString(mode, "mode");
if (strcmp(storage, "logical") == 0) {
if (!isLogical(x))
return make_msg("Must store logicals");
} else if (strcmp(storage, "integer") == 0) {
if (!isInteger(x))
return make_msg("Must store integers");
} else if (strcmp(storage, "double") == 0) {
if (!isReal(x))
return make_msg("Must store doubles");
} else if (strcmp(storage, "numeric") == 0) {
if (!isStrictlyNumeric(x))
return make_msg("Must store numerics");
} else if (strcmp(storage, "complex") == 0) {
if (!isComplex(x))
return make_msg("Must store complexs");
} else if (strcmp(storage, "character") == 0) {
if (!isString(x))
return make_msg("Must store characters");
} else if (strcmp(storage, "list") == 0) {
if (!isRList(x))
return make_msg("Must store a list");
} else if (strcmp(storage, "atomic") == 0) {
if (!isVectorAtomic(x))
return make_msg("Must be atomic");
} else {
error("Invalid argument 'mode'. Must be one of 'logical', 'integer', 'double', 'numeric', 'complex', 'character', 'list' or 'atomic'");
}
}
return MSGT;
}
char iupac(char *name, char *observed, char orig)
{
char *observed2;
if (isComplex(orig))
{
observed2 = iupacReverse(orig);
if (!sameString(observed, observed2))
{
printf("differing observed strings %s, %s, %s\n", name, observed, observed2);
observed = observedBlend(observed, observed2);
printf("---------------\n");
}
}
if (sameString(observed, "A/C")) return 'M';
if (sameString(observed, "A/G")) return 'R';
if (sameString(observed, "A/T")) return 'W';
if (sameString(observed, "C/G")) return 'S';
if (sameString(observed, "C/T")) return 'Y';
if (sameString(observed, "G/T")) return 'K';
if (sameString(observed, "A/C/G")) return 'V';
if (sameString(observed, "A/C/T")) return 'H';
if (sameString(observed, "A/G/T")) return 'D';
if (sameString(observed, "C/G/T")) return 'B';
if (sameString(observed, "A/C/G/T")) return 'N';
return orig;
}
BSONObj Query::getSort() const {
if ( ! isComplex() )
return BSONObj();
BSONObj ret = obj.getObjectField( "orderby" );
if (ret.isEmpty())
ret = obj.getObjectField( "$orderby" );
return ret;
}
NOX::Abstract::Group::ReturnType
LOCA::LAPACK::Group::applyComplexTransposeInverseMultiVector(
Teuchos::ParameterList& params,
const NOX::Abstract::MultiVector& input_real,
const NOX::Abstract::MultiVector& input_imag,
NOX::Abstract::MultiVector& result_real,
NOX::Abstract::MultiVector& result_imag) const
{
#ifdef HAVE_TEUCHOS_COMPLEX
// Check validity of the Jacobian
if (!isComplex())
return NOX::Abstract::Group::BadDependency;
int n = complexSolver.getMatrix().numRows();
int p = input_real.numVectors();
// Copy inputs into a complex vector
std::vector< std::complex<double> > input(n*p);
const NOX::LAPACK::Vector* lapack_input_real;
const NOX::LAPACK::Vector* lapack_input_imag;
for (int j=0; j<p; j++) {
lapack_input_real =
dynamic_cast<const NOX::LAPACK::Vector*>(&(input_real[j]));
lapack_input_imag =
dynamic_cast<const NOX::LAPACK::Vector*>(&(input_imag[j]));
for (int i=0; i<n; i++)
input[i+n*j] = std::complex<double>((*lapack_input_real)(i),
(*lapack_input_imag)(i));
}
// Solve complex matrix
bool res = complexSolver.solve(true, p, &input[0]);
// Copy result into NOX vectors
NOX::LAPACK::Vector* lapack_result_real;
NOX::LAPACK::Vector* lapack_result_imag;
for (int j=0; j<p; j++) {
lapack_result_real =
dynamic_cast<NOX::LAPACK::Vector*>(&(result_real[j]));
lapack_result_imag =
dynamic_cast<NOX::LAPACK::Vector*>(&(result_imag[j]));
for (int i=0; i<n; i++) {
(*lapack_result_real)(i) = input[i+n*j].real();
(*lapack_result_imag)(i) = input[i+n*j].imag();
}
}
if (res)
return NOX::Abstract::Group::Ok;
else
return NOX::Abstract::Group::Failed;
#else
globalData->locaErrorCheck->throwError(
"LOCA::LAPACK::Group::applyComplexTransposeInverseMultiVector()",
"TEUCHOS_COMPLEX must be enabled for complex support! Reconfigure with -D Teuchos_ENABLE_COMPLEX");
return NOX::Abstract::Group::BadDependency;
#endif
}
SymBandSVDiv<T>::SymBandSVDiv(const GenSymBandMatrix<T>& A) :
pimpl(new SymBandSVDiv_Impl(A))
{
TMVAssert(isComplex(T()));
SV_Decompose<T>(A,pimpl->U.view(),pimpl->S.view(),
pimpl->Vt.view(),pimpl->logdet,pimpl->signdet);
thresh(TMV_Epsilon<T>());
}
void HermBandSVDiv<T>::doMakeInverse(MatrixView<T1> minv) const
{
// A^-1 = U S^-1 Ut
if (isComplex(T1())) minv.diag().imagPart().setZero();
CallHermSV_Inverse(
T(),pimpl->U,pimpl->S,pimpl->kmax,HermMatrixViewOf(minv,Upper));
if (pimpl->S.size() > 1)
minv.lowerTri().offDiag() = minv.upperTri().offDiag().adjoint();
}
SEXP c_check_complex(SEXP x, SEXP any_missing, SEXP all_missing, SEXP len, SEXP min_len, SEXP max_len, SEXP unique, SEXP names) {
if (!isComplex(x) && !all_missing_atomic(x))
return make_type_error(x, "complex");
assert(check_vector_len(x, len, min_len, max_len));
assert(check_vector_names(x, names));
assert(check_vector_missings(x, any_missing, all_missing));
assert(check_vector_unique(x, unique));
return ScalarLogical(TRUE);
}
Query& Query::where(const string &jscode, BSONObj scope) {
/* use where() before sort() and hint() and explain(), else this will assert. */
assert( ! isComplex() );
BSONObjBuilder b;
b.appendElements(obj);
b.appendWhere(jscode, scope);
obj = b.obj();
return *this;
}
SEXP do_cum(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP s, t, ans;
int i;
checkArity(op, args);
if (DispatchGroup("Math", call, op, args, env, &ans))
return ans;
if (isComplex(CAR(args))) {
t = CAR(args);
s = allocVector(CPLXSXP, LENGTH(t));
setAttrib(s, R_NamesSymbol, getAttrib(t, R_NamesSymbol));
for (i = 0 ; i < length(t) ; i++) {
COMPLEX(s)[i].r = NA_REAL;
COMPLEX(s)[i].i = NA_REAL;
}
switch (PRIMVAL(op) ) {
case 1: /* cumsum */
return ccumsum(t, s);
break;
case 2: /* cumprod */
return ccumprod(t, s);
break;
case 3: /* cummax */
case 4: /* cummin */
errorcall(call, _("min/max not defined for complex numbers"));
break;
default:
errorcall(call, _("unknown cumxxx function"));
}
}
else { /* Non-Complex: here, (sh|c)ould differentiate real / int */
PROTECT(t = coerceVector(CAR(args), REALSXP));
s = allocVector(REALSXP, LENGTH(t));
setAttrib(s, R_NamesSymbol, getAttrib(t, R_NamesSymbol));
for(i = 0 ; i < length(t) ; i++)
REAL(s)[i] = NA_REAL;
UNPROTECT(1);
switch (PRIMVAL(op) ) {
case 1: /* cumsum */
return cumsum(t,s);
break;
case 2: /* cumprod */
return cumprod(t,s);
break;
case 3: /* cummax */
return cummax(t,s);
break;
case 4: /* cummin */
return cummin(t,s);
break;
default:
errorcall(call, _("unknown cumxxx function"));
}
}
return R_NilValue; /* for -Wall */
}
bool Inst::CastMatch(CodeContext& context, RValue& lhs, RValue& rhs, bool upcast)
{
auto ltype = lhs.stype();
auto rtype = rhs.stype();
if (ltype == rtype) {
return false;
} else if (ltype->isComplex() || rtype->isComplex()) {
context.addError("can not cast complex types");
return true;
} else if (ltype->isPointer() || rtype->isPointer()) {
// different pointer types can't be cast automatically
// the operations need to handle pointers specially
return false;
}
auto toType = SType::numericConv(context, ltype, rtype, upcast);
return CastTo(context, lhs, toType, upcast) || CastTo(context, rhs, toType, upcast);
}
StringArray Parameter::getValuesNames()
{
StringArray result;
if (!isComplex()) result.add("Value");
else
{
for (int i = 0; i < value.size(); i++) result.add("Value " + String(i));
}
return result;
}
void JsonWriter::preValue()
{
if (isComplex()) {
if (fieldCount() > 0) { // i.e. Array
output_ << ",\n";
} else {
output_ << "\n";
}
indent();
}
incrementFieldCount();
}
SEXP Expect_matrix(SEXP S1, SEXP S, SEXP lambda, SEXP time, SEXP theta0, SEXP theta1, SEXP matdiag){
int nvar, npoints, nprotect=0;
nvar = GET_LENGTH(lambda);
npoints = GET_LENGTH(time);
PROTECT(time = coerceVector(time,REALSXP)); nprotect++;
PROTECT(theta0 = coerceVector(theta0,REALSXP)); nprotect++;
PROTECT(theta1 = coerceVector(theta1,REALSXP)); nprotect++;
// results
SEXP expectation = PROTECT(allocVector(REALSXP,nvar*npoints)); nprotect++;
if(!isComplex(lambda)){
// eigenvectors
PROTECT(S1 = coerceVector(S1,REALSXP)); nprotect++;
PROTECT(S = coerceVector(S,REALSXP)); nprotect++;
// matrix exponential
SEXP matexp = PROTECT(allocVector(REALSXP,nvar*nvar*npoints)); nprotect++;
// Compute the exponential matrix
multi_exp_matrix (&nvar, &npoints, REAL(time), REAL(lambda), REAL(S), REAL(S1), REAL(matexp));
// Compute the expectations
optimum (&nvar, &npoints, REAL(time), REAL(theta0), REAL(theta1), REAL(expectation), REAL(matexp), REAL(matdiag));
// Done.
}else{
double complex *matexp;
// complex eigenvalues & eigenvectors
PROTECT(S1 = coerceVector(S1,CPLXSXP)); nprotect++;
PROTECT(S = coerceVector(S,CPLXSXP)); nprotect++;
// alloc a complex vector in C rather than R structure...
matexp = Calloc(nvar*nvar*npoints,double complex);
// Compute the exponential matrix
multi_exp_matrix_complex (&nvar, &npoints, REAL(time), COMPLEX(lambda), COMPLEX(S), COMPLEX(S1), matexp);
// Compute the expectations
optimum_complex(&nvar, &npoints, REAL(time), REAL(theta0), REAL(theta1), REAL(expectation), matexp, REAL(matdiag));
// Done.
// Free the memory
Free(matexp);
}
UNPROTECT(nprotect);
return expectation;
}
// Weight matrix
SEXP Weight_matrix(SEXP S1, SEXP S, SEXP lambda, SEXP time, SEXP matdiag){
int nvar, npoints, vdim[2], nprotect = 0;
nvar = GET_LENGTH(lambda);
npoints = GET_LENGTH(time);
SEXP expectation;
vdim[0] = npoints*nvar; vdim[1] = nvar*2;
PROTECT(expectation = makearray(2,vdim)); nprotect++;
if(!isComplex(lambda)){
// eigenvectors
PROTECT(S1 = coerceVector(S1,REALSXP)); nprotect++;
PROTECT(S = coerceVector(S,REALSXP)); nprotect++;
// matrix exponential
SEXP matexp = PROTECT(allocVector(REALSXP,nvar*nvar*npoints)); nprotect++;
// Compute the exponential matrix
multi_exp_matrix (&nvar, &npoints, REAL(time), REAL(lambda), REAL(S), REAL(S1), REAL(matexp));
// Compute the expectations
build_w (&nvar, &npoints, REAL(time), REAL(expectation), REAL(matexp), REAL(matdiag));
// Done.
}else{
double complex *matexp;
// complex eigenvalues & eigenvectors
PROTECT(S1 = coerceVector(S1,CPLXSXP)); nprotect++;
PROTECT(S = coerceVector(S,CPLXSXP)); nprotect++;
// alloc a complex vector in C rather than R structure...
matexp = Calloc(nvar*nvar*npoints,double complex);
// Compute the exponential matrix
multi_exp_matrix_complex (&nvar, &npoints, REAL(time), COMPLEX(lambda), COMPLEX(S), COMPLEX(S1), matexp);
// Compute the expectations
build_w_complex (&nvar, &npoints, REAL(time), REAL(expectation), matexp, REAL(matdiag));
// Done.
// Free the memory
Free(matexp);
}
UNPROTECT(nprotect);
return expectation;
}
void LogicAnalyzerDisplay::updateData(const int channel, const Pothos::Packet &packet)
{
//column count changed? new labels
const size_t numElems = packet.payload.elements();
const bool changed = _tableView->columnCount() != int(numElems);
_tableView->setColumnCount(numElems);
if (changed) this->updateHeaders();
const auto dtype = packet.payload.dtype;
if (dtype.isComplex()) this->populateChannel<std::complex<qreal>>(channel, packet);
else if (dtype.isFloat()) this->populateChannel<qreal>(channel, packet);
else if (dtype.isInteger()) this->populateChannel<qlonglong>(channel, packet);
if (changed) _tableView->resizeColumnsToContents();
}
NOX::Abstract::Group::ReturnType
LOCA::LAPACK::Group::applyComplexTranspose(
const NOX::Abstract::Vector& input_real,
const NOX::Abstract::Vector& input_imag,
NOX::Abstract::Vector& result_real,
NOX::Abstract::Vector& result_imag) const
{
#ifdef HAVE_TEUCHOS_COMPLEX
// Check validity of the Jacobian
if (!isComplex())
return NOX::Abstract::Group::BadDependency;
int n = complexSolver.getMatrix().numCols();
// Copy inputs into a complex vector
std::vector< std::complex<double> > input(n);
std::vector< std::complex<double> > result(n);
const NOX::LAPACK::Vector& lapack_input_real =
dynamic_cast<const NOX::LAPACK::Vector&>(input_real);
const NOX::LAPACK::Vector& lapack_input_imag =
dynamic_cast<const NOX::LAPACK::Vector&>(input_imag);
for (int i=0; i<n; i++)
input[i] = std::complex<double>(lapack_input_real(i),
lapack_input_imag(i));
// Apply complex matrix
complexSolver.apply(true, 1, &input[0], &result[0]);
// Copy result into NOX vectors
NOX::LAPACK::Vector& lapack_result_real =
dynamic_cast<NOX::LAPACK::Vector&>(result_real);
NOX::LAPACK::Vector& lapack_result_imag =
dynamic_cast<NOX::LAPACK::Vector&>(result_imag);
for (int i=0; i<n; i++) {
lapack_result_real(i) = result[i].real();
lapack_result_imag(i) = result[i].imag();
}
return NOX::Abstract::Group::Ok;
#else
globalData->locaErrorCheck->throwError(
"LOCA::LAPACK::Group::applyComplexTranspose()",
"TEUCHOS_COMPLEX must be enabled for complex support! Reconfigure with -D Teuchos_ENABLE_COMPLEX");
return NOX::Abstract::Group::BadDependency;
#endif
}
char iupac(char *name, char *observed, char orig)
{
char *observed2;
if (isComplex(orig))
{
observed2 = lookupIupacReverse(toupper(orig));
if (!sameString(observed, observed2))
{
verbose(1, "differing observed strings %s, %s, %s\n", name, observed, observed2);
observed = observedBlend(observed, observed2);
verbose(1, "---------------\n");
}
}
return (lookupIupac(observed));
}
char iupac(char *name, char *observed, char orig)
/* Return IUPAC value based on observed. */
/* Check for clustering failure; detect attempt to do different substitution in same position. */
{
char *observed2;
if (isComplex(orig))
{
observed2 = lookupIupacReverse(toupper(orig));
if (!sameString(observed, observed2))
{
verbose(1, "differing observed strings %s, %s, %s\n", name, observed, observed2);
observed = observedBlend(observed, observed2);
verbose(1, "---------------\n");
}
}
return (lookupIupac(observed));
}
SEXP doD(SEXP args)
{
SEXP expr, var;
args = CDR(args);
if (isExpression(CAR(args))) expr = VECTOR_ELT(CAR(args), 0);
else expr = CAR(args);
if (!(isLanguage(expr) || isSymbol(expr) || isNumeric(expr) || isComplex(expr)))
error(_("'expr' must be an expression or call"));
var = CADR(args);
if (!isString(var) || length(var) < 1)
error(_("variable must be a character string"));
if (length(var) > 1)
warning(_("only the first element is used as variable name"));
var = installTrChar(STRING_ELT(var, 0));
InitDerivSymbols();
PROTECT(expr = D(expr, var));
expr = AddParens(expr);
UNPROTECT(1);
return expr;
}
bool EnumGenerator::generateToString (const EnumElement * element) {
bool complex = isComplex (element);
fprintf (mOutput, "const char* toString (%s%s e){\n", classScope().c_str(), element->name.c_str());
if (element->values.empty()){
fprintf (mOutput, "\tassert (false && \"Enum has no values\");\n");
fprintf (mOutput, "\treturn \"invalid\";\n");
fprintf (mOutput, "}\n\n");
return true;
}
if (complex) {
// no string table O(n)
fprintf (mOutput, "\t// Note: not generating string table because of non-trivial enum initializers\n");
for (EnumElement::ValueVec::const_iterator i = element->values.begin(); i != element->values.end(); i++){
fprintf (mOutput, "\tif (e == %s) return \"%s\";\n", i->first.c_str(), i->first.c_str());
}
fprintf (mOutput, "\tassert (false && \"undefined enum value\");\n");
fprintf (mOutput, "\treturn \"UNDEFINED\";\n");
} else {
// with string table
fprintf (mOutput, "\tconst char* values[] = {\n");
bool first = true;
for (EnumElement::ValueVec::const_iterator i = element->values.begin(); i != element->values.end(); i++){
fprintf (mOutput, "\t\t%s \"%s\"\n", first ? "" : ",", i->first.c_str());
first = false;
}
fprintf (mOutput, "\t};\n");
fprintf (mOutput, "\tint x = (int) e;\n");
fprintf (mOutput, "\tif (x < 0 || x >= %ld){\n", element->values.size());
fprintf (mOutput, "\t\tassert (false && \"undefined enum value\");\n");
fprintf (mOutput, "\t\treturn \"UNDEFINED\";\n");
fprintf (mOutput, "\t}\n");
fprintf (mOutput, "\treturn values[x];\n");
}
fprintf (mOutput, "}\n\n");
return true;
}
SEXP simmap_covar (SEXP nterm, SEXP bt, SEXP lambda, SEXP S, SEXP S1, SEXP sigmasq) {
int nprotect = 0;
SEXP V;
int nchar, nt, vdim[2];
nt = INTEGER(nterm)[0];
nchar = GET_LENGTH(lambda);
vdim[0] = nt*nchar; vdim[1] = vdim[0];
PROTECT(V = makearray(2,vdim)); nprotect++;
// Check if there is complex eigenvalues
if(!isComplex(lambda)){
// REAL
simmap_covar_matrix(&nchar, REAL(bt), REAL(lambda), REAL(S), REAL(S1), REAL(sigmasq), &nt, REAL(V));
}else{
// COMPLEX
simmap_covar_matrix_complex(&nchar, REAL(bt), COMPLEX(lambda), COMPLEX(S), COMPLEX(S1), REAL(sigmasq), &nt, REAL(V));
}
UNPROTECT(nprotect);
return V;
}
BSONObj Query::getHint() const {
if ( ! isComplex() )
return BSONObj();
return obj.getObjectField( "$hint" );
}
BSONObj Query::getSort() const {
if ( ! isComplex() )
return BSONObj();
return obj.getObjectField( "orderby" );
}
BSONObj Query::getFilter() const {
if ( ! isComplex() )
return obj;
return obj.getObjectField( "query" );
}
bool Query::isExplain() const {
return isComplex() && obj.getBoolField( "$explain" );
}
SEXP attribute_hidden do_cmathfuns(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP x, y = R_NilValue; /* -Wall*/
R_xlen_t i, n;
checkArity(op, args);
check1arg(args, call, "z");
if (DispatchGroup("Complex", call, op, args, env, &x))
return x;
x = CAR(args);
if (isComplex(x)) {
n = XLENGTH(x);
switch(PRIMVAL(op)) {
case 1: /* Re */
y = allocVector(REALSXP, n);
for(i = 0 ; i < n ; i++)
REAL(y)[i] = COMPLEX(x)[i].r;
break;
case 2: /* Im */
y = allocVector(REALSXP, n);
for(i = 0 ; i < n ; i++)
REAL(y)[i] = COMPLEX(x)[i].i;
break;
case 3: /* Mod */
case 6: /* abs */
y = allocVector(REALSXP, n);
for(i = 0 ; i < n ; i++)
#if HAVE_CABS
REAL(y)[i] = cabs(C99_COMPLEX2(x, i));
#else
REAL(y)[i] = hypot(COMPLEX(x)[i].r, COMPLEX(x)[i].i);
#endif
break;
case 4: /* Arg */
y = allocVector(REALSXP, n);
for(i = 0 ; i < n ; i++)
#if HAVE_CARG
REAL(y)[i] = carg(C99_COMPLEX2(x, i));
#else
REAL(y)[i] = atan2(COMPLEX(x)[i].i, COMPLEX(x)[i].r);
#endif
break;
case 5: /* Conj */
y = NO_REFERENCES(x) ? x : allocVector(CPLXSXP, n);
for(i = 0 ; i < n ; i++) {
COMPLEX(y)[i].r = COMPLEX(x)[i].r;
COMPLEX(y)[i].i = -COMPLEX(x)[i].i;
}
break;
}
}
else if(isNumeric(x)) { /* so no complex numbers involved */
n = XLENGTH(x);
if(isReal(x)) PROTECT(x);
else PROTECT(x = coerceVector(x, REALSXP));
y = NO_REFERENCES(x) ? x : allocVector(REALSXP, n);
switch(PRIMVAL(op)) {
case 1: /* Re */
case 5: /* Conj */
for(i = 0 ; i < n ; i++)
REAL(y)[i] = REAL(x)[i];
break;
case 2: /* Im */
for(i = 0 ; i < n ; i++)
REAL(y)[i] = 0.0;
break;
case 4: /* Arg */
for(i = 0 ; i < n ; i++)
if(ISNAN(REAL(x)[i]))
REAL(y)[i] = REAL(x)[i];
else if (REAL(x)[i] >= 0)
REAL(y)[i] = 0;
else
REAL(y)[i] = M_PI;
break;
case 3: /* Mod */
case 6: /* abs */
for(i = 0 ; i < n ; i++)
REAL(y)[i] = fabs(REAL(x)[i]);
break;
}
UNPROTECT(1);
}
else errorcall(call, _("non-numeric argument to function"));
if (x != y && ATTRIB(x) != R_NilValue) {
PROTECT(x);
PROTECT(y);
DUPLICATE_ATTRIB(y, x);
UNPROTECT(2);
}
return y;
}
/* "%*%" (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;
}
