2
0
Fork 0
This commit is contained in:
Daniel Kapla 2019-09-16 11:28:06 +02:00
parent 6f46cb2eaf
commit 998f8d3568
8 changed files with 490 additions and 781 deletions

348
benchmark.R Normal file
View File

@ -0,0 +1,348 @@
library(microbenchmark)
dyn.load("wip.so")
## rowSum* .call --------------------------------------------------------------
rowSums.c <- function(M) {
stopifnot(
is.matrix(M),
is.numeric(M)
)
if (!is.double(M)) {
M <- matrix(as.double(M), nrow = nrow(M))
}
.Call('R_rowSums', PACKAGE = 'wip', M)
}
colSums.c <- function(M) {
stopifnot(
is.matrix(M),
is.numeric(M)
)
if (!is.double(M)) {
M <- matrix(as.double(M), nrow = nrow(M))
}
.Call('R_colSums', PACKAGE = 'wip', M)
}
rowSquareSums.c <- function(M) {
stopifnot(
is.matrix(M),
is.numeric(M)
)
if (!is.double(M)) {
M <- matrix(as.double(M), nrow = nrow(M))
}
.Call('R_rowSquareSums', PACKAGE = 'wip', M)
}
rowSumsSymVec.c <- function(vecA, nrow, diag = 0.0) {
stopifnot(
is.vector(vecA),
is.numeric(vecA),
is.numeric(diag),
nrow * (nrow - 1) == length(vecA) * 2
)
if (!is.double(vecA)) {
vecA <- as.double(vecA)
}
.Call('R_rowSumsSymVec', PACKAGE = 'wip',
vecA, as.integer(nrow), as.double(diag))
}
rowSweep.c <- function(A, v, op = '-') {
stopifnot(
is.matrix(A),
is.numeric(v)
)
if (!is.double(A)) {
A <- matrix(as.double(A), nrow = nrow(A))
}
if (!is.vector(v) || !is.double(v)) {
v <- as.double(v)
}
stopifnot(
nrow(A) == length(v),
op %in% c('+', '-', '*', '/')
)
.Call('R_rowSweep', PACKAGE = 'wip', A, v, op)
}
## row*, col* tests ------------------------------------------------------------
n <- 3000
M <- matrix(runif(n * 12), n, 12)
stopifnot(
all.equal(rowSums(M^2), rowSums.c(M^2)),
all.equal(colSums(M), colSums.c(M))
)
microbenchmark(
rowSums = rowSums(M^2),
rowSums.c = rowSums.c(M^2),
rowSqSums.c = rowSquareSums.c(M)
)
microbenchmark(
colSums = colSums(M),
colSums.c = colSums.c(M)
)
sum = rowSums(M)
stopifnot(all.equal(
sweep(M, 1, sum, FUN = `/`),
rowSweep.c(M, sum, '/') # Col-Normalize)
), all.equal(
sweep(M, 1, sum, FUN = `/`),
M / sum
))
microbenchmark(
sweep = sweep(M, 1, sum, FUN = `/`),
M / sum,
rowSweep.c = rowSweep.c(M, sum, '/') # Col-Normalize)
)
# Create symmetric matrix with constant diagonal entries.
nrow <- 200
diag <- 1.0
Sym <- tcrossprod(runif(nrow))
diag(Sym) <- diag
# Get vectorized lower triangular part of `Sym` matrix.
SymVec <- Sym[lower.tri(Sym)]
stopifnot(all.equal(
rowSums(Sym),
rowSumsSymVec.c(SymVec, nrow, diag)
))
microbenchmark(
rowSums = rowSums(Sym),
rowSums.c = rowSums.c(Sym),
rowSumsSymVec.c = rowSumsSymVec.c(SymVec, nrow, diag)
)
## Matrix-Matrix opperation .call ---------------------------------------------
transpose.c <- function(A) {
stopifnot(
is.matrix(A), is.numeric(A)
)
if (!is.double(A)) {
A <- matrix(as.double(A), nrow(A), ncol(A))
}
.Call('R_transpose', PACKAGE = 'wip', A)
}
matrixprod.c <- function(A, B) {
stopifnot(
is.matrix(A), is.numeric(A),
is.matrix(B), is.numeric(B),
ncol(A) == nrow(B)
)
if (!is.double(A)) {
A <- matrix(as.double(A), nrow = nrow(A))
}
if (!is.double(B)) {
B <- matrix(as.double(B), nrow = nrow(B))
}
.Call('R_matrixprod', PACKAGE = 'wip', A, B)
}
crossprod.c <- function(A, B) {
stopifnot(
is.matrix(A), is.numeric(A),
is.matrix(B), is.numeric(B),
nrow(A) == nrow(B)
)
if (!is.double(A)) {
A <- matrix(as.double(A), nrow = nrow(A))
}
if (!is.double(B)) {
B <- matrix(as.double(B), nrow = nrow(B))
}
.Call('R_crossprod', PACKAGE = 'wip', A, B)
}
skewSymRank2k.c <- function(A, B, alpha = 1, beta = 0) {
stopifnot(
is.matrix(A), is.numeric(A),
is.matrix(B), is.numeric(B),
all(dim(A) == dim(B)),
is.numeric(alpha), length(alpha) == 1L,
is.numeric(beta), length(beta) == 1L
)
if (!is.double(A)) {
A <- matrix(as.double(A), nrow = nrow(A))
}
if (!is.double(B)) {
B <- matrix(as.double(B), nrow = nrow(B))
}
.Call('R_skewSymRank2k', PACKAGE = 'wip', A, B,
as.double(alpha), as.double(beta))
}
## Matrix-Matrix opperation tests ---------------------------------------------
n <- 200
k <- 100
m <- 300
A <- matrix(runif(n * k), n, k)
B <- matrix(runif(k * m), k, m)
stopifnot(
all.equal(t(A), transpose.c(A))
)
microbenchmark(
t(A),
transpose.c(A)
)
stopifnot(
all.equal(A %*% B, matrixprod.c(A, B))
)
microbenchmark(
"%*%" = A %*% B,
matrixprod.c = matrixprod.c(A, B)
)
A <- matrix(runif(k * n), k, n)
B <- matrix(runif(k * m), k, m)
stopifnot(
all.equal(crossprod(A, B), crossprod.c(A, B))
)
microbenchmark(
crossprod = crossprod(A, B),
crossprod.c = crossprod.c(A, B)
)
n <- 12
k <- 11
A <- matrix(runif(n * k), n, k)
B <- matrix(runif(n * k), n, k)
stopifnot(all.equal(
A %*% t(B) - B %*% t(A), skewSymRank2k.c(A, B)
))
microbenchmark(
A %*% t(B) - B %*% t(A),
skewSymRank2k.c(A, B)
)
## Orthogonal projection onto null space .Call --------------------------------
nullProj.c <- function(B) {
stopifnot(
is.matrix(B), is.numeric(B)
)
if (!is.double(B)) {
B <- matrix(as.double(B), nrow = nrow(B))
}
.Call('R_nullProj', PACKAGE = 'wip', B)
}
## Orthogonal projection onto null space tests --------------------------------
p <- 12
q <- 10
V <- qr.Q(qr(matrix(rnorm(p * q, 0, 1), p, q)))
# Projection matrix onto `span(V)`
Q <- diag(1, p) - tcrossprod(V, V)
stopifnot(
all.equal(Q, nullProj.c(V))
)
microbenchmark(
nullProj = diag(1, p) - tcrossprod(V, V),
nullProj.c = nullProj.c(V)
)
# ## WIP for gradient. ----------------------------------------------------------
gradient.c <- function(X, X_diff, Y, V, h) {
stopifnot(
is.matrix(X), is.double(X),
is.matrix(X_diff), is.double(X_diff),
ncol(X_diff) == ncol(X), nrow(X_diff) == nrow(X) * (nrow(X) - 1) / 2,
is.vector(Y) || (is.matrix(Y) && pmin(dim(Y)) == 1L), is.double(Y),
length(Y) == nrow(X),
is.matrix(V), is.double(V),
nrow(V) == ncol(X),
is.vector(h), is.numeric(h), length(h) == 1
)
.Call('R_gradient', PACKAGE = 'wip',
X, X_diff, as.double(Y), V, as.double(h));
}
elem.pairs <- function(elements) {
# Number of elements to match.
n <- length(elements)
# Create all combinations.
pairs <- rbind(rep(elements, each=n), rep(elements, n))
# Select unique combinations without self interaction.
return(pairs[, pairs[1, ] < pairs[2, ]])
}
grad <- function(X, Y, V, h, persistent = TRUE) {
n <- nrow(X)
p <- ncol(X)
if (!persistent) {
pair.index <- elem.pairs(seq(n))
i <- pair.index[, 1] # `i` indices of `(i, j)` pairs
j <- pair.index[, 2] # `j` indices of `(i, j)` pairs
lower <- ((i - 1) * n) + j
upper <- ((j - 1) * n) + i
X_diff <- X[i, , drop = F] - X[j, , drop = F]
}
# Projection matrix onto `span(V)`
Q <- diag(1, p) - tcrossprod(V, V)
# Vectorized distance matrix `D`.
vecD <- rowSums((X_diff %*% Q)^2)
# Weight matrix `W` (dnorm ... gaussean density function)
W <- matrix(1, n, n) # `exp(0) == 1`
W[lower] <- exp((-0.5 / h) * vecD^2) # Set lower tri. part
W[upper] <- t.default(W)[upper] # Mirror lower tri. to upper
W <- sweep(W, 2, colSums(W), FUN = `/`) # Col-Normalize
# Weighted `Y` momentums
y1 <- Y %*% W # Result is 1D -> transposition irrelevant
y2 <- Y^2 %*% W
# Per example loss `L(V, X_i)`
L <- y2 - y1^2
# Vectorized Weights with forced symmetry
vecS <- (L[i] - (Y[j] - y1[i])^2) * W[lower]
vecS <- vecS + ((L[j] - (Y[i] - y1[j])^2) * W[upper])
# Compute scaling of `X` row differences
vecS <- vecS * vecD
G <- crossprod(X_diff, X_diff * vecS) %*% V
G <- (-2 / (n * h^2)) * G
return(G)
}
rStiefl <- function(p, q) {
return(qr.Q(qr(matrix(rnorm(p * q, 0, 1), p, q))))
}
n <- 200
p <- 12
q <- 10
X <- matrix(runif(n * p), n, p)
Y <- runif(n)
V <- rStiefl(p, q)
h <- 0.1
pair.index <- elem.pairs(seq(n))
i <- pair.index[1, ] # `i` indices of `(i, j)` pairs
j <- pair.index[2, ] # `j` indices of `(i, j)` pairs
lower <- ((i - 1) * n) + j
upper <- ((j - 1) * n) + i
X_diff <- X[i, , drop = F] - X[j, , drop = F]
stopifnot(all.equal(
grad(X, Y, V, h),
gradient.c(X, X_diff, Y, V, h)
))
microbenchmark(
grad = grad(X, Y, V, h),
gradient.c = gradient.c(X, X_diff, Y, V, h)
)

View File

View File

43
build_install.R Normal file
View File

@ -0,0 +1,43 @@
## Installing CVE (C implementation)
(setwd('~/Projects/CVE/CVE_C'))
# equiv to Rcpp::compileAttributes().
library(devtools)
pkgbuild::compile_dll()
document() # See bug: https://github.com/stan-dev/rstantools/issues/52
pkgbuild::clean_dll()
(path <- build(vignettes = FALSE))
install.packages(path, repos = NULL, type = "source")
library(CVE)
## Installing CVEpureR
(setwd('~/Projects/CVE/CVE_R'))
library(devtools)
document() # See bug: https://github.com/stan-dev/rstantools/issues/52
(path <- build(vignettes = FALSE))
install.packages(path, repos = NULL, type = "source")
library(CVEpureR)
ds <- dataset("M1")
gc()
path <- '~/Projects/CVE/tmp/R.prof'
Rprof(path, append = F, line.profiling = T)
cve.res <- cve.call(ds$X, ds$Y, k = ncol(ds$B)) # , method = "linesearch"
Rprof(NULL)
(prof <- summaryRprof(path)) # , lines = "both"))
cve.res[[ncol(ds$B)]]$loss
X <- ds$X
Y <- ds$Y
k <- ncol(ds$B)
system.time(
cve.res <- cve(Y ~ X, k = k)
)
system.time(
cve.res <- cve(Y ~ X, k = k, method = "sgd", tau = 0.01, batch.size = 32L)
)
system.time(
cve.res <- cve(Y ~ X, k = k, method = "linesearch")
)

View File

@ -1,394 +0,0 @@
//
// Usage (bash):
// ~$ R -e "library(Rcpp); sourceCpp('runtime_tests_grad.cpp')"
//
// Usage (R):
// > library(Rcpp)
// > sourceCpp('runtime_tests_grad.cpp')
//
// // #define ARMA_DONT_USE_WRAPPER
// #define ARMA_DONT_USE_BLAS
// [[Rcpp::depends(RcppArmadillo)]]
#include <RcppArmadillo.h>
#include <math.h>
// [[Rcpp::export]]
arma::mat arma_grad(const arma::mat& X,
const arma::mat& X_diff,
const arma::vec& Y,
const arma::vec& Y_rep,
const arma::mat& V,
const double h) {
using namespace arma;
uword n = X.n_rows;
uword p = X.n_cols;
// orthogonal projection matrix `Q = I - VV'` for dist computation
mat Q = -(V * V.t());
Q.diag() += 1;
// calc pairwise distances as `D` with `D(i, j) = d_i(V, X_j)`
vec D_vec = sum(square(X_diff * Q), 1);
mat D = reshape(D_vec, n, n);
// calc weights as `W` with `W(i, j) = w_i(V, X_j)`
mat W = exp(D / (-2.0 * h));
W = normalise(W, 1); // colomn-wise, 1-norm
vec W_vec = vectorise(W);
// centered weighted `Y` means
vec y1 = W.t() * Y;
vec y2 = W.t() * square(Y);
// loss for each X_i, meaning `L(i) = L_n(V, X_i)`
vec L = y2 - square(y1);
// "global" loss
double loss = mean(L);
// `G = \nabla_V L_n(V)` a.k.a. gradient of `L` with respect to `V`
vec scale = (repelem(L, n, 1) - square(Y_rep - repelem(y1, n, 1))) % W_vec % D_vec;
mat X_diff_scale = X_diff.each_col() % scale;
mat G = X_diff_scale.t() * X_diff * V;
G *= -2.0 / (h * h * n);
return G;
}
// ATTENTION: assumed `X` stores X_i's column wise, `X = cbind(X_1, X_2, ..., X_n)`
// [[Rcpp::export]]
arma::mat grad(const arma::mat& X,
const arma::vec& Y,
const arma::mat& V,
const double h
) {
using namespace arma;
// get dimensions
const uword n = X.n_cols;
const uword p = X.n_rows;
const uword q = V.n_cols;
// compute orthogonal projection
mat Q = -(V * V.t());
Q.diag() += 1.0;
// distance matrix `D(i, j) = d_i(V, X_j)`
mat D(n, n, fill::zeros);
// weights matrix `W(i, j) = w_i(V, X_j)`
mat W(n, n, fill::ones); // exp(0) = 1
double mvm = 0.0; // Matrix Vector Mult.
double sos = 0.0; // Sum Of Squares
// double wcn = 0.0; // Weights Column Norm
for (uword j = 0; j + 1 < n; ++j) {
for (uword i = j + 1; i < n; ++i) {
sos = 0.0;
for (uword k = 0; k < p; ++k) {
mvm = 0.0;
for (uword l = 0; l < p; ++l) {
mvm += Q(k, l) * (X(l, i) - X(l, j));
}
sos += mvm * mvm;
}
D(i, j) = D(j, i) = sos;
W(i, j) = W(j, i) = std::exp(sos / (-2. * h));
}
}
// column normalization of weights `W`
double col_sum;
for (uword j = 0; j < n; ++j) {
col_sum = 0.0;
for (uword i = 0; i < n; ++i) {
col_sum += W(i, j);
}
for (uword i = 0; i < n; ++i) {
W(i, j) /= col_sum;
}
}
// weighted first, second order responce means `y1`, `y2`
// and component wise Loss `L(i) = L_n(V, X_i)`
vec y1(n);
vec y2(n);
vec L(n);
double tmp;
double loss = 0.0;
for (uword i = 0; i < n; ++i) {
mvm = 0.0; // Matrix Vector Mult.
sos = 0.0; // Sum Of Squared (weighted)
for (uword k = 0; k < n; ++k) {
mvm += (tmp = W(k, i) * Y(k));
sos += tmp * Y(k); // W(k, i) * Y(k) * Y(k)
}
y1(i) = mvm;
y2(i) = sos;
loss += (L(i) = sos - (mvm * mvm)); // L_n(V, X_i) = y2(i) - y1(i)^2
}
loss /= n;
mat S(n, n);
for (uword k = 0; k < n; ++k) {
for (uword l = 0; l < n; ++l) {
tmp = Y(k) - y1(l);
S(k, l) = (L(l) - (tmp * tmp)) * W(k, l) * D(k, l);
}
}
// gradient
mat G(p, q);
double factor = -2. / (n * h * h);
double gij;
for (uword j = 0; j < q; ++j) {
for (uword i = 0; i < p; ++i) {
gij = 0.0;
for (uword k = 0; k < n; ++k) {
for (uword l = 0; l < n; ++l) {
mvm = 0.0;
for (uword m = 0; m < p; ++m) {
mvm += (X(m, l) - X(m, k)) * V(m, j);
}
// gij += (S(k, l) + S(l, k)) * (X(i, l) - X(i, k));
gij += S(k, l) * (X(i, l) - X(i, k)) * mvm;
}
}
G(i, j) = factor * gij;
}
}
return G;
}
// ATTENTION: assumed `X` stores X_i's column wise, `X = cbind(X_1, X_2, ..., X_n)`
// [[Rcpp::export]]
arma::mat grad_p(const arma::mat& X_ref,
const arma::vec& Y_ref,
const arma::mat& V_ref,
const double h
) {
using arma::uword;
// get dimensions
const uword n = X_ref.n_cols;
const uword p = X_ref.n_rows;
const uword q = V_ref.n_cols;
const double* X = X_ref.memptr();
const double* Y = Y_ref.memptr();
const double* V = V_ref.memptr();
// allocate memory for entire algorithm
// Q (p,p) D+W+S (n,n) y1+L (n) G (p,q)
uword memsize = (p * p) + (3 * n * n) + (2 * n) + (p * q);
double* mem = static_cast<double*>(malloc(sizeof(double) * memsize));
// assign pointer to memory associated memory area
double* Q = mem;
double* D = Q + (p * p);
double* W = D + (n * n);
double* S = W + (n * n);
double* y1 = S + (n * n);
double* L = y1 + n;
double* G = L + n;
// compute orthogonal projection
double sum;
// compute orthogonal projection `Q = I_p - V V'`
for (uword j = 0; j < p; ++j) {
for (uword i = j; i < p; ++i) {
sum = 0.0;
for (uword k = 0; k < q; ++k) {
sum += V[k * p + i] * V[k * p + j];
}
if (i == j) {
Q[j * p + i] = 1.0 - sum;
} else {
Q[j * p + i] = Q[i * p + j] = -sum;
}
}
}
// set `diag(D) = 0` and `diag(W) = 1`.
for (uword i = 0; i < n * n; i += n + 1) {
D[i] = 0.0;
W[i] = 1.0;
}
// components (using symmetrie) of `D` and `W` (except `diag`)
double mvm = 0.0; // Matrix Vector Mult.
for (uword j = 0; j + 1 < n; ++j) {
for (uword i = j + 1; i < n; ++i) {
sum = 0.0;
for (uword k = 0; k < p; ++k) {
mvm = 0.0;
for (uword l = 0; l < p; ++l) {
mvm += Q[l * p + k] * (X[i * p + l] - X[j * p + l]);
}
sum += mvm * mvm;
}
D[j * n + i] = D[i * n + j] = sum;
W[j * n + i] = W[i * n + j] = std::exp(sum / (-2. * h));
}
}
// column normalization of weights `W`
for (uword j = 0; j < n; ++j) {
sum = 0.0;
for (uword i = 0; i < n; ++i) {
sum += W[j * n + i];
}
for (uword i = 0; i < n; ++i) {
W[j * n + i] /= sum;
}
}
// weighted first, secend order responce means `y1`, `y2`
// and component wise Loss `L(i) = L_n(V, X_i)`
double tmp;
double loss = 0.0;
for (uword i = 0; i < n; ++i) {
mvm = 0.0; // Matrix Vector Mult.
sum = 0.0; // Sum Of (weighted) Squares
for (uword k = 0; k < n; ++k) {
mvm += (tmp = W[i * n + k] * Y[k]);
sum += tmp * Y[k];
}
y1[i] = mvm;
loss += (L[i] = sum - (mvm * mvm));
}
loss /= n;
// scaling for gradient summation
// this scaling matrix is the lower triangular matrix defined as
//
// S_kl := (s_{kl} + s_{lk}) D_{kl}
// s_ij := (L_n(V, X_j) - (Y_i - y1(V, X_j))^2) W_ij
double factor;
for (uword l = 0; l < n; ++l) {
for (uword k = l + 1; k < n; ++k) {
tmp = Y[k] - y1[l];
factor = (L[l] - (tmp * tmp)) * W[l * n + k]; // \tile{S}_{kl}
tmp = Y[l] - y1[k];
factor += (L[k] - (tmp * tmp)) * W[k * n + l]; // \tile{S}_{lk}
S[l * n + k] = factor * D[l * n + k]; // (s_kl + s_lk) * D_kl
}
}
// gradient
// reuse memory area of `Q`
// no longer needed and provides enough space (`q < p`)
double* GD = Q;
const double* X_l;
const double* X_k;
for (uword j = 0; j < p; ++j) {
for (uword i = 0; i < p; ++i) {
sum = 0.0;
for (uword l = 0; l < n; ++l) {
X_l = X + (l * p);
for (uword k = l + 1; k < n; ++k) {
X_k = X + (k * p);
sum += S[l * n + k] * (X_l[i] - X_k[i]) * (X_l[j] - X_k[j]);
}
}
GD[j * p + i] = sum;
}
}
// distance gradient `DG` to gradient by multiplying with `V`
factor = -2. / (n * h * h);
for (uword i = 0; i < p; ++i) {
for (uword j = 0; j < q; ++j) {
sum = 0.0;
for (uword k = 0; k < p; ++k) {
sum += GD[k * p + i] * V[j * p + k];
}
G[j * p + i] = factor * sum;
}
}
// construct 'Armadillo' matrix from `G`s memory area
arma::mat Grad(G, p, q);
// free entire allocated memory block
free(mem);
return Grad;
}
/*** R
suppressMessages(library(microbenchmark))
cat("Start timing:\n")
time.start <- Sys.time()
rStiefl <- function(p, q) {
return(qr.Q(qr(matrix(rnorm(p * q, 0, 1), p, q))))
}
## compare runtimes
n <- 200L
p <- 12L
q <- p - 2L
X <- matrix(rnorm(n * p), n, p)
Xt <- t(X)
X_diff <- kronecker(rep(1, n), X) - kronecker(X, rep(1, n))
Y <- rnorm(n)
Y_rep <- kronecker(rep(1, n), Y) # repmat(Y, n, 1)
h <- 1. / 4.;
V <- rStiefl(p, q)
# A <- arma_grad(X, X_diff, Y, Y_rep, V, h)
# G1 <- grad(Xt, Y, V, h)
# G2 <- grad_p(Xt, Y, V, h)
#
# print(round(A[1:6, 1:6], 3))
# print(round(G1[1:6, 1:6], 3))
# print(round(G2[1:6, 1:6], 3))
# print(round(abs(A - G1), 9))
# print(round(abs(A - G2), 9))
#
# q()
comp <- function (A, B, tol = sqrt(.Machine$double.eps)) {
max(abs(A - B)) < tol
}
comp.all <- function (res) {
if (length(res) < 2) {
return(TRUE)
}
res.one = res[[1]]
for (i in 2:length(res)) {
if (!comp(res.one, res[[i]])) {
return(FALSE)
}
}
return(TRUE)
}
counter <- 0
setup.tests <- function () {
if ((counter %% 3) == 0) {
X <<- matrix(rnorm(n * p), n, p)
Xt <<- t(X)
X_diff <<- kronecker(rep(1, n), X) - kronecker(X, rep(1, n))
Y <<- rnorm(n)
Y_rep <<- kronecker(rep(1, n), Y) # arma::repmat(Y, n, 1)
h <<- 1. / 4.;
V <<- rStiefl(p, q)
}
counter <<- counter + 1
}
mbm <- microbenchmark(
arma = arma_grad(X, X_diff, Y, Y_rep, V, h),
# grad = grad(Xt, Y, V, h),
grad_p = grad_p(Xt, Y, V, h),
check = comp.all,
setup = setup.tests(),
times = 100L
)
cat("\033[1m\033[92mTotal time:", format(Sys.time() - time.start), '\n')
print(mbm)
cat("\033[0m")
boxplot(mbm, las = 2, xlab = NULL)
*/

60
test.R Normal file
View File

@ -0,0 +1,60 @@
# library(CVEpureR)
# path <- '~/Projects/CVE/tmp/logger.R.pdf'
library(CVE)
path <- '~/Projects/CVE/tmp/seeded_test.pdf'
epochs <- 100
attempts <- 25
# Define the logger for the `cve()` method.
logger <- function(env) {
# Note the `<<-` assignement!
loss.history[env$epoch + 1, env$attempt] <<- env$loss
error.history[env$epoch + 1, env$attempt] <<- env$error
tau.history[env$epoch + 1, env$attempt] <<- env$tau
# Compute true error by comparing to the true `B`
B.est <- null(env$V) # Function provided by CVE
P.est <- B.est %*% solve(t(B.est) %*% B.est) %*% t(B.est)
true.error <- norm(P - P.est, 'F') / sqrt(2 * k)
true.error.history[env$epoch + 1, env$attempt] <<- true.error
}
pdf(path)
par(mfrow = c(2, 2))
for (name in paste0("M", seq(5))) {
# Seed random number generator
set.seed(42)
# Create a dataset
ds <- dataset(name)
X <- ds$X
Y <- ds$Y
B <- ds$B # the true `B`
k <- ncol(ds$B)
# True projection matrix.
P <- B %*% solve(t(B) %*% B) %*% t(B)
# Setup histories.
loss.history <- matrix(NA, epochs + 1, attempts)
error.history <- matrix(NA, epochs + 1, attempts)
tau.history <- matrix(NA, epochs + 1, attempts)
true.error.history <- matrix(NA, epochs + 1, attempts)
dr <- cve(Y ~ X, k = k, logger = logger, epochs = epochs, attempts = attempts)
# Plot history's
matplot(loss.history, type = 'l', log = 'y', xlab = 'i (iteration)',
main = paste('loss', name),
ylab = expression(L(V[i])))
matplot(true.error.history, type = 'l', log = 'y', xlab = 'i (iteration)',
main = paste('true error', name),
ylab = expression(group('|', B * B^T - B[i] * B[i]^T, '|')[F] / sqrt(2 * k)))
matplot(error.history, type = 'l', log = 'y', xlab = 'i (iteration)',
main = paste('error', name),
ylab = expression(group('|', V[i-1] * V[i-1]^T - V[i] * V[i]^T, '|')[F]))
matplot(tau.history, type = 'l', log = 'y', xlab = 'i (iteration)',
main = paste('learning rate', name),
ylab = expression(tau[i]))
}

View File

@ -1,104 +0,0 @@
#
# Usage:
# ~$ Rscript validate.R
# load MAVE package for comparison
library(MAVE)
# load (and compile) cve and dataset source
library(Rcpp)
cat("Compiling source 'cve_V1.cpp'\n")
Rcpp::sourceCpp('cve_V1.cpp', embeddedR = FALSE)
# load dataset sampler
source('CVE/R/datasets.R')
# set default nr of simulations
nr.sim <- 25
#' Orthogonal projection to sub-space spanned by `B`
#'
#' @param B Matrix
#' @return Orthogonal Projection Matrix
proj <- function(B) {
B %*% solve(t(B) %*% B) %*% t(B)
}
#' Compute nObs given dataset dimension \code{n}.
#'
#' @param n Number of samples
#' @return Numeric estimate of \code{nObs}
nObs <- function (n) { n^0.5 }
# dataset names
dataset.names <- c("M1", "M2", "M3", "M4", "M5") # M4 not implemented jet
## prepare "logging"
# result error, time, ... data.frame's
error <- matrix(nrow = nr.sim, ncol = 2 * length(dataset.names))
time <- matrix(nrow = nr.sim, ncol = 2 * length(dataset.names))
# convert to data.frames
error <- as.data.frame(error)
time <- as.data.frame(time)
# set names
names(error) <- kronecker(c("CVE.", "MAVE."), dataset.names, paste0)
names(time) <- kronecker(c("CVE.", "MAVE."), dataset.names, paste0)
# get current time
start.time <- Sys.time()
## main comparison loop (iterate `nr.sim` times for each dataset)
for (i in seq_along(dataset.names)) {
for (j in 1:nr.sim) {
name <- dataset.names[i]
# reporting progress
cat("\rRunning Test (", name, j , "):",
(i - 1) * nr.sim + j, "/", length(dataset.names) * nr.sim,
" - Time since start:", format(Sys.time() - start.time), "\033[K")
# create new dataset
ds <- dataset(name)
k <- ncol(ds$B) # real dim
# call CVE
cve.time <- system.time(
cve.res <- cve_cpp(ds$X, ds$Y,
k = k,
nObs = nObs(nrow(ds$X)),
verbose = FALSE)
)
# call MAVE
mave.time <- system.time(
mave.res <- mave(Y ~ .,
data = data.frame(X = ds$X, Y = ds$Y),
method = "meanMAVE")
)
# compute real and approximated sub-space projections
P <- proj(ds$B) # real
P.cve <- proj(cve.res$B)
P.mave <- proj(mave.res$dir[[k]])
# compute (and store) errors
error[j, paste0("CVE.", name)] <- norm(P - P.cve, 'F') / sqrt(2 * k)
error[j, paste0("MAVE.", name)] <- norm(P - P.mave, 'F') / sqrt(2 * k)
# store run-times
time[j, paste0("CVE.", name)] <- cve.time["elapsed"]
time[j, paste0("MAVE.", name)] <- mave.time["elapsed"]
}
}
cat("\n\n## Time [sec] Means:\n")
print(colMeans(time))
cat("\n## Error Means:\n")
print(colMeans(error))
len <- length(dataset.names)
pdf("plots/Rplots_validate.pdf")
boxplot(as.matrix(error),
main = paste0("Error (nr.sim = ", nr.sim, ")"),
ylab = expression(error == group("||", P[B] - P[hat(B)], "||")[F] / sqrt(2*k)),
las = 2,
at = c(1:len, 1:len + len + 1)
)
boxplot(as.matrix(time),
main = paste0("Time (nr.sim = ", nr.sim, ")"),
ylab = "time [sec]",
las = 2,
at = c(1:len, 1:len + len + 1)
)
cat("Plot saved to 'plots/Rplots_validate.pdf'\n")
suppressMessages(dev.off())

322
wip.R
View File

@ -1,273 +1,5 @@
library(microbenchmark) library(microbenchmark)
dyn.load("wip.so")
## rowSum* .call --------------------------------------------------------------
rowSums.c <- function(M) {
stopifnot(
is.matrix(M),
is.numeric(M)
)
if (!is.double(M)) {
M <- matrix(as.double(M), nrow = nrow(M))
}
.Call('R_rowSums', PACKAGE = 'wip', M)
}
colSums.c <- function(M) {
stopifnot(
is.matrix(M),
is.numeric(M)
)
if (!is.double(M)) {
M <- matrix(as.double(M), nrow = nrow(M))
}
.Call('R_colSums', PACKAGE = 'wip', M)
}
rowSquareSums.c <- function(M) {
stopifnot(
is.matrix(M),
is.numeric(M)
)
if (!is.double(M)) {
M <- matrix(as.double(M), nrow = nrow(M))
}
.Call('R_rowSquareSums', PACKAGE = 'wip', M)
}
rowSumsSymVec.c <- function(vecA, nrow, diag = 0.0) {
stopifnot(
is.vector(vecA),
is.numeric(vecA),
is.numeric(diag),
nrow * (nrow - 1) == length(vecA) * 2
)
if (!is.double(vecA)) {
vecA <- as.double(vecA)
}
.Call('R_rowSumsSymVec', PACKAGE = 'wip',
vecA, as.integer(nrow), as.double(diag))
}
rowSweep.c <- function(A, v, op = '-') {
stopifnot(
is.matrix(A),
is.numeric(v)
)
if (!is.double(A)) {
A <- matrix(as.double(A), nrow = nrow(A))
}
if (!is.vector(v) || !is.double(v)) {
v <- as.double(v)
}
stopifnot(
nrow(A) == length(v),
op %in% c('+', '-', '*', '/')
)
.Call('R_rowSweep', PACKAGE = 'wip', A, v, op)
}
## row*, col* tests ------------------------------------------------------------
n <- 3000
M <- matrix(runif(n * 12), n, 12)
stopifnot(
all.equal(rowSums(M^2), rowSums.c(M^2)),
all.equal(colSums(M), colSums.c(M))
)
microbenchmark(
rowSums = rowSums(M^2),
rowSums.c = rowSums.c(M^2),
rowSqSums.c = rowSquareSums.c(M)
)
microbenchmark(
colSums = colSums(M),
colSums.c = colSums.c(M)
)
sum = rowSums(M)
stopifnot(all.equal(
sweep(M, 1, sum, FUN = `/`),
rowSweep.c(M, sum, '/') # Col-Normalize)
), all.equal(
sweep(M, 1, sum, FUN = `/`),
M / sum
))
microbenchmark(
sweep = sweep(M, 1, sum, FUN = `/`),
M / sum,
rowSweep.c = rowSweep.c(M, sum, '/') # Col-Normalize)
)
# Create symmetric matrix with constant diagonal entries.
nrow <- 200
diag <- 1.0
Sym <- tcrossprod(runif(nrow))
diag(Sym) <- diag
# Get vectorized lower triangular part of `Sym` matrix.
SymVec <- Sym[lower.tri(Sym)]
stopifnot(all.equal(
rowSums(Sym),
rowSumsSymVec.c(SymVec, nrow, diag)
))
microbenchmark(
rowSums = rowSums(Sym),
rowSums.c = rowSums.c(Sym),
rowSumsSymVec.c = rowSumsSymVec.c(SymVec, nrow, diag)
)
## Matrix-Matrix opperation .call ---------------------------------------------
transpose.c <- function(A) {
stopifnot(
is.matrix(A), is.numeric(A)
)
if (!is.double(A)) {
A <- matrix(as.double(A), nrow(A), ncol(A))
}
.Call('R_transpose', PACKAGE = 'wip', A)
}
matrixprod.c <- function(A, B) {
stopifnot(
is.matrix(A), is.numeric(A),
is.matrix(B), is.numeric(B),
ncol(A) == nrow(B)
)
if (!is.double(A)) {
A <- matrix(as.double(A), nrow = nrow(A))
}
if (!is.double(B)) {
B <- matrix(as.double(B), nrow = nrow(B))
}
.Call('R_matrixprod', PACKAGE = 'wip', A, B)
}
crossprod.c <- function(A, B) {
stopifnot(
is.matrix(A), is.numeric(A),
is.matrix(B), is.numeric(B),
nrow(A) == nrow(B)
)
if (!is.double(A)) {
A <- matrix(as.double(A), nrow = nrow(A))
}
if (!is.double(B)) {
B <- matrix(as.double(B), nrow = nrow(B))
}
.Call('R_crossprod', PACKAGE = 'wip', A, B)
}
skewSymRank2k.c <- function(A, B, alpha = 1, beta = 0) {
stopifnot(
is.matrix(A), is.numeric(A),
is.matrix(B), is.numeric(B),
all(dim(A) == dim(B)),
is.numeric(alpha), length(alpha) == 1L,
is.numeric(beta), length(beta) == 1L
)
if (!is.double(A)) {
A <- matrix(as.double(A), nrow = nrow(A))
}
if (!is.double(B)) {
B <- matrix(as.double(B), nrow = nrow(B))
}
.Call('R_skewSymRank2k', PACKAGE = 'wip', A, B,
as.double(alpha), as.double(beta))
}
## Matrix-Matrix opperation tests ---------------------------------------------
n <- 200
k <- 100
m <- 300
A <- matrix(runif(n * k), n, k)
B <- matrix(runif(k * m), k, m)
stopifnot(
all.equal(t(A), transpose.c(A))
)
microbenchmark(
t(A),
transpose.c(A)
)
stopifnot(
all.equal(A %*% B, matrixprod.c(A, B))
)
microbenchmark(
"%*%" = A %*% B,
matrixprod.c = matrixprod.c(A, B)
)
A <- matrix(runif(k * n), k, n)
B <- matrix(runif(k * m), k, m)
stopifnot(
all.equal(crossprod(A, B), crossprod.c(A, B))
)
microbenchmark(
crossprod = crossprod(A, B),
crossprod.c = crossprod.c(A, B)
)
n <- 12
k <- 11
A <- matrix(runif(n * k), n, k)
B <- matrix(runif(n * k), n, k)
stopifnot(all.equal(
A %*% t(B) - B %*% t(A), skewSymRank2k.c(A, B)
))
microbenchmark(
A %*% t(B) - B %*% t(A),
skewSymRank2k.c(A, B)
)
## Orthogonal projection onto null space .Call --------------------------------
nullProj.c <- function(B) {
stopifnot(
is.matrix(B), is.numeric(B)
)
if (!is.double(B)) {
B <- matrix(as.double(B), nrow = nrow(B))
}
.Call('R_nullProj', PACKAGE = 'wip', B)
}
## Orthogonal projection onto null space tests --------------------------------
p <- 12
q <- 10
V <- qr.Q(qr(matrix(rnorm(p * q, 0, 1), p, q)))
# Projection matrix onto `span(V)`
Q <- diag(1, p) - tcrossprod(V, V)
stopifnot(
all.equal(Q, nullProj.c(V))
)
microbenchmark(
nullProj = diag(1, p) - tcrossprod(V, V),
nullProj.c = nullProj.c(V)
)
# ## WIP for gradient. ----------------------------------------------------------
gradient.c <- function(X, X_diff, Y, V, h) {
stopifnot(
is.matrix(X), is.double(X),
is.matrix(X_diff), is.double(X_diff),
ncol(X_diff) == ncol(X), nrow(X_diff) == nrow(X) * (nrow(X) - 1) / 2,
is.vector(Y) || (is.matrix(Y) && pmin(dim(Y)) == 1L), is.double(Y),
length(Y) == nrow(X),
is.matrix(V), is.double(V),
nrow(V) == ncol(X),
is.vector(h), is.numeric(h), length(h) == 1
)
.Call('R_gradient', PACKAGE = 'wip',
X, X_diff, as.double(Y), V, as.double(h));
}
elem.pairs <- function(elements) { elem.pairs <- function(elements) {
# Number of elements to match. # Number of elements to match.
n <- length(elements) n <- length(elements)
@ -276,25 +8,20 @@ elem.pairs <- function(elements) {
# Select unique combinations without self interaction. # Select unique combinations without self interaction.
return(pairs[, pairs[1, ] < pairs[2, ]]) return(pairs[, pairs[1, ] < pairs[2, ]])
} }
rStiefl <- function(p, q) {
return(qr.Q(qr(matrix(rnorm(p * q, 0, 1), p, q))))
}
grad <- function(X, Y, V, h, persistent = TRUE) { grad <- function(X, Y, V, h, persistent = TRUE) {
n <- nrow(X) n <- nrow(X)
p <- ncol(X) p <- ncol(X)
if (!persistent) {
pair.index <- elem.pairs(seq(n))
i <- pair.index[, 1] # `i` indices of `(i, j)` pairs
j <- pair.index[, 2] # `j` indices of `(i, j)` pairs
lower <- ((i - 1) * n) + j
upper <- ((j - 1) * n) + i
X_diff <- X[i, , drop = F] - X[j, , drop = F]
}
# Projection matrix onto `span(V)` # Projection matrix onto `span(V)`
Q <- diag(1, p) - tcrossprod(V, V) Q <- diag(1, p) - tcrossprod(V, V)
# Vectorized distance matrix `D`. # Vectorized distance matrix `D`.
vecD <- rowSums((X_diff %*% Q)^2) vecD <- rowSums((X_diff %*% Q)^2)
# Weight matrix `W` (dnorm ... gaussean density function) # Weight matrix `W` (dnorm ... gaussean density function)
W <- matrix(1, n, n) # `exp(0) == 1` W <- matrix(1, n, n) # `exp(0) == 1`
W[lower] <- exp((-0.5 / h) * vecD^2) # Set lower tri. part W[lower] <- exp((-0.5 / h) * vecD^2) # Set lower tri. part
@ -304,7 +31,6 @@ grad <- function(X, Y, V, h, persistent = TRUE) {
# Weighted `Y` momentums # Weighted `Y` momentums
y1 <- Y %*% W # Result is 1D -> transposition irrelevant y1 <- Y %*% W # Result is 1D -> transposition irrelevant
y2 <- Y^2 %*% W y2 <- Y^2 %*% W
# Per example loss `L(V, X_i)` # Per example loss `L(V, X_i)`
L <- y2 - y1^2 L <- y2 - y1^2
@ -318,8 +44,38 @@ grad <- function(X, Y, V, h, persistent = TRUE) {
G <- (-2 / (n * h^2)) * G G <- (-2 / (n * h^2)) * G
return(G) return(G)
} }
rStiefl <- function(p, q) {
return(qr.Q(qr(matrix(rnorm(p * q, 0, 1), p, q)))) grad2 <- function(X, Y, V, h, persistent = TRUE) {
n <- nrow(X)
p <- ncol(X)
# Projection matrix onto `span(V)`
Q <- diag(1, p) - tcrossprod(V, V)
# Vectorized distance matrix `D`.
# vecD <- rowSums((X_diff %*% Q)^2)
vecD <- colSums(tcrossprod(Q, X_diff)^2)
# Weight matrix `W` (dnorm ... gaussean density function)
K <- matrix(1, n, n) # `exp(0) == 1`
K[lower] <- exp((-0.5 / h) * vecD^2) # Set lower tri. part
K[upper] <- t(K)[upper] # Mirror lower tri. to upper
# W <- sweep(K, 2, colSums(K), FUN = `/`) # Col-Normalize
# Weighted `Y` momentums
colSumsK <- colSums(K)
y1 <- (K %*% Y) / colSumsK
y2 <- (K %*% Y^2) / colSumsK
# Per example loss `L(V, X_i)`
L <- y2 - y1^2
tmp <- kronecker(matrix(y1, n, 1), matrix(Y, 1, n), `-`)^2
tmp <- as.vector(L) - tmp
tmp <- tmp * K / colSumsK
vecS <- (tmp + t(tmp))[lower] * vecD
G <- crossprod(X_diff, X_diff * vecS) %*% V
G <- (-2 / (n * h^2)) * G
return(G)
} }
n <- 200 n <- 200
@ -340,9 +96,9 @@ X_diff <- X[i, , drop = F] - X[j, , drop = F]
stopifnot(all.equal( stopifnot(all.equal(
grad(X, Y, V, h), grad(X, Y, V, h),
gradient.c(X, X_diff, Y, V, h) grad2(X, Y, V, h)
)) ))
microbenchmark( microbenchmark(
grad = grad(X, Y, V, h), grad = grad(X, Y, V, h),
gradient.c = gradient.c(X, X_diff, Y, V, h) grad2 = grad2(X, Y, V, h)
) )