diff --git a/R/block.R b/R/block.R index 01f3c8f4..f2d394ad 100644 --- a/R/block.R +++ b/R/block.R @@ -48,7 +48,7 @@ new_sparse_block <- function(x, j, sparsity, tol = 1e-08, ...) { new_tensor_block <- function(x, j, rank, mode_orth, ..., class = character()) { new_block( x, j, rank = rank, mode_orth = mode_orth, factors = NULL, - weights = NULL, ..., class = c(class, "tensor_block") + lambda = NULL, ..., class = c(class, "tensor_block") ) } diff --git a/R/block_init.R b/R/block_init.R index 9293d59d..8180faab 100644 --- a/R/block_init.R +++ b/R/block_init.R @@ -57,7 +57,7 @@ block_init.tensor_block <- function(x, init = "svd") { } }) } - x$weights <- rep(1 / sqrt(x$rank), x$rank) + x$lambda <- rep(1 / sqrt(x$rank), x$rank) return(block_project(x)) } @@ -79,11 +79,11 @@ block_init.regularized_tensor_block <- function(x, init = "svd") { } x$M <- x$tau + (1 - x$tau) * x$M / x$N - # Initialize the factors and weights using the tau = 1 strategy + # Initialize the factors and lambda using the tau = 1 strategy x <- NextMethod() - # Change weights to satisfy the constraints - x$weights <- x$weights / sqrt(x$M) + # Change lambda to satisfy the constraints + x$lambda <- x$lambda / sqrt(x$M) x$a <- x$a / sqrt(x$M) x$Y <- x$Y / sqrt(x$M) return(x) @@ -106,6 +106,6 @@ block_init.separable_regularized_tensor_block <- function(x, init = "svd") { x$x <- mode_product(x$x, x$M[[m]], m = m + 1) } - # Initialize the factors and weights using the tau = 1 strategy + # Initialize the factors and lambda using the tau = 1 strategy NextMethod() } \ No newline at end of file diff --git a/R/block_postprocess.R b/R/block_postprocess.R index efa27499..6a68eeb3 100644 --- a/R/block_postprocess.R +++ b/R/block_postprocess.R @@ -37,6 +37,6 @@ block_postprocess.separable_regularized_tensor_block <- function(x, ctrl) { x$factors <- lapply(seq_along(x$factors), function(m) { x$M[[m]] %*% x$factors[[m]] }) - x$a <- Reduce(khatri_rao, rev(x$factors)) %*% x$weights + x$a <- Reduce(khatri_rao, rev(x$factors)) %*% x$lambda NextMethod() } \ No newline at end of file diff --git a/R/block_project.R b/R/block_project.R index 9dcfd9dc..b8e68be0 100644 --- a/R/block_project.R +++ b/R/block_project.R @@ -57,7 +57,7 @@ block_project.sparse_block <- function(x) { #' @export block_project.tensor_block <- function(x) { - x$a <- Reduce(khatri_rao, rev(x$factors)) %*% x$weights + x$a <- Reduce(khatri_rao, rev(x$factors)) %*% x$lambda x$Y <- pm(matrix(x$x, nrow = nrow(x$x)), x$a, na.rm = x$na.rm) return(x) } diff --git a/R/block_update.R b/R/block_update.R index 3910077f..fdec6e88 100644 --- a/R/block_update.R +++ b/R/block_update.R @@ -31,11 +31,11 @@ block_update.tensor_block <- function(x, grad) { ) if (m == x$mode_orth) { SVD <- svd( - grad_m %*% diag(x$weights, nrow = x$rank), nu = x$rank, nv = x$rank + grad_m %*% diag(x$lambda, nrow = x$rank), nu = x$rank, nv = x$rank ) x$factors[[m]] <- SVD$u %*% t(SVD$v) } else { - x$factors[[m]] <- grad_m %*% diag(x$weights, nrow = x$rank) + x$factors[[m]] <- grad_m %*% diag(x$lambda, nrow = x$rank) x$factors[[m]] <- apply( x$factors[[m]], 2, function(y) y / norm(y, type = "2") ) @@ -43,9 +43,9 @@ block_update.tensor_block <- function(x, grad) { other_factors <- khatri_rao(x$factors[[m]], other_factors) } - # Update weights - x$weights <- t(other_factors) %*% as.vector(grad) - x$weights <- drop(x$weights) / norm(drop(x$weights), type = "2") + # Update lambda + x$lambda <- t(other_factors) %*% as.vector(grad) + x$lambda <- drop(x$lambda) / norm(drop(x$lambda), type = "2") return(block_project(x)) } @@ -63,7 +63,7 @@ block_update.regularized_tensor_block <- function(x, grad) { ) grad_m <- grad_m %*% khatri_rao( Reduce(khatri_rao, rev(x$factors[-seq_len(m)])), other_factors - ) %*% diag(x$weights, nrow = x$rank) + ) %*% diag(x$lambda, nrow = x$rank) if (m == x$mode_orth) { SVD <- svd(grad_m, nu = x$rank, nv = x$rank) x$factors[[m]] <- SVD$u %*% t(SVD$v) @@ -73,7 +73,7 @@ block_update.regularized_tensor_block <- function(x, grad) { other_factors <- khatri_rao(x$factors[[m]], other_factors) } - # Update weights + # Update lambda u <- drop(t(other_factors) %*% as.vector(grad)) w_ref <- drop(ginv( @@ -85,25 +85,25 @@ block_update.regularized_tensor_block <- function(x, grad) { w_opt <- u / (norm(u, type = "2") * sqrt(x$M)) - eps <- 0.5 * drop(t(u) %*% (x$weights + w_opt)) + eps <- 0.5 * drop(t(u) %*% (x$lambda + w_opt)) # If w_ref is satisfying, keep w_ref, otherwise find a point that # increases the criterion and satisfies the constraints between # w_ref and w_opt if (all(w_ref_norm == w_opt)) { - x$weights <- w_ref_norm + x$lambda <- w_ref_norm } else if (t(u) %*% w_ref_norm >= eps) { - x$weights <- w_ref_norm + x$lambda <- w_ref_norm } else { if (1 / x$M - eps^2 / crossprod(u) > .Machine$double.eps) { Pu <- diag(x$rank) - tcrossprod(u / norm(u, type = "2")) mu <- norm(Pu %*% w_ref, type = "2") / drop(sqrt( 1 / x$M - eps^2 / crossprod(u) )) - x$weights <- eps / drop(crossprod(u)) * u + drop(Pu %*% w_ref) / mu + x$lambda <- eps / drop(crossprod(u)) * u + drop(Pu %*% w_ref) / mu } else { # collinearity between u and w_ref - x$weights <- w_opt + x$lambda <- w_opt } } return(block_project(x)) diff --git a/R/rgcca_inner_loop.R b/R/rgcca_inner_loop.R index e04bd70e..5717ad61 100644 --- a/R/rgcca_inner_loop.R +++ b/R/rgcca_inner_loop.R @@ -89,9 +89,9 @@ rgcca_inner_loop <- function(A, C, g, dg, tau = rep(1, length(A)), a <- lapply(block_objects, "[[", "a") Y <- do.call(cbind, lapply(block_objects, "[[", "Y")) factors <- lapply(block_objects, "[[", "factors") - weights <- lapply(block_objects, "[[", "weights") + lambda <- lapply(block_objects, "[[", "lambda") return(list( - Y = Y, a = a, factors = factors, weights = weights, crit = crit, tau = tau + Y = Y, a = a, factors = factors, lambda = lambda, crit = crit, tau = tau )) } diff --git a/R/rgcca_outer_loop.R b/R/rgcca_outer_loop.R index e65977d3..ff74c6dc 100644 --- a/R/rgcca_outer_loop.R +++ b/R/rgcca_outer_loop.R @@ -50,7 +50,7 @@ rgcca_outer_loop <- function(blocks, connection = 1 - diag(length(blocks)), crit <- list() R <- blocks - a <- Y <- weights <- lapply(seq(J), function(b) c()) + a <- Y <- lambda <- lapply(seq(J), function(b) c()) factors <- lapply(seq(J), function(b) { lapply(seq_along(dim(R[[b]])[-1]), function(m) NULL) }) @@ -112,7 +112,7 @@ rgcca_outer_loop <- function(blocks, connection = 1 - diag(length(blocks)), computed_tau[n, ] <- gcca_result$tau crit[[n]] <- gcca_result$crit - # Store Y, a, factors and weights + # Store Y, a, factors and lambda a <- lapply(seq(J), function(b) cbind(a[[b]], gcca_result$a[[b]])) Y <- lapply(seq(J), function(b) cbind(Y[[b]], gcca_result$Y[, b])) factors <- lapply(seq(J), function(b) { @@ -120,8 +120,8 @@ rgcca_outer_loop <- function(blocks, connection = 1 - diag(length(blocks)), cbind(factors[[b]][[m]], gcca_result$factors[[b]][[m]]) }) }) - weights <- lapply( - seq(J), function(b) cbind(weights[[b]], gcca_result$weights[[b]]) + lambda <- lapply( + seq(J), function(b) cbind(lambda[[b]], gcca_result$lambda[[b]]) ) # Deflation procedure @@ -133,7 +133,7 @@ rgcca_outer_loop <- function(blocks, connection = 1 - diag(length(blocks)), } # If there is a superblock and weight vectors are orthogonal, it is possible - # to have non meaningful weights associated to blocks that have been set to + # to have non meaningful lambda associated to blocks that have been set to # zero by the deflation if (superblock && !comp_orth) { a <- lapply(a, function(x) { @@ -159,7 +159,7 @@ rgcca_outer_loop <- function(blocks, connection = 1 - diag(length(blocks)), a = a, astar = astar, factors = factors, - weights = weights, + lambda = lambda, tau = computed_tau, crit = crit, primal_dual = primal_dual )