I'm trying to port a very fast R function for calculating cosine similarity into Rcpp with Armadillo and sparse matrix operations.
Here's the R function:
#' Compute cosine similarities between columns in x and y
#'
#' #description adapted from qlcMatrix::cosSparse
#'
#' #param x dgCMatrix with samples as columns
#' #param y dgCMatrix with samples as columns
#' #return dgCMatrix of cosine similarities pairs of columns in "x" and "y"
sparse.cos <- function(x, y) {
s <- rep(1, nrow(x))
nx <- Matrix::Diagonal(x = drop(Matrix::crossprod(x ^ 2, s)) ^ -0.5)
x <- x %*% nx
ny <- Matrix::Diagonal(x = drop(Matrix::crossprod(y ^ 2, s)) ^ -0.5)
y <- y %*% ny
return(Matrix::crossprod(x, y))
}
Here's an example usage of the R function:
library(Matrix)
m1 <- rsparsematrix(1000, 10000, density = 0.1)
m2 <- rsparsematrix(1000, 100, density = 0.2)
res <- c_sparse_cos_mat_mat(m1, m2)
And here's my best stab so far at an Rcpp function (not working):
//[[Rcpp::export]]
arma::SpMat<double> sparse_cos(const arma::SpMat<double> &x, const arma::SpMat<double> &y){
arma::vec s(x.n_rows);
s = s.fill(1);
arma::vec nx = arma::vec(1 / sqrt(square(x) * s));
arma::vec ny = arma::vec(1 / sqrt(square(y) * s));
// apply column-wise Euclidean norm to x and y
for(sp_mat::const_iterator it_x = x.begin(); it_x != x.end(); it_x++)
x.at(it_x.row(), it_x.col()) = *it_x * nx(it_x.col());
for(sp_mat::const_iterator it_y = y.begin(); it_y != y.end(); it_y++)
y.at(it_y.row(), it_y.col()) = *it_y * ny(it_y.col());
// return cross-product of x and y as cosine distance
return(x * y);
}
Questions:
What is the fastest way to multiply all non-zero values in each column of SpMat x by corresponding values in a vector of length ncol(x)?
How do I fix the issues in the Rcpp function? Specifically: lvalue required as left operand of assignment in line x.at(it_x.row(), it_x.col()) = *it_x * nx(it_x.col());.
The result is inherently dense, and ideally would be returned as a dense matrix. Is there a fast method for taking the cross-product of two sparse matrices while explicitly filling in a dense matrix with the result?
Related
I am re-writting an algorithm I did in C++ in R for practice called the Finite Difference Method. I am pretty new with R so I don't know all the rules regarding vector/matrix multiplication. For some reason I am getting a non-conformable arguments error when I do this:
ST_u <- matrix(0,M,1)
ST_l <- matrix(0,M,1)
for(i in 1:M){
Z <- matrix(gaussian_box_muller(i),M,1)
ST_u[i] <- (S0 + delta_S)*exp((r - (sigma*sigma)/(2.0))*T + sigma*sqrt(T)%*%Z)
ST_l[i] <- (S0 - delta_S)*exp((r - (sigma*sigma)/(2.0))*T + sigma*sqrt(T)%*%Z)
}
I get this error:
Error in sqrt(T) %*% Z : non-conformable arguments
Here is my whole code:
gaussian_box_muller <- function(n){
theta <- runif(n, 0, 2 * pi)
rsq <- rexp(n, 0.5)
x <- sqrt(rsq) * cos(theta)
return(x)
}
d_j <- function(j, S, K, r, v,T) {
return ((log(S/K) + (r + (-1^(j-1))*0.5*v*v)*T)/(v*(T^0.5)))
}
call_delta <- function(S,K,r,v,T){
return (S * dnorm(d_j(1, S, K, r, v, T))-K*exp(-r*T) * dnorm(d_j(2, S, K, r, v, T)))
}
Finite_Difference <- function(S0,K,r,sigma,T,M,delta_S){
ST_u <- matrix(0,M,1)
ST_l <- matrix(0,M,1)
for(i in 1:M){
Z <- matrix(gaussian_box_muller(i),M,1)
ST_u[i] <- (S0 + delta_S)*exp((r - (sigma*sigma)/(2.0))*T + sigma*sqrt(T)%*%Z)
ST_l[i] <- (S0 - delta_S)*exp((r - (sigma*sigma)/(2.0))*T + sigma*sqrt(T)%*%Z)
}
Delta <- matrix(0,M,1)
totDelta <- 0
for(i in 1:M){
if(ST_u[i] - K > 0 && ST_l[i] - K > 0){
Delta[i] <- ((ST_u[i] - K) - (ST_l[i] - K))/(2*delta_S)
}else{
Delta <- 0
}
totDelta = totDelta + exp(-r*T)*Delta[i]
}
totDelta <- totDelta * 1/M
Var <- 0
for(i in 1:M){
Var = Var + (Delta[i] - totDelta)^2
}
Var = Var*1/M
cat("The Finite Difference Delta is : ", totDelta)
call_Delta_a <- call_delta(S,K,r,sigma,T)
bias <- abs(call_Delta_a - totDelta)
cat("The bias is: ", bias)
cat("The Variance of the Finite Difference method is: ", Var)
MSE <- bias*bias + Var
cat("The marginal squared error is thus: ", MSE)
}
S0 <- 100.0
delta_S <- 0.001
K <- 100.0
r <- 0.05
sigma <- 0.2
T <- 1.0
M <- 10
result1 <- Finite_Difference(S0,K,r,sigma,T,M,delta_S)
I can't seem to figure out the problem, any suggestions would be greatly appreciated.
In R, the %*% operator is reserved for multiplying two conformable matrices. As one special case, you can also use it to multiply a vector by a matrix (or vice versa), if the vector can be treated as a row or column vector that conforms to the matrix; as a second special case, it can be used to multiply two vectors to calculate their inner product.
However, one thing it cannot do is perform scalar multipliciation. Scalar multiplication of vectors or matrices always uses the plain * operator. Specifically, in the expression sqrt(T) %*% Z, the first term sqrt(T) is a scalar, and the second Z is a matrix. If what you intend to do here is multiply the matrix Z by the scalar sqrt(T), then this should just be written sqrt(T) * Z.
When I made this change, your program still didn't work because of another bug -- S is used but never defined -- but I don't understand your algorithm well enough to attempt a fix.
A few other comments on the program not directly related to your original question:
The first loop in Finite_Difference looks suspicious: guassian_box_muller(i) generates a vector of length i as i varies in the loop from 1 up to M, and forcing these vectors into a column matrix of length M to generate Z is probably not doing what you want. It will "reuse" the values in a cycle to populate the matrix. Try these to see what I mean:
matrix(gaussian_box_muller(1),10,1) # all one value
matrix(gaussian_box_muller(3),10,1) # cycle of three values
You also use loops in many places where R's vector operations would be easier to read and (typically) faster to execute. For example, your definition of Var is equivalent to:
Var <- sum((Delta - totDelta)^2)/M
and the definitions of Delta and totDelta could also be written in this simplified fashion.
I'd suggest Googling for "vector and matrix operations in r" or something similar and reading some tutorials. Vector arithmetic in particular is idiomatic R, and you'll want to learn it early and use it often.
You might find it helpful to consider the rnorm function to generate random Gaussians.
Happy R-ing!
I am using the example from here, where the original post had an objective function returning a list, with first element equal to the value of the objective function and the second element the gradient:
logisticRegressionCost <- function(theta, X, y) {
J = 0;
theta = as.matrix(theta);
X = as.matrix(X);
y = as.matrix(y);
rows = dim(theta)[2];
cols = dim(theta)[1];
grad = matrix(0, rows, cols);
predicted = sigmoid(X %*% theta);
J = (-y) * log(predicted) - (1 - y) * log(1 - predicted);
J = sum(J) / dim(y)[1];
grad = t(predicted - y);
grad = grad %*% X;
grad = grad / dim(y)[1];
return(list(fn = J, gr = t(grad)));
}
The suggested solution to use optim is to split this into two separate functions that serve as wrappers, e.g.:
fn <- function(...){
logisticRegressionCost(...)$fn
}
gr <- function(...){
logisticRegressionCost(...)$gr
}
and thus optim can be called like optim(fn = fn, gr = gr, ...).
However, this is unsatisfactory as computation of the gradient generally relies on shared computations with the objective function. In this case, the line:
predicted = sigmoid(X %*% theta);
will definitely be duplicated.
Is there a way to use optim so that shared computations between the objective function and gradient are efficient performed?
I have the upper triangular part of matrix in R (without diagonal) and want to generate a symmetric matrix from the upper triangular part (with 1 on the diagonal but that can be adjusted later). I usually do that like this:
res.upper <- rnorm(4950)
res <- matrix(0, 100, 100)
res[upper.tri(res)] <- res.upper
rm(res.upper)
diag(res) <- 1
res[lower.tri(res)] <- t(res)[lower.tri(res)]
This works fine but now I want to work with very large matrices. Thus, I would want to avoid having to store res.upper and res (filled with 0) at the same time. Is there any way I can directly convert res.upper to a symmetric matrix without having to initialize the matrix res first?
I think there are two issues here.
now I want to work with very large matrices
Then do not use R code to do this job. R will use much more memory than you expect. Try the following code:
res.upper <- rnorm(4950)
res <- matrix(0, 100, 100)
tracemem(res) ## trace memory copies of `res`
res[upper.tri(res)] <- res.upper
rm(res.upper)
diag(res) <- 1
res[lower.tri(res)] <- t(res)[lower.tri(res)]
This is what you will get:
> res.upper <- rnorm(4950) ## allocation of length 4950 vector
> res <- matrix(0, 100, 100) ## allocation of 100 * 100 matrix
> tracemem(res)
[1] "<0xc9e6c10>"
> res[upper.tri(res)] <- res.upper
tracemem[0xc9e6c10 -> 0xdb7bcf8]: ## allocation of 100 * 100 matrix
> rm(res.upper)
> diag(res) <- 1
tracemem[0xdb7bcf8 -> 0xdace438]: diag<- ## allocation of 100 * 100 matrix
> res[lower.tri(res)] <- t(res)[lower.tri(res)]
tracemem[0xdace438 -> 0xdb261d0]: ## allocation of 100 * 100 matrix
tracemem[0xdb261d0 -> 0xccc34d0]: ## allocation of 100 * 100 matrix
In R, you have to use 5 * (100 * 100) + 4950 double words to finish these operations. While in C, you only need at most 4950 + 100 * 100 double words (In fact, 100 * 100 is all that is needed! Will talk about it later). It is difficult to overwrite object directly in R without extra memory assignment.
Is there any way I can directly convert res.upper to a symmetric matrix without having to initialize the matrix res first?
You do have to allocate memory for res because that is what you end up with; but there is no need to allocate memory for res.upper. You can initialize the upper triangular, while filling in the lower triangular at the same time. Consider the following template:
#include <Rmath.h> // use: double rnorm(double a, double b)
#include <R.h> // use: getRNGstate() and putRNGstate() for randomness
#include <Rinternals.h> // SEXP data type
## N is matrix dimension, a length-1 integer vector in R
## this function returns the matrix you want
SEXP foo(SEXP N) {
int i, j, n = asInteger(N);
SEXP R_res = PROTECT(allocVector(REALSXP, n * n)); // allocate memory for `R_res`
double *res = REAL(R_res);
double tmp; // a local variable for register reuse
getRNGstate();
for (i = 0; i < n; i++) {
res[i * n + i] = 1.0; // diagonal is 1, as you want
for (j = i + 1; j < n; j++) {
tmp = rnorm(0, 1);
res[j * n + i] = tmp; // initialize upper triangular
res[i * n + j] = tmp; // fill lower triangular
}
}
putRNGstate();
UNPROTECT(1);
return R_res;
}
The code has not been optimized, as using integer multiplication j * n + i for addressing in the innermost loop will result in performance penalty. But I believe you can move multiplication outside the inner loop, and only leave addition inside.
To get a symmetric matrix from an upper or lower triangular matrix you can add the matrix to its transpose and subtract the diagonal elements. The equation is linked below.
diag(U) is a diagonal matrix with the diagonal elements of U.
ultosymmetric=function(m){
m = m + t(m) - diag(diag(m))
return (m)}
If you want the diagonal elements to be 1 you can do this.
ultosymmetric_diagonalone=function(m){
m = m + t(m) - 2*diag(diag(m)) + diag(1,nrow=dim(m)[1])
return (m)}
I am not able to understand why is this happening. I have a data matrix which is (64x6830). When I do the following
pr.out=prcomp(data,scale=TRUE)
dim(pr.out$rotation)
# [1] 6830 64
I am not able to understand why the rotation matrix is not 6830x6830. When I take a subset of data like this:
data1=data[1:nrow(data),1:10]
pr.data=prcomp(data1,scale=TRUE)
dim(pr.data$rotation)
# [1] 10 10
So for smaller size from the same data is giving correct, but I am clueless why it is giving a different rotation matrix when done on the whole dataset.
The function prcomp is based on the function svd:
svd(x, nu = min(n, p), nv = min(n, p), LINPACK = FALSE)
From edit(stats:::prcomp.default), we see:
s <- svd(x, nu = 0)
This means that the left singular vectors are not computed. Thus, in the case of prcomp, svd only returns "a vector containing the singular values of x, of length min(n, p)" and "a matrix whose columns contain the right singular vectors of x [...]. Dimension c(p, nv)"
If we go back to the call of svd, nv is defined as nv = min(n, p) (minimum between n and p), where n = row(x) and p = ncol(x).
In the case of "data", n = 64 and p = 6830. Then nv = 64 and pr.out$rotation is a 6830x64 (p x nv) matrix
In the case of "data1", n = 10 and p = 10. Then nv = 10 and and pr.out$rotation is a 10x10 (p x nv) matrix
I'm trying to write a program that does the following:
Given two intervals A and B, for every (a,b) with a in A and b in B
create a variance matrix ymat, depending on (a,b)
calculate the (multivariate normal) density of some vector y
with mean 0 and variance matrix ymat
I learned that using loops is bad in R, so I wanted to use outer(). Here are my two functions:
y_mat <- function(n,lambda,theta,sigma) {
L <- diag(n);
L[row(L) == col(L) + 1] <- -1;
K <- t(1/n * L - theta*diag(n))%*%(1/n * L - theta*diag(n));
return(sigma^2*diag(n) + 1/lambda*K);
}
make_plot <- function(y,sigma,theta,lambda) {
n <- length(y)
sig_intv <- seq(.1,2*sigma,.01);
th_intv <- seq(-abs(2*theta),abs(2*theta),.01);
z <- outer(sig_intv,th_intv,function(s,t){dmvnorm(y,rep(0,n),y_mat(n,lambda,theta=t,sigma=s))})
contour(sig_intv,th_intv,z);
}
The shape of the variance matrix isn't relevant for this question. n and lambda are just two scalars, as are sigma and theta.
When I try
make_plot(y,.5,-3,10)
I get the following error message:
Error in t(1/n * L - theta * diag(n)) :
dims [product 25] do not match the length of object [109291]
In addition: Warning message:
In theta * diag(n) :
longer object length is not a multiple of shorter object length
Could someone enlighten me as to what's going wrong? Am I maybe going about this the wrong way?
The third argument of outer should be a vectorized function. Wrapping it with Vectorize should suffice:
make_plot <- function(y, sigma, theta, lambda) {
n <- length(y)
sig_intv <- seq(.1,2*sigma,.01);
th_intv <- seq(-abs(2*theta),abs(2*theta),.01);
z <- outer(
sig_intv, th_intv,
Vectorize(function(s,t){dmvnorm(y,rep(0,n),y_mat(n,lambda,theta=t,sigma=s))})
)
contour(sig_intv,th_intv,z);
}