130 lines
4.2 KiB
C
130 lines
4.2 KiB
C
// The need for `USE_FC_LEN_T` and `FCONE` is due to a Fortran character string
|
|
// to C incompatibility. See: Writing R Extentions: 6.6.1 Fortran character strings
|
|
#define USE_FC_LEN_T
|
|
// Disables remapping of R API functions from `Rf_<name>` or `R_<name>`
|
|
#define R_NO_REMAP
|
|
#include <R.h>
|
|
#include <Rinternals.h>
|
|
#include <R_ext/BLAS.h>
|
|
#ifndef FCONE
|
|
#define FCONE
|
|
#endif
|
|
|
|
/**
|
|
* Tensor Times Matrix a.k.a. Mode Product
|
|
*
|
|
* @param A multi-dimensional array
|
|
* @param B matrix
|
|
* @param m mode index (1-indexed)
|
|
* @param op boolean if `B` is transposed
|
|
*/
|
|
extern SEXP ttm(SEXP A, SEXP B, SEXP m, SEXP op) {
|
|
|
|
// get zero indexed mode
|
|
const int mode = Rf_asInteger(m) - 1;
|
|
|
|
// get dimension attribute of A
|
|
SEXP dim = Rf_getAttrib(A, R_DimSymbol);
|
|
|
|
// operation on `B` (transposed or not)
|
|
const int trans = Rf_asLogical(op);
|
|
|
|
// as well as `B`s dimensions
|
|
const int nrow = Rf_nrows(B);
|
|
const int ncol = Rf_ncols(B);
|
|
|
|
// validate mode (mode must be smaller than the nr of dimensions)
|
|
if (mode < 0 || Rf_length(dim) <= mode) {
|
|
Rf_error("Illegal mode");
|
|
}
|
|
|
|
// and check if B is a matrix of non degenetate size
|
|
if (!Rf_isMatrix(B)) {
|
|
Rf_error("Expected a matrix as second argument");
|
|
}
|
|
if (!Rf_nrows(B) || !Rf_ncols(B)) {
|
|
Rf_error("Zero dimension detected");
|
|
}
|
|
|
|
// check matching of dimensions
|
|
if (INTEGER(dim)[mode] != (trans ? nrow : ncol)) {
|
|
Rf_error("Dimension missmatch");
|
|
}
|
|
|
|
// calc nr of response elements `prod(dim(A)[-mode]) * ncol(A)` (size of C),
|
|
int sizeC = 1;
|
|
// and the strides
|
|
// `stride[0] <- prod(dim(A)[seq_len(mode - 1)])`
|
|
// `stride[1] <- dim(A)[mode]`
|
|
// `stride[2] <- prod(dim(A)[-seq_len(mode)])`
|
|
int stride[3] = {1, INTEGER(dim)[mode], 1};
|
|
for (int i = 0; i < Rf_length(dim); ++i) {
|
|
int size = INTEGER(dim)[i];
|
|
// check for non-degenetate dimensions
|
|
if (!size) {
|
|
Rf_error("Zero dimension detected");
|
|
}
|
|
sizeC *= (i == mode) ? (trans ? ncol : nrow) : size;
|
|
stride[0] *= (i < mode) ? size : 1;
|
|
stride[2] *= (i > mode) ? size : 1;
|
|
}
|
|
|
|
// create response object C
|
|
SEXP C = PROTECT(Rf_allocVector(REALSXP, sizeC));
|
|
|
|
// raw data access pointers
|
|
double* a = REAL(A);
|
|
double* b = REAL(B);
|
|
double* c = REAL(C);
|
|
|
|
// Tensor Times Matrix / Mode Product
|
|
const double zero = 0.0;
|
|
const double one = 1.0;
|
|
if (mode == 0) {
|
|
// mode 1: (A x_1 op(B))_(1) = op(B) A_(1) as a single Matrix-Matrix
|
|
// multiplication
|
|
F77_CALL(dgemm)(trans ? "T" : "N", "N",
|
|
(trans ? &ncol : &nrow), &stride[2], &stride[1], &one,
|
|
b, &nrow, a, &stride[1],
|
|
&zero, c, (trans ? &ncol : &nrow)
|
|
FCONE FCONE);
|
|
} else {
|
|
// Other modes can be written as blocks of matrix multiplications
|
|
// (A x_m op(B))_(m)' = A_(m)' op(B)'
|
|
for (int i2 = 0; i2 < stride[2]; ++i2) {
|
|
F77_CALL(dgemm)("N", trans ? "N" : "T",
|
|
&stride[0], (trans ? &ncol : &nrow), &stride[1], &one,
|
|
&a[i2 * stride[0] * stride[1]], &stride[0], b, &nrow,
|
|
&zero, &c[i2 * stride[0] * (trans ? ncol : nrow)], &stride[0]
|
|
FCONE FCONE);
|
|
}
|
|
}
|
|
/*
|
|
// (reference implementation)
|
|
// Tensor Times Matrix / Mode Product for `op(B) == B`
|
|
memset(c, 0, sizeC * sizeof(double));
|
|
for (int i2 = 0; i2 < stride[2]; ++i2) {
|
|
for (int i1 = 0; i1 < stride[1]; ++i1) { // stride[1] == ncols(B)
|
|
for (int j = 0; j < nrow; ++j) {
|
|
for (int i0 = 0; i0 < stride[0]; ++i0) {
|
|
c[i0 + (j + i2 * nrow) * stride[0]] +=
|
|
a[i0 + (i1 + i2 * stride[1]) * stride[0]] * b[j + i1 * nrow];
|
|
}
|
|
}
|
|
}
|
|
}
|
|
*/
|
|
|
|
// finally, set result dimensions
|
|
SEXP newdim = PROTECT(Rf_allocVector(INTSXP, Rf_length(dim)));
|
|
for (int i = 0; i < Rf_length(dim); ++i) {
|
|
INTEGER(newdim)[i] = (i == mode) ? (trans ? ncol : nrow) : INTEGER(dim)[i];
|
|
}
|
|
Rf_setAttrib(C, R_DimSymbol, newdim);
|
|
|
|
// release C to the hands of the garbage collector
|
|
UNPROTECT(2);
|
|
|
|
return C;
|
|
}
|