subset NumericMatrix by row and column names in Rcpp - rcpp

Question

I am trying to create a function in Rcpp that will take as input a pairwise numeric matrix, as well as a list of vectors, each element being a subset of row/column names. I would like this function identify the subset of the matrix that matches those names, and return the mean of the values.
Below I generated some dummy data that resembles the sort of data I have, and follow with an attempt of a Rcpp function.
library(Rcpp)
dat <- c(spA = 4, spB = 10, spC = 8, spD = 1, spE = 5, spF = 9)
pdist <- as.matrix(dist(dat))
pdist[upper.tri(pdist, diag = TRUE)] <- NA
Here I have a list made up of character vectors of various subsets of the row/column names in pdist
subsetList <- replicate(10, sample(names(dat), 4), simplify=FALSE)
For each of these sets of names, I would like to identify the subset of the pairwise matrix and take the mean of the values
Here is what I have so far, which does not work, but I think it illustrates where I am trying to get.
cppFunction('
List meanDistByCell(List input, NumericMatrix pairmat) {
int n = input.size();
List out(n);
List dimnames = pairmat.attr( "dimnames" );
CharacterVector colnames = dimnames[1];
for (int i = 0; i < n; i++) {
CharacterVector sp = as< CharacterVector >(input[i]);
if (sp.size() > 0) {
out[i] = double(mean(pairmat(sp, sp)));
} else {
out[i] = NA_REAL;
}
}
return out;
}
')
Any help would be greatly appreciated! Thanks!

Answer 1

Although (contiguous) range-based subsetting is available (e.g. x(Range(first_row, last_row), Range(first_col, last_col))), as coatless pointed out, subsetting by CharacterVector is not currently supported, so you will have to roll your own for the time being. A general-ish approach might look something like this:
template <int RTYPE> inline Matrix<RTYPE>
Subset2D(const Matrix<RTYPE>& x, CharacterVector crows, CharacterVector ccols) {
R_xlen_t i = 0, j = 0, rr = crows.length(), rc = ccols.length(), pos;
Matrix<RTYPE> res(rr, rc);
CharacterVector xrows = rownames(x), xcols = colnames(x);
IntegerVector rows = match(crows, xrows), cols = match(ccols, xcols);
for (; j < rc; j++) {
// NB: match returns 1-based indices
pos = cols[j] - 1;
for (i = 0; i < rr; i++) {
res(i, j) = x(rows[i] - 1, pos);
}
}
rownames(res) = crows;
colnames(res) = ccols;
return res;
}
// [[Rcpp::export]]
NumericMatrix subset2d(NumericMatrix x, CharacterVector rows, CharacterVector cols) {
return Subset2D(x, rows, cols);
}
This assumes that the input matrix has both row and column names, and that the row and column lookup vectors are valid subsets of those dimnames; additional defensive code could be added to make this more robust. To demonstrate,
subset2d(pdist, subsetList[[1]], subsetList[[1]])
# spB spD spE spC
# spB NA NA NA NA
# spD 9 NA NA 7
# spE 5 4 NA 3
# spC 2 NA NA NA
pdist[subsetList[[1]], subsetList[[1]]]
# spB spD spE spC
# spB NA NA NA NA
# spD 9 NA NA 7
# spE 5 4 NA 3
# spC 2 NA NA NA
Subset2D takes care of most of the boilerplate involved in implementing meanDistByCell; all that remains is to loop over the input list, apply this to each list element, and store the mean of the result in the output list:
// [[Rcpp::export]]
List meanDistByCell(List keys, NumericMatrix x, bool na_rm = false) {
R_xlen_t i = 0, sz = keys.size();
List res(sz);
if (!na_rm) {
for (; i < sz; i++) {
res[i] = NumericVector::create(
mean(Subset2D(x, keys[i], keys[i]))
);
}
} else {
for (; i < sz; i++) {
res[i] = NumericVector::create(
mean(na_omit(Subset2D(x, keys[i], keys[i])))
);
}
}
return res;
}
all.equal(
lapply(subsetList, function(x) mean(pdist[x, x], na.rm = TRUE)),
meanDistByCell2(subsetList, pdist, TRUE)
)
# [1] TRUE
Although the use of Subset2D allows for a much cleaner implementation of meanDistByCell, in this situation it is inefficient for at least a couple of reasons:
It sets the dimnames of the return object (rownames(res) = crows;, colnames(res) = ccols;), which you have no need for here.
It makes a call to match to obtain indices for each of rownames and colnames, which is unnecessary since you know in advance that rownames(x) == colnames(x).
You will incur the cost of both of these points k times, for an input list with length k.
A more efficient -- but consequently less concise -- approach would be to essentially implement only the aspects of Subset2D that are needed, inline inside of meanDistByCell:
// [[Rcpp::export]]
List meanDistByCell2(List keys, NumericMatrix x, bool na_rm = false) {
R_xlen_t k = 0, sz = keys.size(), i = 0, j = 0, nidx, pos;
List res(sz);
CharacterVector cx = colnames(x);
if (!na_rm) {
for (; k < sz; k++) {
// NB: match returns 1-based indices
IntegerVector idx = match(as<CharacterVector>(keys[k]), cx) - 1;
nidx = idx.size();
NumericVector tmp(nidx * nidx);
for (j = 0; j < nidx; j++) {
pos = idx[j];
for (i = 0; i < nidx; i++) {
tmp[nidx * j + i] = x(idx[i], pos);
}
}
res[k] = NumericVector::create(mean(tmp));
}
} else {
for (; k < sz; k++) {
IntegerVector idx = match(as<CharacterVector>(keys[k]), cx) - 1;
nidx = idx.size();
NumericVector tmp(nidx * nidx);
for (j = 0; j < nidx; j++) {
pos = idx[j];
for (i = 0; i < nidx; i++) {
tmp[nidx * j + i] = x(idx[i], pos);
}
}
res[k] = NumericVector::create(mean(na_omit(tmp)));
}
}
return res;
}
all.equal(
meanDistByCell(subsetList, pdist, TRUE),
meanDistByCell2(subsetList, pdist, TRUE)
)
# [1] TRUE