tensor_predictors/tensorPredictors/R/RMReg.R

205 lines
7.8 KiB
R
Raw Normal View History

#' Regularized Matrix Regression
#'
#' Solved the regularized problem
#' \deqn{min h(B) = l(B) + J(B)}
#' for a matrix \eqn{B}.
#' where \eqn{l} is a loss function; for the GLM, we use the negative
#' log-likelihood as the loss. \eqn{J(B) = f(\sigma(B))}, where \eqn{f} is a
#' function of the singular values of \eqn{B}.
#'
2022-01-18 11:30:05 +00:00
#' Currently, only the least squares problem with nuclear norm penalty is
#' implemented.
#'
2021-12-14 19:05:47 +00:00
#' In case of \code{lambda = Inf} the maximum penalty \eqn{\lambda} is computed.
#' In this case the return value is only estimate as a single value.
#'
#' @param X the singnal data ether as a 3D tensor or a 2D matrix. In case of a
#' 3D tensor the axis are assumed to be \eqn{n\times p\times q} meaning the
#' first dimension are the observations while the second and third are the
#' `image' dimensions. When the data is provided as a matix it's assumed to be
#' of shape \eqn{n\times p q} where each observation is the vectorid `image'.
2021-12-09 12:21:38 +00:00
#' @param Z additional covariate vector (can be \code{NULL} if not required.
#' For regression with intercept set \code{Z = rep(1, n)})
#' @param y univariate response vector
2022-01-13 10:13:34 +00:00
#' @param lambda penalty term, if set to \code{Inf} max lambda is computed.
2022-01-18 11:30:05 +00:00
#' @param max.iter maximum number of gadient updates
#' @param max.line.iter maximum number of line search iterations
#' @param shape Shape of the matrix valued predictors. Required iff the
#' predictors \code{X} are provided in vectorized form, e.g. as a 2D matrix.
#' @param step.size max. stepsize for gradient updates
#' @param B0 initial value for optimization. Matrix of dimensions \eqn{p\times q}
2022-01-18 11:30:05 +00:00
#' @param beta0 initial value of additional covatiates coefficient for \eqn{Z}
#' @param alpha iterative Nesterov momentum scaling values
#' @param eps precition for main loop break conditions
2022-01-13 10:21:58 +00:00
#' @param logger logging callback invoced after every line search before break
#' condition checks. The expected function signature is of the form
2022-01-18 11:30:05 +00:00
#' \code{function(iter, loss, penalty, B, beta, step.size)}.
#'
#' @export
2022-01-18 11:30:05 +00:00
RMReg <- function(X, Z, y, lambda = 0, max.iter = 500L, max.line.iter = 50L,
shape = dim(X)[-1], step.size = 1e-3,
B0 = array(0, dim = shape),
2022-01-18 11:30:05 +00:00
beta0 = rep(0, NCOL(Z)),
alpha = function(a, t) { (1 + sqrt(1 + (2 * a)^2)) / 2 },
eps = .Machine$double.eps,
2022-01-13 10:21:58 +00:00
logger = NULL
) {
2022-01-18 11:30:05 +00:00
# Define loss (without penalty)
loss <- function(B, beta, X, Z, y) 0.5 * sum((y - Z %*% beta - X %*% c(B))^2)
# gradient of loss (without penalty)
grad <- function(B, beta, X, Z, y) {
inner <- X %*% c(B) + Z %*% beta - y
list(beta = c(crossprod(inner, Z)), B = c(crossprod(inner, X)))
}
# # and the penalty function (as function of singular values)
# penalty <- function(sigma) sum(sigma)
# Check (prepair) params
stopifnot(nrow(X) == length(y))
if (!missing(shape)) {
stopifnot(ncol(X) == prod(shape))
} else {
stopifnot(length(dim(X)) == 3)
dim(X) <- c(nrow(X), prod(shape))
}
2021-12-09 12:21:38 +00:00
if (missing(Z) || is.null(Z)) {
Z <- matrix(0, nrow(X), 1)
2022-01-18 11:30:05 +00:00
} else if (!is.matrix(Z)) {
Z <- as.matrix(Z)
2021-12-09 12:21:38 +00:00
}
2022-01-18 11:30:05 +00:00
# Set singular values of start matrix predictor coefficients
if (missing(B0)) {
2022-01-18 11:30:05 +00:00
B1.sv <- rep(0, min(shape))
} else {
2022-01-18 11:30:05 +00:00
B1.sv <- La.svd(B0, 0, 0)$d
}
2022-01-18 11:30:05 +00:00
# initialize current and previous coefficients (start position)
B1 <- B0
2022-01-18 11:30:05 +00:00
beta1 <- beta0
alpha0 <- 0
alpha1 <- 1
loss0 <- loss1 <- loss(B1, beta1, X, Z, y)
# main descent loop
no.nesterov <- FALSE
for (iter in seq_len(max.iter)) {
2021-12-14 19:05:47 +00:00
if (no.nesterov) {
2022-01-18 11:30:05 +00:00
# classic gradient step as fallback
2021-12-14 19:05:47 +00:00
S <- B1
2022-01-18 11:30:05 +00:00
s <- beta1
2021-12-14 19:05:47 +00:00
} else {
2022-01-18 11:30:05 +00:00
# momentum step (extrapolation using previous direction)
S <- B1 + ((alpha0 - 1) / alpha1) * (B1 - B0)
s <- beta1 + ((alpha0 - 1) / alpha1) * (beta1 - beta0)
2021-12-09 12:21:38 +00:00
}
2022-01-18 11:30:05 +00:00
# compute (nesterov) gradient
G <- grad(S, s, X, Z, y)
2022-01-18 11:30:05 +00:00
# backtracking line search (executed at least once)
for (delta in step.size * 0.5^seq(0, max.line.iter - 1L)) {
# Gradient step with step size delta
A <- S - delta * G$B
beta.temp <- s - delta * G$beta
2021-12-14 19:05:47 +00:00
if (lambda == Inf) {
2022-01-18 11:30:05 +00:00
# Application of Corollary 1 for estimation of max lambda
# Return max lambda estimate
return(max(La.svd(A, 0, 0)$d) / delta)
2021-12-14 19:05:47 +00:00
} else if (lambda > 0) {
# SVD of (potential) next step
svdA <- La.svd(A)
2022-01-18 11:30:05 +00:00
# Next (possible) penalized iterate
B.temp.sv <- pmax(0, svdA$d - delta * lambda)
B.temp <- svdA$u %*% (B.temp.sv * svdA$vt)
} else {
2022-01-18 11:30:05 +00:00
# in case of no penalization (pure least squares)
B.temp.sv <- La.svd(A, 0, 0)$d
B.temp <- A
}
2022-01-18 11:30:05 +00:00
# Check line search condition
# h(B.temp) <= g(B.temp | S, delta)
# \_ left _/ \_____ right _____/
# where g(B.temp | S, delta) is the first order approx. of the loss
# l(S) + <grad l(S), B - S> + | B - S |_F^2 / 2 delta + J(B)
2022-01-18 11:30:05 +00:00
left <- loss(B.temp, beta.temp, X, Z, y)
right <- loss(S, s, X, Z, y) +
sum(G$B * (B.temp - S)) + sum(G$beta * (beta.temp - s)) +
(norm(B.temp - S, 'F')^2 + sum((beta.temp - s)^2)) / (2 * delta)
if (left <= right) {
break
}
}
2022-01-18 11:30:05 +00:00
# Evaluate loss to ensure descent after line search
2022-03-22 15:26:24 +00:00
loss.temp <- left # loss(B.temp, beta.temp, X, Z, y) # already computed
2022-01-13 10:21:58 +00:00
# logging callback
if (is.function(logger)) {
2022-01-18 11:30:05 +00:00
logger(iter, loss.temp, lambda * sum(B.temp.sv),
B.temp, beta.temp, delta)
2022-01-13 10:21:58 +00:00
}
2022-01-18 11:30:05 +00:00
# after line search enforce descent
if (loss.temp + lambda * sum(B.temp.sv) <= loss1 + lambda * sum(B1.sv)) {
B0 <- B1
2022-01-18 11:30:05 +00:00
B1 <- array(B.temp, shape)
B1.sv <- B.temp.sv
beta0 <- beta1
beta1 <- beta.temp
loss0 <- loss1
loss1 <- loss.temp
no.nesterov <- FALSE # always reset
2021-12-14 19:05:47 +00:00
} else if (!no.nesterov) {
2022-01-18 11:30:05 +00:00
no.nesterov <- TRUE # retry without momentum
2021-12-14 19:05:47 +00:00
next
} else {
2022-01-18 11:30:05 +00:00
break # failed even without momentum -> stop
}
2022-01-18 11:30:05 +00:00
# check break conditions
if (sum(B1.sv) < eps) {
break # estimate is (numerically) zero -> stop
}
if ((sum(G$B^2) + sum(G$beta^2)) < eps * sum(unlist(Map(length, G)))) {
break # mean squared gradient is smaller than epsilon -> stop
2021-12-09 12:21:38 +00:00
}
2022-01-18 11:30:05 +00:00
if (abs(loss0 - loss1) < eps) {
break # decrease is smaller than epsilon -> stop
}
# update momentum scaling
alpha0 <- alpha1
alpha1 <- alpha(alpha1, iter)
2021-12-09 12:21:38 +00:00
2022-01-18 11:30:05 +00:00
# set step size to two times current delta
step.size <- 2 * delta
}
2022-01-18 11:30:05 +00:00
# Degrees of Freedom estimate (TODO: this is like in `matrix_sparsereg.m`)
sigma <- c(La.svd(A, 0, 0)$d, rep(0, max(shape) - min(shape)))
2022-01-18 11:30:05 +00:00
df <- length(beta1)
for (i in seq_len(sum(B1.sv > 0))) {
df <- df + 1 + sigma[i] * (sigma[i] - delta * lambda) * (
sum(ifelse((1:shape[1]) != i, 1 / (sigma[i]^2 - sigma[1:shape[1]]^2), 0)) +
sum(ifelse((1:shape[2]) != i, 1 / (sigma[i]^2 - sigma[1:shape[2]]^2), 0)))
}
2021-12-09 12:21:38 +00:00
# return estimates and some additional stats
list(
B = B1,
2022-01-18 11:30:05 +00:00
beta = beta1,
singular.values = B1.sv,
2021-12-09 12:21:38 +00:00
iter = iter,
df = df,
loss = loss1,
2022-03-22 15:26:24 +00:00
lambda = delta * lambda, #
2022-01-18 11:30:05 +00:00
AIC = loss1 + 2 * df, # TODO: check this!
BIC = loss1 + log(nrow(X)) * df, # TODO: check this!
2021-12-09 12:21:38 +00:00
call = match.call() # invocing function call, collects params like lambda
)
}