Merge branch 'master' of https://git.art-ist.cc/daniel/tensor_predictors
This commit is contained in:
commit
8da1950d02
|
@ -11,5 +11,6 @@ export(dist.subspace)
|
||||||
export(matpow)
|
export(matpow)
|
||||||
export(matrixImage)
|
export(matrixImage)
|
||||||
export(reduce)
|
export(reduce)
|
||||||
|
export(tensor_predictor)
|
||||||
import(stats)
|
import(stats)
|
||||||
useDynLib(tensorPredictors, .registration = TRUE)
|
useDynLib(tensorPredictors, .registration = TRUE)
|
||||||
|
|
|
@ -23,7 +23,7 @@
|
||||||
#' @param Z additional covariate vector (can be \code{NULL} if not required.
|
#' @param Z additional covariate vector (can be \code{NULL} if not required.
|
||||||
#' For regression with intercept set \code{Z = rep(1, n)})
|
#' For regression with intercept set \code{Z = rep(1, n)})
|
||||||
#' @param y univariate response vector
|
#' @param y univariate response vector
|
||||||
#' @param lambda penalty term, if set to \code{Inf}
|
#' @param lambda penalty term, if set to \code{Inf} max lambda is computed.
|
||||||
#' @param loss loss function, part of the objective function
|
#' @param loss loss function, part of the objective function
|
||||||
#' @param penalty penalty function with a vector of the singular values if the
|
#' @param penalty penalty function with a vector of the singular values if the
|
||||||
#' current iterate as arguments. The default function
|
#' current iterate as arguments. The default function
|
||||||
|
@ -68,6 +68,7 @@ RMReg <- function(X, Z, y, lambda = 0,
|
||||||
Z <- matrix(0, nrow(X), 1)
|
Z <- matrix(0, nrow(X), 1)
|
||||||
ZZiZ <- NULL
|
ZZiZ <- NULL
|
||||||
} else {
|
} else {
|
||||||
|
if (!is.matrix(Z)) Z <- as.matrix(Z)
|
||||||
# Compute (Z' Z)^{-1} Z used to solve for beta. This is constant
|
# Compute (Z' Z)^{-1} Z used to solve for beta. This is constant
|
||||||
# throughout and the variable name stands for "((Z' Z) Inverse) Z"
|
# throughout and the variable name stands for "((Z' Z) Inverse) Z"
|
||||||
ZZiZ <- solve(crossprod(Z, Z), t(Z))
|
ZZiZ <- solve(crossprod(Z, Z), t(Z))
|
||||||
|
@ -89,7 +90,7 @@ RMReg <- function(X, Z, y, lambda = 0,
|
||||||
loss1 <- loss(B1, beta, X, Z, y)
|
loss1 <- loss(B1, beta, X, Z, y)
|
||||||
|
|
||||||
# Start without, the nesterov momentum is zero anyway
|
# Start without, the nesterov momentum is zero anyway
|
||||||
no.nesterov <- TRUE
|
no.nesterov <- TRUE # Set to FALSE after the first iteration
|
||||||
### Repeat untill convergence
|
### Repeat untill convergence
|
||||||
for (iter in 1:max.iter) {
|
for (iter in 1:max.iter) {
|
||||||
# Extrapolation with Nesterov Momentum
|
# Extrapolation with Nesterov Momentum
|
||||||
|
|
|
@ -1,28 +1,45 @@
|
||||||
#' Plots a matrix as an image
|
#' Plots a matrix as an image
|
||||||
#'
|
#'
|
||||||
#' @param A a matrix to be plotted
|
#' @param A a matrix to be plotted
|
||||||
|
#' @param add.values boolean indicating if matrix values are to be written into
|
||||||
|
#' matrix element boxes
|
||||||
#' @param main overall title for the plot
|
#' @param main overall title for the plot
|
||||||
#' @param sub sub-title of the plot
|
#' @param sub sub-title of the plot
|
||||||
#' @param interpolate a logical vector (or scalar) indicating whether to apply
|
#' @param interpolate a logical vector (or scalar) indicating whether to apply
|
||||||
#' linear interpolation to the image when drawing.
|
#' linear interpolation to the image when drawing.
|
||||||
#' @param ... further arguments passed to \code{\link{rasterImage}}
|
#' @param ... further arguments passed to \code{\link{rasterImage}}
|
||||||
#'
|
#'
|
||||||
|
#' @examples
|
||||||
|
#' AR <- 0.5^abs(outer(1:10, 1:10, `-`))
|
||||||
|
#' matrixImage(AR, AR > 0.2, main = "Autoregressiv Covariance")
|
||||||
|
#'
|
||||||
#' @export
|
#' @export
|
||||||
matrixImage <- function(A, main = NULL, sub = NULL, interpolate = FALSE, ...) {
|
matrixImage <- function(A, add.values = FALSE,
|
||||||
|
main = NULL, sub = NULL, interpolate = FALSE, ...
|
||||||
# Scale values of `A` to [0, 1] with min mapped to 1 and max to 0.
|
) {
|
||||||
A <- (max(A) - A) / diff(range(A))
|
|
||||||
|
|
||||||
# plot raster image
|
# plot raster image
|
||||||
plot(c(0, ncol(A)), c(0, nrow(A)), type = "n", bty = "n", col = "red",
|
plot(c(0, ncol(A)), c(0, nrow(A)), type = "n", bty = "n", col = "red",
|
||||||
xlab = "", ylab = "", xaxt = "n", yaxt = "n", main = main, sub = sub)
|
xlab = "", ylab = "", xaxt = "n", yaxt = "n", main = main, sub = sub)
|
||||||
|
|
||||||
# Add X-axis giving index
|
# Scale values of `A` to [0, 1] with min mapped to 1 and max to 0.
|
||||||
ind <- seq(1, ncol(A), by = 1)
|
S <- (max(A) - A) / diff(range(A))
|
||||||
axis(1, at = ind - 0.5, labels = ind, lwd = 0, lwd.ticks = 1)
|
|
||||||
# Add Y-axis
|
|
||||||
ind <- seq(1, nrow(A))
|
|
||||||
axis(2, at = ind - 0.5, labels = rev(ind), lwd = 0, lwd.ticks = 1, las = 1)
|
|
||||||
|
|
||||||
rasterImage(A, 0, 0, ncol(A), nrow(A), interpolate = interpolate, ...)
|
# Raster Image ploting the matrix with element values mapped to grayscale
|
||||||
|
# as big elements (original matrix A) are dark and small (negative) elements
|
||||||
|
# are white.
|
||||||
|
rasterImage(S, 0, 0, ncol(A), nrow(A), interpolate = interpolate, ...)
|
||||||
|
|
||||||
|
# Add X-axis giving index
|
||||||
|
x <- seq(1, ncol(A), by = 1)
|
||||||
|
axis(1, at = x - 0.5, labels = x, lwd = 0, lwd.ticks = 1)
|
||||||
|
# Add Y-axis
|
||||||
|
y <- seq(1, nrow(A))
|
||||||
|
axis(2, at = y - 0.5, labels = rev(y), lwd = 0, lwd.ticks = 1, las = 1)
|
||||||
|
|
||||||
|
# Writes matrix values (in colored element grids)
|
||||||
|
if (any(add.values)) {
|
||||||
|
if (length(add.values) > 1) { A[!add.values] <- NA }
|
||||||
|
text(rep(x - 0.5, nrow(A)), rep(rev(y - 0.5), each = ncol(A)), A,
|
||||||
|
adj = 0.5, col = as.integer(S > 0.65))
|
||||||
|
}
|
||||||
}
|
}
|
||||||
|
|
|
@ -18,6 +18,7 @@ log.likelihood <- function(par, X, Fy, Delta.inv, da, db) {
|
||||||
sum(error * (error %*% Delta.inv))
|
sum(error * (error %*% Delta.inv))
|
||||||
}
|
}
|
||||||
|
|
||||||
|
#' @export
|
||||||
tensor_predictor <- function(X, Fy, p, t, k = 1L, r = 1L, d1 = 1L, d2 = 1L,
|
tensor_predictor <- function(X, Fy, p, t, k = 1L, r = 1L, d1 = 1L, d2 = 1L,
|
||||||
method = "KPIR_LS",
|
method = "KPIR_LS",
|
||||||
eps1 = 1e-2, eps2 = 1e-2, maxit = 10L) {
|
eps1 = 1e-2, eps2 = 1e-2, maxit = 10L) {
|
||||||
|
|
Loading…
Reference in New Issue