ica/0000755000176200001440000000000014262064632011013 5ustar liggesusersica/NAMESPACE0000644000176200001440000000033514210227554012230 0ustar liggesusersexportPattern("^[[:alpha:]]+") S3method(print, icafast) S3method(print, icaimax) S3method(print, icajade) importFrom("graphics", "par", "plot") importFrom("stats", "dexp", "dnorm", "dt", "rexp", "rnorm", "rt", "runif")ica/ChangeLog0000644000176200001440000000324214262057231012563 0ustar liggesusers Changes from ver 1.0-2 to ver 1.0-3 [July-08-2022] 1) Computational improvements for n < p * Now computes initial PCA using eigen of X %*% t(X) if n < p * Applies to all ICA functions (fast, imax, and jade) 2) Added "ica" wrapper function * Can be used to fit ICA model via FastICA, Infomax, or JADE * The "method" argument controls the decomposition method 3) Added "converged" output to all ICA functions * converged = TRUE if algorithm converged (w.r.t. user-specified tol) * converged = FALSE if maximum number of iterations (maxit) is reached 4) Added classes and print method for all ICA functions * Outputs are now of class "icafast", "icaimax", or "icajade" * Print method prints basic details about model fit and algorithm Changes from ver 1.0-1 to ver 1.0-2 [May-24-2018] 1) ica-package * Package file is now update-to-date with Description file * Updated references throughout * Remove "congru" function from package 2) congru * Removed function from package * See "multiway" package for a duplicate of congru Changes from ver 1.0-0 to ver 1.0-1 [Aug-24-2015] 1) ica-package * Improvements and updates to internals of all functions * Changed "acyidx" to "acy" * Major changes to congru functionality (for matrices) * Bug fix for icafast with alpha != 1 2) acy (acyidx) * Changed function name from "acyidx" to "acy" * Minor updates to help file and internals 3) congru * Change in default behavior if "x" and "y" are matrices * Now comparable to "cor" and "cov" functions * Calculates congruence coefficient matrices 4) icafast * Bug fix for alpha inputs not equal to 1ica/man/0000755000176200001440000000000014262057416011570 5ustar liggesusersica/man/icajade.Rd0000644000176200001440000001011214210222012013405 0ustar liggesusers\name{icajade} \alias{icajade} \title{ ICA via JADE Algorithm } \description{ Computes ICA decomposition using Cardoso and Souloumiac's (1993, 1996) Joint Approximate Diagonalization of Eigenmatrices (JADE) approach. } \usage{ icajade(X, nc, center = TRUE, maxit = 100, tol = 1e-6, Rmat = diag(nc)) } \arguments{ \item{X}{ Data matrix with \code{n} rows (samples) and \code{p} columns (variables). } \item{nc}{ Number of components to extract. } \item{center}{ If \code{TRUE}, columns of \code{X} are mean-centered before ICA decomposition. } \item{maxit}{ Maximum number of algorithm iterations to allow. } \item{tol}{ Convergence tolerance. } \item{Rmat}{ Initial estimate of the \code{nc}-by-\code{nc} orthogonal rotation matrix. } } \value{ \item{S}{Matrix of source signal estimates (\code{S = Y \%*\% R}).} \item{M}{Estimated mixing matrix.} \item{W}{Estimated unmixing matrix (\code{W = crossprod(R, Q)}).} \item{Y}{Whitened data matrix.} \item{Q}{Whitening matrix.} \item{R}{Orthogonal rotation matrix.} \item{vafs}{Variance-accounted-for by each component.} \item{iter}{Number of algorithm iterations.} \item{converged}{Logical indicating if algorithm converged.} } \references{ Cardoso, J.F., & Souloumiac, A. (1993). Blind beamforming for non-Gaussian signals. \emph{IEE Proceedings-F, 140}(6), 362-370. \doi{https://doi.org/10.1049/ip-f-2.1993.0054} Cardoso, J.F., & Souloumiac, A. (1996). Jacobi angles for simultaneous diagonalization. \emph{SIAM Journal on Matrix Analysis and Applications, 17}(1), 161-164. \doi{10.1137/S0895479893259546} Helwig, N.E. & Hong, S. (2013). A critique of Tensor Probabilistic Independent Component Analysis: Implications and recommendations for multi-subject fMRI data analysis. \emph{Journal of Neuroscience Methods, 213}(2), 263-273. \doi{https://doi.org/10.1016/j.jneumeth.2012.12.009} } \author{ Nathaniel E. Helwig } \details{ \bold{ICA Model} The ICA model can be written as \code{X = tcrossprod(S, M) + E}, where \code{S} contains the source signals, \code{M} is the mixing matrix, and \code{E} contains the noise signals. Columns of \code{X} are assumed to have zero mean. The goal is to find the unmixing matrix \code{W} such that columns of \code{S = tcrossprod(X, W)} are independent as possible. \bold{Whitening} Without loss of generality, we can write \code{M = P \%*\% R} where \code{P} is a tall matrix and \code{R} is an orthogonal rotation matrix. Letting \code{Q} denote the pseudoinverse of \code{P}, we can whiten the data using \code{Y = tcrossprod(X, Q)}. The goal is to find the orthongal rotation matrix \code{R} such that the source signal estimates \code{S = Y \%*\% R} are as independent as possible. Note that \code{W = crossprod(R, Q)}. \bold{JADE} The JADE approach finds the orthogonal rotation matrix \code{R} that (approximately) diagonalizes the cumulant array of the source signals. See Cardoso and Souloumiac (1993,1996) and Helwig and Hong (2013) for specifics of the JADE algorithm. } \seealso{ \code{\link{icafast}} for FastICA \code{\link{icaimax}} for ICA via Infomax } \examples{ ########## EXAMPLE 1 ########## # generate noiseless data (p == r) set.seed(123) nobs <- 1000 Amat <- cbind(icasamp("a", "rnd", nobs), icasamp("b", "rnd", nobs)) Bmat <- matrix(2 * runif(4), nrow = 2, ncol = 2) Xmat <- tcrossprod(Amat, Bmat) # ICA via JADE with 2 components imod <- icajade(Xmat, nc = 2) acy(Bmat, imod$M) cor(Amat, imod$S) ########## EXAMPLE 2 ########## # generate noiseless data (p != r) set.seed(123) nobs <- 1000 Amat <- cbind(icasamp("a", "rnd", nobs), icasamp("b", "rnd", nobs)) Bmat <- matrix(2 * runif(200), nrow = 100, ncol = 2) Xmat <- tcrossprod(Amat, Bmat) # ICA via JADE with 2 components imod <- icajade(Xmat, nc = 2) cor(Amat, imod$S) ########## EXAMPLE 3 ########## # generate noisy data (p != r) set.seed(123) nobs <- 1000 Amat <- cbind(icasamp("a", "rnd", nobs), icasamp("b", "rnd", nobs)) Bmat <- matrix(2 * runif(200), 100, 2) Emat <- matrix(rnorm(10^5), nrow = 1000, ncol = 100) Xmat <- tcrossprod(Amat,Bmat) + Emat # ICA via JADE with 2 components imod <- icajade(Xmat, nc = 2) cor(Amat, imod$S) } ica/man/icaimax.Rd0000644000176200001440000001231114210171715013460 0ustar liggesusers\name{icaimax} \alias{icaimax} \title{ ICA via Infomax Algorithm } \description{ Computes ICA decomposition using Bell and Sejnowski's (1995) Information-Maximization (Infomax) approach with various options. } \usage{ icaimax(X, nc, center = TRUE, maxit = 100, tol = 1e-6, Rmat = diag(nc), alg = "newton", fun = "tanh", signs = rep(1, nc), signswitch = TRUE, rate = 1, rateanneal = NULL) } \arguments{ \item{X}{ Data matrix with \code{n} rows (samples) and \code{p} columns (variables). } \item{nc}{ Number of components to extract. } \item{center}{ If \code{TRUE}, columns of \code{X} are mean-centered before ICA decomposition. } \item{maxit}{ Maximum number of algorithm iterations to allow. } \item{tol}{ Convergence tolerance. } \item{Rmat}{ Initial estimate of the \code{nc}-by-\code{nc} orthogonal rotation matrix. } \item{alg}{ Algorithm to use: \code{alg="newton"} for Newton iteration, and \code{alg="gradient"} for gradient descent. } \item{fun}{ Nonlinear (squashing) function to use for algorithm: \code{fun="tanh"} for hyperbolic tangent, \code{fun="log"} for logistic, and \code{fun="ext"} for extended Infomax. } \item{signs}{ Vector of length \code{nc} such that \code{signs[j] = 1} if j-th component is super-Gaussian and \code{signs[j] = -1} if j-th component is sub-Gaussian. Only used if \code{fun="ext"}. Ignored if \code{signswitch=TRUE}. } \item{signswitch}{ If \code{TRUE}, the \code{signs} vector is automatically determined from the data; otherwise a confirmatory ICA decomposition is calculated using input \code{signs} vector. Only used if \code{fun="ext"}. } \item{rate}{ Learing rate for gradient descent algorithm. Ignored if \code{alg="newton"}. } \item{rateanneal}{ Annealing angle and proportion for gradient descent learing rate (see Details). Ignored if \code{alg="newton"}. } } \value{ \item{S}{Matrix of source signal estimates (\code{S = Y \%*\% R}).} \item{M}{Estimated mixing matrix.} \item{W}{Estimated unmixing matrix (\code{W = crossprod(R, Q)}).} \item{Y}{Whitened data matrix.} \item{Q}{Whitening matrix.} \item{R}{Orthogonal rotation matrix.} \item{vafs}{Variance-accounted-for by each component.} \item{iter}{Number of algorithm iterations.} \item{alg}{Algorithm used (same as input).} \item{fun}{Contrast function (same as input).} \item{signs}{Component signs (same as input).} \item{rate}{Learning rate (same as input).} \item{converged}{Logical indicating if algorithm converged.} } \references{ Bell, A.J. & Sejnowski, T.J. (1995). An information-maximization approach to blind separation and blind deconvolution. \emph{Neural Computation, 7}(6), 1129-1159. \doi{10.1162/neco.1995.7.6.1129} Helwig, N.E. & Hong, S. (2013). A critique of Tensor Probabilistic Independent Component Analysis: Implications and recommendations for multi-subject fMRI data analysis. \emph{Journal of Neuroscience Methods, 213}(2), 263-273. \doi{https://doi.org/10.1016/j.jneumeth.2012.12.009} } \author{ Nathaniel E. Helwig } \details{ \bold{ICA Model} The ICA model can be written as \code{X = tcrossprod(S, M) + E}, where \code{S} contains the source signals, \code{M} is the mixing matrix, and \code{E} contains the noise signals. Columns of \code{X} are assumed to have zero mean. The goal is to find the unmixing matrix \code{W} such that columns of \code{S = tcrossprod(X, W)} are independent as possible. \bold{Whitening} Without loss of generality, we can write \code{M = P \%*\% R} where \code{P} is a tall matrix and \code{R} is an orthogonal rotation matrix. Letting \code{Q} denote the pseudoinverse of \code{P}, we can whiten the data using \code{Y = tcrossprod(X, Q)}. The goal is to find the orthongal rotation matrix \code{R} such that the source signal estimates \code{S = Y \%*\% R} are as independent as possible. Note that \code{W = crossprod(R, Q)}. \bold{Infomax} The Infomax approach finds the orthogonal rotation matrix \code{R} that (approximately) maximizes the joint entropy of a nonlinear function of the estimated source signals. See Bell and Sejnowski (1995) and Helwig and Hong (2013) for specifics of algorithms. } \seealso{ \code{\link{icafast}} for FastICA \code{\link{icajade}} for ICA via JADE } \examples{ ########## EXAMPLE 1 ########## # generate noiseless data (p == r) set.seed(123) nobs <- 1000 Amat <- cbind(icasamp("a", "rnd", nobs), icasamp("b", "rnd", nobs)) Bmat <- matrix(2 * runif(4), nrow = 2, ncol = 2) Xmat <- tcrossprod(Amat, Bmat) # ICA via Infomax with 2 components imod <- icaimax(Xmat, nc = 2) acy(Bmat, imod$M) cor(Amat, imod$S) ########## EXAMPLE 2 ########## # generate noiseless data (p != r) set.seed(123) nobs <- 1000 Amat <- cbind(icasamp("a", "rnd", nobs), icasamp("b", "rnd", nobs)) Bmat <- matrix(2 * runif(200), nrow = 100, ncol = 2) Xmat <- tcrossprod(Amat, Bmat) # ICA via Infomax with 2 components imod <- icaimax(Xmat, nc = 2) cor(Amat, imod$S) ########## EXAMPLE 3 ########## # generate noisy data (p != r) set.seed(123) nobs <- 1000 Amat <- cbind(icasamp("a", "rnd", nobs), icasamp("b", "rnd", nobs)) Bmat <- matrix(2 * runif(200), 100, 2) Emat <- matrix(rnorm(10^5), nrow = 1000, ncol = 100) Xmat <- tcrossprod(Amat,Bmat) + Emat # ICA via Infomax with 2 components imod <- icaimax(Xmat, nc = 2) cor(Amat, imod$S) } ica/man/ica.Rd0000644000176200001440000001322014210223762012601 0ustar liggesusers\name{ica} \alias{ica} %- Also NEED an '\alias' for EACH other topic documented here. \title{ ICA via FastICA, Infomax, or JADE } \description{ Computes ICA decomposition using Hyvarinen's (1999) FastICA algorithm, Bell and Sejnowski's (1995) Information-Maximization (Infomax) algorithm, or Cardoso and Souloumiac's (1993, 1996) Joint Approximate Diagonalization of Eigenmatrices (JADE) algorithm. } \usage{ ica(X, nc, method = c("fast", "imax", "jade"), ...) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{X}{ Data matrix with \code{n} rows (samples) and \code{p} columns (variables). } \item{nc}{ Number of components to extract. } \item{method}{ Method for decomposition. } \item{...}{ Additional arguments to be passed to other ICA functions (see Details). } } \details{ \bold{ICA Model} The ICA model can be written as \code{X = tcrossprod(S, M) + E}, where \code{S} contains the source signals, \code{M} is the mixing matrix, and \code{E} contains the noise signals. Columns of \code{X} are assumed to have zero mean. The goal is to find the unmixing matrix \code{W} such that columns of \code{S = tcrossprod(X, W)} are independent as possible. \bold{Whitening} Without loss of generality, we can write \code{M = P \%*\% R} where \code{P} is a tall matrix and \code{R} is an orthogonal rotation matrix. Letting \code{Q} denote the pseudoinverse of \code{P}, we can whiten the data using \code{Y = tcrossprod(X, Q)}. The goal is to find the orthongal rotation matrix \code{R} such that the source signal estimates \code{S = Y \%*\% R} are as independent as possible. Note that \code{W = crossprod(R, Q)}. \bold{Method} This is a wrapper function for the functions \code{\link{icafast}}, \code{\link{icaimax}}, or \code{\link{icajade}}. See the corresponding function for details on the method, as well as the available arguments (handled by the \code{...} argument). } \value{ \item{S}{Matrix of source signal estimates (\code{S = Y \%*\% R}).} \item{M}{Estimated mixing matrix.} \item{W}{Estimated unmixing matrix (\code{W = crossprod(R, Q)}).} \item{Y}{Whitened data matrix.} \item{Q}{Whitening matrix.} \item{R}{Orthogonal rotation matrix.} \item{vafs}{Variance-accounted-for by each component.} \item{iter}{Number of algorithm iterations.} \item{converged}{Logical indicating if algorithm converged.} \item{...}{Other arguments (if \code{method = "fast"} or \code{method = "imax"}).} } \references{ Bell, A.J. & Sejnowski, T.J. (1995). An information-maximization approach to blind separation and blind deconvolution. \emph{Neural Computation, 7}(6), 1129-1159. \doi{10.1162/neco.1995.7.6.1129} Cardoso, J.F., & Souloumiac, A. (1993). Blind beamforming for non-Gaussian signals. \emph{IEE Proceedings-F, 140}(6), 362-370. \doi{https://doi.org/10.1049/ip-f-2.1993.0054} Cardoso, J.F., & Souloumiac, A. (1996). Jacobi angles for simultaneous diagonalization. \emph{SIAM Journal on Matrix Analysis and Applications, 17}(1), 161-164. \doi{10.1137/S0895479893259546} Helwig, N.E. & Hong, S. (2013). A critique of Tensor Probabilistic Independent Component Analysis: Implications and recommendations for multi-subject fMRI data analysis. \emph{Journal of Neuroscience Methods, 213}(2), 263-273. \doi{https://doi.org/10.1016/j.jneumeth.2012.12.009} Hyvarinen, A. (1999). Fast and robust fixed-point algorithms for independent component analysis. \emph{IEEE Transactions on Neural Networks, 10}(3), 626-634. \doi{10.1109/72.761722} } \author{ Nathaniel E. Helwig } %% ~Make other sections like Warning with \section{Warning }{....} ~ \seealso{ \code{\link{icafast}} for ICA via FastICA \code{\link{icaimax}} for ICA via Infomax \code{\link{icajade}} for ICA via JADE } \examples{ ########## EXAMPLE 1 ########## # generate noiseless data (p == r) set.seed(123) nobs <- 1000 Amat <- cbind(icasamp("a", "rnd", nobs), icasamp("b", "rnd", nobs)) Bmat <- matrix(2 * runif(4), nrow = 2, ncol = 2) Xmat <- tcrossprod(Amat, Bmat) # ICA via different algorithms imod.fast <- ica(Xmat, nc = 2) imod.imax <- ica(Xmat, nc = 2, method = "imax") imod.jade <- ica(Xmat, nc = 2, method = "jade") # compare mixing matrix recovery acy(Bmat, imod.fast$M) acy(Bmat, imod.imax$M) acy(Bmat, imod.jade$M) # compare source signal recovery cor(Amat, imod.fast$S) cor(Amat, imod.imax$S) cor(Amat, imod.jade$S) ########## EXAMPLE 2 ########## # generate noiseless data (p != r) set.seed(123) nobs <- 1000 Amat <- cbind(icasamp("a", "rnd", nobs), icasamp("b", "rnd", nobs)) Bmat <- matrix(2 * runif(200), nrow = 100, ncol = 2) Xmat <- tcrossprod(Amat, Bmat) # ICA via different algorithms imod.fast <- ica(Xmat, nc = 2) imod.imax <- ica(Xmat, nc = 2, method = "imax") imod.jade <- ica(Xmat, nc = 2, method = "jade") # compare source signal recovery cor(Amat, imod.fast$S) cor(Amat, imod.imax$S) cor(Amat, imod.jade$S) ########## EXAMPLE 3 ########## # generate noisy data (p != r) set.seed(123) nobs <- 1000 Amat <- cbind(icasamp("a", "rnd", nobs), icasamp("b", "rnd", nobs)) Bmat <- matrix(2 * runif(200), 100, 2) Emat <- matrix(rnorm(10^5), nrow = 1000, ncol = 100) Xmat <- tcrossprod(Amat,Bmat) + Emat # ICA via different algorithms imod.fast <- ica(Xmat, nc = 2) imod.imax <- ica(Xmat, nc = 2, method = "imax") imod.jade <- ica(Xmat, nc = 2, method = "jade") # compare source signal recovery cor(Amat, imod.fast$S) cor(Amat, imod.imax$S) cor(Amat, imod.jade$S) } % Add one or more standard keywords, see file 'KEYWORDS' in the % R documentation directory (show via RShowDoc("KEYWORDS")): % \keyword{ ~kwd1 } % \keyword{ ~kwd2 } % Use only one keyword per line. % For non-standard keywords, use \concept instead of \keyword: % \concept{ ~cpt1 } % \concept{ ~cpt2 } % Use only one concept per line. ica/man/ica-internal.Rd0000644000176200001440000000061114210224170014405 0ustar liggesusers% Part of the R ica package, % Nathaniel E. Helwig \name{ica-internal} %% List of Internal Functions Called \alias{sdiag} \alias{print.icafast} \alias{print.icaimax} \alias{print.icajade} \title{Internal Functions for ica Package} \description{ Internal functions for ica package. } \details{ These functions are not to be called by the user. } \keyword{ internal } ica/man/icafast.Rd0000644000176200001440000001127714210171727013474 0ustar liggesusers\name{icafast} \alias{icafast} \title{ ICA via FastICA Algorithm } \description{ Computes ICA decomposition using Hyvarinen's (1999) FastICA algorithm with various options. } \usage{ icafast(X, nc, center = TRUE, maxit = 100, tol = 1e-6, Rmat = diag(nc), alg = "par", fun = "logcosh", alpha = 1) } \arguments{ \item{X}{ Data matrix with \code{n} rows (samples) and \code{p} columns (variables). } \item{nc}{ Number of components to extract. } \item{center}{ If \code{TRUE}, columns of \code{X} are mean-centered before ICA decomposition. } \item{maxit}{ Maximum number of algorithm iterations to allow. } \item{tol}{ Convergence tolerance. } \item{Rmat}{ Initial estimate of the \code{nc}-by-\code{nc} orthogonal rotation matrix. } \item{alg}{ Algorithm to use: \code{alg="par"} to estimate all \code{nc} components in parallel (default) or \code{alg="def"} for deflation estimation (i.e., projection pursuit). } \item{fun}{ Contrast function to use for negentropy approximation: \code{fun="logcosh"} for log of hyperbolic cosine, \code{fun="exp"} for Gaussian kernel, and \code{fun="kur"} for kurtosis. } \item{alpha}{ Tuning parameter for "logcosh" contrast function (1 <= \code{alpha} <= 2). } } \value{ \item{S}{Matrix of source signal estimates (\code{S = Y \%*\% R}).} \item{M}{Estimated mixing matrix.} \item{W}{Estimated unmixing matrix (\code{W = crossprod(R, Q)}).} \item{Y}{Whitened data matrix.} \item{Q}{Whitening matrix.} \item{R}{Orthogonal rotation matrix.} \item{vafs}{Variance-accounted-for by each component.} \item{iter}{Number of algorithm iterations.} \item{alg}{Algorithm used (same as input).} \item{fun}{Contrast function (same as input).} \item{alpha}{Tuning parameter (same as input).} \item{converged}{Logical indicating if algorithm converged.} } \references{ Helwig, N.E. & Hong, S. (2013). A critique of Tensor Probabilistic Independent Component Analysis: Implications and recommendations for multi-subject fMRI data analysis. \emph{Journal of Neuroscience Methods, 213}(2), 263-273. \doi{https://doi.org/10.1016/j.jneumeth.2012.12.009} Hyvarinen, A. (1999). Fast and robust fixed-point algorithms for independent component analysis. \emph{IEEE Transactions on Neural Networks, 10}(3), 626-634. \doi{10.1109/72.761722} } \author{ Nathaniel E. Helwig } \details{ \bold{ICA Model} The ICA model can be written as \code{X = tcrossprod(S, M) + E}, where \code{S} contains the source signals, \code{M} is the mixing matrix, and \code{E} contains the noise signals. Columns of \code{X} are assumed to have zero mean. The goal is to find the unmixing matrix \code{W} such that columns of \code{S = tcrossprod(X, W)} are independent as possible. \bold{Whitening} Without loss of generality, we can write \code{M = P \%*\% R} where \code{P} is a tall matrix and \code{R} is an orthogonal rotation matrix. Letting \code{Q} denote the pseudoinverse of \code{P}, we can whiten the data using \code{Y = tcrossprod(X, Q)}. The goal is to find the orthongal rotation matrix \code{R} such that the source signal estimates \code{S = Y \%*\% R} are as independent as possible. Note that \code{W = crossprod(R, Q)}. \bold{FastICA} The FastICA algorithm finds the orthogonal rotation matrix \code{R} that (approximately) maximizes the negentropy of the estimated source signals. Negentropy is approximated using \deqn{J(s) = [ E(G(s)) - E(G(z)) ]^2} where \emph{E} denotes the expectation, \emph{G} is the contrast function, and \emph{z} is a standard normal variable. See Hyvarinen (1999) or Helwig and Hong (2013) for specifics of fixed-point algorithm. } \seealso{ \code{\link{icaimax}} for ICA via Infomax \code{\link{icajade}} for ICA via JADE } \examples{ ########## EXAMPLE 1 ########## # generate noiseless data (p == r) set.seed(123) nobs <- 1000 Amat <- cbind(icasamp("a", "rnd", nobs), icasamp("b", "rnd", nobs)) Bmat <- matrix(2 * runif(4), nrow = 2, ncol = 2) Xmat <- tcrossprod(Amat, Bmat) # ICA via FastICA with 2 components imod <- icafast(Xmat, nc = 2) acy(Bmat, imod$M) cor(Amat, imod$S) ########## EXAMPLE 2 ########## # generate noiseless data (p != r) set.seed(123) nobs <- 1000 Amat <- cbind(icasamp("a", "rnd", nobs), icasamp("b", "rnd", nobs)) Bmat <- matrix(2 * runif(200), nrow = 100, ncol = 2) Xmat <- tcrossprod(Amat, Bmat) # ICA via FastICA with 2 components imod <- icafast(Xmat, nc = 2) cor(Amat, imod$S) ########## EXAMPLE 3 ########## # generate noisy data (p != r) set.seed(123) nobs <- 1000 Amat <- cbind(icasamp("a", "rnd", nobs), icasamp("b", "rnd", nobs)) Bmat <- matrix(2 * runif(200), 100, 2) Emat <- matrix(rnorm(10^5), nrow = 1000, ncol = 100) Xmat <- tcrossprod(Amat,Bmat) + Emat # ICA via FastICA with 2 components imod <- icafast(Xmat, nc = 2) cor(Amat, imod$S) } ica/man/icasamp.Rd0000644000176200001440000000345113301346052013465 0ustar liggesusers\name{icasamp} \alias{icasamp} \title{ Sample from Various Source Signal Distributions } \description{ Sample observations from the 18 source signal distributions used in Bach and Jordan (2002). Can also return density values and kurtosis for each distribution. Use \code{\link{icaplot}} to plot distributions. } \usage{ icasamp(dname, query = c("rnd","pdf","kur"), nsamp = NULL, data = NULL) } \arguments{ \item{dname}{ Distribution name: letter "a" through "r" (see Bach & Jordan, 2002). } \item{query}{ What to return: \code{query="rnd"} for random sample, \code{query="pdf"} for density values, and \code{query="kur"} for kurtosis. } \item{nsamp}{ Number of observations to sample. Only used if \code{query="rnd"}. } \item{data}{ Data values for density evaluation. Only used if \code{query="pdf"}. } } \value{ If \code{query="rnd"}, returns random sample of size \code{nsamp}. If \code{query="pdf"}, returns density for input \code{data}. If \code{query="kur"}, returns kurtosis of distribution. } \references{ Bach, F.R. (2002). \emph{kernel-ica}. MATLAB toolbox (ver 1.2) http://www.di.ens.fr/~fbach/kernel-ica/. Bach, F.R. & Jordan, M.I. (2002). Kernel independent component analysis. \emph{Journal of Machine Learning Research, 3}, 1-48. } \author{ Nathaniel E. Helwig } \details{ Inspired by \code{usr_distrib.m} from Bach's (2002) \code{kernel-ica} MATLAB toolbox. } \examples{ ########## EXAMPLE ########## # sample 1000 observations from distribution "f" set.seed(123) mysamp <- icasamp("f","rnd",nsamp=1000) xr <- range(mysamp) hist(mysamp,freq=FALSE,ylim=c(0,.8),breaks=sqrt(1000)) # evaluate density of distribution "f" xseq <- seq(-5,5,length.out=1000) mypdf <- icasamp("f","pdf",data=xseq) lines(xseq,mypdf) # evaluate kurtosis of distribution "f" icasamp("f","kur") } ica/man/icaplot.Rd0000644000176200001440000000247513301346004013505 0ustar liggesusers\name{icaplot} \alias{icaplot} \title{ Plot Densities of Source Signal Distributions } \description{ Plot density (pdf) and kurtosis for the 18 source signal distributions used in Bach and Jordan (2002); see \code{\link{icasamp}} for more information. } \usage{ icaplot(xseq = seq(-2,2,length.out=500), xlab = "", ylab = "", lty = 1, lwd = 1, col = "black", ...) } \arguments{ \item{xseq}{ Sequence of ordered data values for plotting density. } \item{xlab}{ X-axis label for plot (default is no label). } \item{ylab}{ Y-axis label for plot (default is no label). } \item{lty}{ Line type for each density (scalar or vector of length 18). } \item{lwd}{ Line width for each density (scalar or vector of length 18). } \item{col}{ Line color for each density (scalar or vector of length 18). } \item{...}{ Optional inputs for \code{plot}. } } \value{ Produces a plot with \code{NULL} return value. } \references{ Bach, F.R. (2002). \emph{kernel-ica}. MATLAB toolbox (ver 1.2) http://www.di.ens.fr/~fbach/kernel-ica/. Bach, F.R. & Jordan, M.I. (2002). Kernel independent component analysis. \emph{Journal of Machine Learning Research, 3}, 1-48. } \author{ Nathaniel E. Helwig } \examples{ \dontrun{ ########## EXAMPLE ########## quartz(height=9,width=7) par(mar=c(3,3,3,3)) icaplot() } } ica/man/acy.Rd0000644000176200001440000000300012566474505012633 0ustar liggesusers\name{acy} \alias{acy} \title{ Amari-Cichocki-Yang Error } \description{ The Amari-Cichocki-Yang (ACY) error is an asymmetric measure of dissimilarity between two nonsingular matrices \code{X} and \code{Y}. The ACY error: (a) is invariant to permutation and rescaling of the columns of \code{X} and \code{Y}, (b) ranges between 0 and \code{n-1}, and (c) equals 0 if and only if \code{X} and \code{Y} are identical up to column permutations and rescalings. } \usage{ acy(X,Y) } \arguments{ \item{X}{ Nonsingular matrix of dimension \eqn{n \times n} (test matrix). } \item{Y}{ Nonsingular matrix of dimension \eqn{n \times n} (target matrix). } } \value{ Returns a scalar (the ACY error). } \references{ Amari, S., Cichocki, A., & Yang, H.H. (1996). A new learning algorithm for blind signal separation. In D. S. Touretzky, M. C. Mozer, and M. E. Hasselmo (Eds.), \emph{Advances in Neural Information Processing Systems, 8}. Cambridge, MA: MIT Press. } \author{ Nathaniel E. Helwig } \details{ The ACY error is defined as \deqn{\frac{1}{2n}\sum_{i=1}^{n}\left(\frac{\sum_{j=1}^{n}|a_{ij}|}{\max_{j}|a_{ij}|}-1\right) + \frac{1}{2n}\sum_{j=1}^{n}\left(\frac{\sum_{i=1}^{n}|a_{ij}|}{\max_{i}|a_{ij}|}-1\right) } where \eqn{a_{ij} = (\mathbf{Y}^{-1}\mathbf{X})_{ij}}. } \section{Warnings }{ If \code{Y} is singular, function will produce an error. } \examples{ ########## EXAMPLE ########## set.seed(1) X <- matrix(runif(16),4,4) Y <- matrix(runif(16),4,4) Z <- X[,c(3,1,2,4)]\%*\%diag(1:4) acy(X,Y) acy(X,Z) } ica/DESCRIPTION0000644000176200001440000000100314262064632012513 0ustar liggesusersPackage: ica Type: Package Title: Independent Component Analysis Version: 1.0-3 Date: 2022-07-08 Author: Nathaniel E. Helwig Maintainer: Nathaniel E. Helwig Description: Independent Component Analysis (ICA) using various algorithms: FastICA, Information-Maximization (Infomax), and Joint Approximate Diagonalization of Eigenmatrices (JADE). License: GPL (>= 2) NeedsCompilation: no Packaged: 2022-07-08 16:45:10 UTC; nate Repository: CRAN Date/Publication: 2022-07-08 17:30:02 UTC ica/build/0000755000176200001440000000000014262057426012115 5ustar liggesusersica/build/partial.rdb0000644000176200001440000000007514262057426014244 0ustar liggesusers‹‹àb```b`abd`b1…À€… H02°0piÖ¼ÄÜÔb C"Éðw‚a7ica/R/0000755000176200001440000000000014210220440011174 5ustar liggesusersica/R/icaplot.R0000644000176200001440000000140613301345745012773 0ustar liggesusersicaplot <- function(xseq = seq(-2,2,length.out=500), xlab = "", ylab = "", lty = 1, lwd = 1, col = "black", ...){ if(length(lty)!=18L){ lty <- rep(lty[1],18) } if(length(lwd)!=18L){ lwd <- rep(lwd[1],18) } if(length(col)!=18L){ col <- rep(col[1],18) } xlim <- range(xseq) par(mfrow=c(6,3)) for(i in 1:18){ myfun <- as.character(letters[i]) kurto <- icasamp(myfun,"kur") myden <- icasamp(myfun,"pdf",data=xseq) tit1p <- bquote("("*.(myfun)*")") tit2p <- bquote(k==.(round(kurto,2))) mytit <- bquote(.(tit1p)*" "*.(tit2p)) plot(xseq,myden,type="l",ylim=c(0,max(myden)+.1), xlab=xlab,ylab=ylab,main=mytit,lty=lty[i], lwd=lwd[i],col=col[i],...) } }ica/R/icasamp.R0000644000176200001440000003144513301346040012750 0ustar liggesusersicasamp <- function(dname, query = c("rnd","pdf","kur"), nsamp = NULL, data = NULL){ # initial checks dname <- dname[1] didx <- match(dname,letters[1:18]) if(is.na(didx)){stop("Input 'dname' must be letter between 'a' and 'r'.")} query <- query[1] qidx <- match(query,c("rnd","pdf","kur")) if(is.na(qidx)){stop("Input 'query' must be 'rnd', 'pdf', or 'kur'.")} if(qidx==1L){ if(is.null(nsamp[1])){stop("Input 'nsamp' must be provided.")} nsamp <- as.integer(nsamp[1]) if(nsamp<=0){stop("Input 'nsamp' must be positive integer.")} } else if(qidx==2L){ if(is.null(data[1])){stop("Input 'data' must be provided.")} data <- as.numeric(data) } # sample data if(dname=="a"){ # Student t with df=3 if(query=="rnd"){ return(rt(nsamp,3)) } else if(query=="pdf"){ return(dt(data,3)) } else if(query=="kur"){ return(Inf) } } else if(dname=="b"){ # double exponential if(query=="rnd"){ return(sign(runif(nsamp)-0.5)*rexp(nsamp,rate=sqrt(2))) } else if(query=="pdf"){ return(exp(-sqrt(2)*abs(data))/sqrt(2)) } else if(query=="kur"){ return(3) } } else if(dname=="c"){ # uniform if(query=="rnd"){ return(runif(nsamp)*2*sqrt(3)-sqrt(3)) } else if(query=="pdf"){ return(1/2/sqrt(3)*(data-sqrt(3))) } else if(query=="kur"){ return(-1.2) } } else if(dname=="d"){ # Student t with df=5 if(query=="rnd"){ return(rt(nsamp,5)) } else if(query=="pdf"){ return(dt(data,5)) } else if(query=="kur"){ return(6) } } else if(dname=="e"){ # Exponential if(query=="rnd"){ return(-1+rexp(nsamp)) } else if(query=="pdf"){ return(dexp(data+1)) } else if(query=="kur"){ return(6) } } else if(dname=="f"){ # Mixture 2 Double Exponential prop <- rep(0.5,2) mus <- c(-1,1) covs <- rep(0.5,2) if(query=="rnd"){ idx <- sample(1:2,nsamp,replace=TRUE) return(sign(runif(nsamp)-0.5)*rexp(nsamp,sqrt(2))*covs[idx]+mus[idx]) } else if(query=="pdf"){ myden <- 0 for(i in 1:2){ myden <- myden + prop[i]/covs[i]*exp(-sqrt(2)*abs(data-mus[i])/covs[i])/sqrt(2) } return(myden) } else if(query=="kur"){ mus <- mus*covs mu <- x2 <- x4 <- x3 <- 0 for(i in 1:length(prop)){ mu <- mu + prop[i]*mus[i] x2 <- x2 + prop[i]*(mus[i]^2+covs[i]) x3 <- x3 + prop[i]*(3*mus[i]*covs[i]+mus[i]^3) x4 <- x4 + prop[i]*(6*covs[i]^2+6*covs[i]*mus[i]^2+mus[i]^4) } return((x4-4*mu*x3+6*mu^2*x2-3*mu^4)/(x2-mu^2)^2-3) } } else if(dname=="g"){ # Mixture 2 Gaussian (symmetric & multimodal) prop <- rep(0.5,2) mus <- c(-0.5,0.5) covs <- rep(.15,2) if(query=="rnd"){ idx <- sample(1:2,nsamp,replace=TRUE) return(rnorm(nsamp,mus[idx],covs[idx])) } else if(query=="pdf"){ myden <- 0 for(i in 1:2){ myden <- myden + prop[i]*dnorm(data,mus[i],covs[i]) } return(myden) } else if(query=="kur"){ mu <- x2 <- x4 <- x3 <- 0 for(i in 1:length(prop)){ mu <- mu + prop[i]*mus[i] x2 <- x2 + prop[i]*(mus[i]^2+covs[i]^2) x3 <- x3 + prop[i]*(3*mus[i]*covs[i]^2+mus[i]^3) x4 <- x4 + prop[i]*(3*covs[i]^4+6*covs[i]^2*mus[i]^2+mus[i]^4) } return((x4-4*mu*x3+6*mu^2*x2-3*mu^4)/(x2-mu^2)^2-3) } } else if(dname=="h"){ # Mixture 2 Gaussian (symmetric & transitional) prop <- rep(0.5,2) mus <- c(-0.5,0.5) covs <- rep(0.4,2) if(query=="rnd"){ idx <- sample(1:2,nsamp,replace=TRUE) return(rnorm(nsamp,mus[idx],covs[idx])) } else if(query=="pdf"){ myden <- 0 for(i in 1:2){ myden <- myden + prop[i]*dnorm(data,mus[i],covs[i]) } return(myden) } else if(query=="kur"){ mu <- x2 <- x4 <- x3 <- 0 for(i in 1:length(prop)){ mu <- mu + prop[i]*mus[i] x2 <- x2 + prop[i]*(mus[i]^2+covs[i]^2) x3 <- x3 + prop[i]*(3*mus[i]*covs[i]^2+mus[i]^3) x4 <- x4 + prop[i]*(3*covs[i]^4+6*covs[i]^2*mus[i]^2+mus[i]^4) } return((x4-4*mu*x3+6*mu^2*x2-3*mu^4)/(x2-mu^2)^2-3) } } else if(dname=="i"){ # Mixture 2 Gaussian (symmetric & unimodal) prop <- rep(0.5,2) mus <- c(-0.5,0.5) covs <- rep(0.5,2) if(query=="rnd"){ idx <- sample(1:2,nsamp,replace=TRUE) return(rnorm(nsamp,mus[idx],covs[idx])) } else if(query=="pdf"){ myden <- 0 for(i in 1:2){ myden <- myden + prop[i]*dnorm(data,mus[i],covs[i]) } return(myden) } else if(query=="kur"){ mu <- x2 <- x4 <- x3 <- 0 for(i in 1:length(prop)){ mu <- mu + prop[i]*mus[i] x2 <- x2 + prop[i]*(mus[i]^2+covs[i]^2) x3 <- x3 + prop[i]*(3*mus[i]*covs[i]^2+mus[i]^3) x4 <- x4 + prop[i]*(3*covs[i]^4+6*covs[i]^2*mus[i]^2+mus[i]^4) } return((x4-4*mu*x3+6*mu^2*x2-3*mu^4)/(x2-mu^2)^2-3) } } else if(dname=="j"){ # Mixture 2 Gaussian (nonsymmetric & multimodal) prop <- c(1,3) prop <- prop/sum(prop) mus <- c(-0.5,0.5) covs <- rep(0.15,2) if(query=="rnd"){ idx <- sample(1:2,nsamp,replace=TRUE,prob=prop) return(rnorm(nsamp,mus[idx],covs[idx])) } else if(query=="pdf"){ myden <- 0 for(i in 1:2){ myden <- myden + prop[i]*dnorm(data,mus[i],covs[i]) } return(myden) } else if(query=="kur"){ mu <- x2 <- x4 <- x3 <- 0 for(i in 1:length(prop)){ mu <- mu + prop[i]*mus[i] x2 <- x2 + prop[i]*(mus[i]^2+covs[i]^2) x3 <- x3 + prop[i]*(3*mus[i]*covs[i]^2+mus[i]^3) x4 <- x4 + prop[i]*(3*covs[i]^4+6*covs[i]^2*mus[i]^2+mus[i]^4) } return((x4-4*mu*x3+6*mu^2*x2-3*mu^4)/(x2-mu^2)^2-3) } } else if(dname=="k"){ # Mixture 2 Gaussian (nonsymmetric & transitional) prop <- c(1,2) prop <- prop/sum(prop) mus <- c(-0.7,0.5) covs <- rep(0.4,2) if(query=="rnd"){ idx <- sample(1:2,nsamp,replace=TRUE,prob=prop) return(rnorm(nsamp,mus[idx],covs[idx])) } else if(query=="pdf"){ myden <- 0 for(i in 1:2){ myden <- myden + prop[i]*dnorm(data,mus[i],covs[i]) } return(myden) } else if(query=="kur"){ mu <- x2 <- x4 <- x3 <- 0 for(i in 1:length(prop)){ mu <- mu + prop[i]*mus[i] x2 <- x2 + prop[i]*(mus[i]^2+covs[i]^2) x3 <- x3 + prop[i]*(3*mus[i]*covs[i]^2+mus[i]^3) x4 <- x4 + prop[i]*(3*covs[i]^4+6*covs[i]^2*mus[i]^2+mus[i]^4) } return((x4-4*mu*x3+6*mu^2*x2-3*mu^4)/(x2-mu^2)^2-3) } } else if(dname=="l"){ # Mixture 2 Gaussian (nonsymmetric & unimodal) prop <- c(1,2) prop <- prop/sum(prop) mus <- c(-0.7,0.5) covs <- rep(0.5,2) if(query=="rnd"){ idx <- sample(1:2,nsamp,replace=TRUE,prob=prop) return(rnorm(nsamp,mus[idx],covs[idx])) } else if(query=="pdf"){ myden <- 0 for(i in 1:2){ myden <- myden + prop[i]*dnorm(data,mus[i],covs[i]) } return(myden) } else if(query=="kur"){ mu <- x2 <- x4 <- x3 <- 0 for(i in 1:length(prop)){ mu <- mu + prop[i]*mus[i] x2 <- x2 + prop[i]*(mus[i]^2+covs[i]^2) x3 <- x3 + prop[i]*(3*mus[i]*covs[i]^2+mus[i]^3) x4 <- x4 + prop[i]*(3*covs[i]^4+6*covs[i]^2*mus[i]^2+mus[i]^4) } return((x4-4*mu*x3+6*mu^2*x2-3*mu^4)/(x2-mu^2)^2-3) } } else if(dname=="m"){ # Mixture 4 Gaussian (symmetric & multimodal) prop <- c(1,2,2,1) prop <- prop/sum(prop) mus <- c(-1,-.33,.33,1) covs <- rep(0.16,4) if(query=="rnd"){ idx <- sample(1:4,nsamp,replace=TRUE,prob=prop) return(rnorm(nsamp,mus[idx],covs[idx])) } else if(query=="pdf"){ myden <- 0 for(i in 1:4){ myden <- myden + prop[i]*dnorm(data,mus[i],covs[i]) } return(myden) } else if(query=="kur"){ mu <- x2 <- x4 <- x3 <- 0 for(i in 1:length(prop)){ mu <- mu + prop[i]*mus[i] x2 <- x2 + prop[i]*(mus[i]^2+covs[i]^2) x3 <- x3 + prop[i]*(3*mus[i]*covs[i]^2+mus[i]^3) x4 <- x4 + prop[i]*(3*covs[i]^4+6*covs[i]^2*mus[i]^2+mus[i]^4) } return((x4-4*mu*x3+6*mu^2*x2-3*mu^4)/(x2-mu^2)^2-3) } } else if(dname=="n"){ # Mixture 4 Gaussian (symmetric & transitional) prop <- c(1,2,2,1) prop <- prop/sum(prop) mus <- c(-1,-.2,.2,1) covs <- c(.2,.3,.3,.2) if(query=="rnd"){ idx <- sample(1:4,nsamp,replace=TRUE,prob=prop) return(rnorm(nsamp,mus[idx],covs[idx])) } else if(query=="pdf"){ myden <- 0 for(i in 1:4){ myden <- myden + prop[i]*dnorm(data,mus[i],covs[i]) } return(myden) } else if(query=="kur"){ mu <- x2 <- x4 <- x3 <- 0 for(i in 1:length(prop)){ mu <- mu + prop[i]*mus[i] x2 <- x2 + prop[i]*(mus[i]^2+covs[i]^2) x3 <- x3 + prop[i]*(3*mus[i]*covs[i]^2+mus[i]^3) x4 <- x4 + prop[i]*(3*covs[i]^4+6*covs[i]^2*mus[i]^2+mus[i]^4) } return((x4-4*mu*x3+6*mu^2*x2-3*mu^4)/(x2-mu^2)^2-3) } } else if(dname=="o"){ # Mixture 4 Gaussian (symmetric & unimodal) prop <- c(1,2,2,1) prop <- prop/sum(prop) mus <- c(-.7,-.2,.2,.7) covs <- c(.2,.3,.3,.2) if(query=="rnd"){ idx <- sample(1:4,nsamp,replace=TRUE,prob=prop) return(rnorm(nsamp,mus[idx],covs[idx])) } else if(query=="pdf"){ myden <- 0 for(i in 1:4){ myden <- myden + prop[i]*dnorm(data,mus[i],covs[i]) } return(myden) } else if(query=="kur"){ mu <- x2 <- x4 <- x3 <- 0 for(i in 1:length(prop)){ mu <- mu + prop[i]*mus[i] x2 <- x2 + prop[i]*(mus[i]^2+covs[i]^2) x3 <- x3 + prop[i]*(3*mus[i]*covs[i]^2+mus[i]^3) x4 <- x4 + prop[i]*(3*covs[i]^4+6*covs[i]^2*mus[i]^2+mus[i]^4) } return((x4-4*mu*x3+6*mu^2*x2-3*mu^4)/(x2-mu^2)^2-3) } } else if(dname=="p"){ # Mixture 4 Gaussian (nonsymmetric & multimodal) prop <- c(1,1,2,1) prop <- prop/sum(prop) mus <- c(-1,.3,-.3,1.1) covs <- c(.2,.2,.2,.2) if(query=="rnd"){ idx <- sample(1:4,nsamp,replace=TRUE,prob=prop) return(rnorm(nsamp,mus[idx],covs[idx])) } else if(query=="pdf"){ myden <- 0 for(i in 1:4){ myden <- myden + prop[i]*dnorm(data,mus[i],covs[i]) } return(myden) } else if(query=="kur"){ mu <- x2 <- x4 <- x3 <- 0 for(i in 1:length(prop)){ mu <- mu + prop[i]*mus[i] x2 <- x2 + prop[i]*(mus[i]^2+covs[i]^2) x3 <- x3 + prop[i]*(3*mus[i]*covs[i]^2+mus[i]^3) x4 <- x4 + prop[i]*(3*covs[i]^4+6*covs[i]^2*mus[i]^2+mus[i]^4) } return((x4-4*mu*x3+6*mu^2*x2-3*mu^4)/(x2-mu^2)^2-3) } } else if(dname=="q"){ # Mixture 4 Gaussian (nonsymmetric & transitional) prop <- c(1,3,2,.5) prop <- prop/sum(prop) mus <- c(-1,-.2,.3,1) covs <- c(.2,.3,.2,.2) if(query=="rnd"){ idx <- sample(1:4,nsamp,replace=TRUE,prob=prop) return(rnorm(nsamp,mus[idx],covs[idx])) } else if(query=="pdf"){ myden <- 0 for(i in 1:4){ myden <- myden + prop[i]*dnorm(data,mus[i],covs[i]) } return(myden) } else if(query=="kur"){ mu <- x2 <- x4 <- x3 <- 0 for(i in 1:length(prop)){ mu <- mu + prop[i]*mus[i] x2 <- x2 + prop[i]*(mus[i]^2+covs[i]^2) x3 <- x3 + prop[i]*(3*mus[i]*covs[i]^2+mus[i]^3) x4 <- x4 + prop[i]*(3*covs[i]^4+6*covs[i]^2*mus[i]^2+mus[i]^4) } return((x4-4*mu*x3+6*mu^2*x2-3*mu^4)/(x2-mu^2)^2-3) } } else if(dname=="r"){ # Mixture 4 Gaussian (nonsymmetric & unimodal) prop <- c(1,2,2,1) prop <- prop/sum(prop) mus <- c(-.8,-.2,.2,.5) covs <- c(.22,.3,.3,.2) if(query=="rnd"){ idx <- sample(1:4,nsamp,replace=TRUE,prob=prop) return(rnorm(nsamp,mus[idx],covs[idx])) } else if(query=="pdf"){ myden <- 0 for(i in 1:4){ myden <- myden + prop[i]*dnorm(data,mus[i],covs[i]) } return(myden) } else if(query=="kur"){ mu <- x2 <- x4 <- x3 <- 0 for(i in 1:length(prop)){ mu <- mu + prop[i]*mus[i] x2 <- x2 + prop[i]*(mus[i]^2+covs[i]^2) x3 <- x3 + prop[i]*(3*mus[i]*covs[i]^2+mus[i]^3) x4 <- x4 + prop[i]*(3*covs[i]^4+6*covs[i]^2*mus[i]^2+mus[i]^4) } return((x4-4*mu*x3+6*mu^2*x2-3*mu^4)/(x2-mu^2)^2-3) } } # end if(dname=="a") }ica/R/icaimax.R0000644000176200001440000001347214210226475012757 0ustar liggesusersicaimax <- function(X, nc, center = TRUE, maxit = 100, tol = 1e-6, Rmat = diag(nc), alg = "newton", fun = "tanh", signs = rep(1, nc), signswitch = TRUE, rate = 1, rateanneal = NULL){ ###### ICA via (Fast and Robust) Information-Maximization ###### Nathaniel E. Helwig (helwig@umn.edu) ###### Last modified: March 3, 2022 ### initial checks X <- as.matrix(X) nobs <- nrow(X) nvar <- ncol(X) nc <- as.integer(nc[1]) if(nc < 1) stop("Must set nc >= 1 component") maxit <- as.integer(maxit[1]) if(maxit < 1) stop("Must set maxit >= 1 iteration") tol <- tol[1] if(tol <= 0) stop("Must set tol > 0") if(nc > min(nobs, nvar)) stop("Too many components. Set nc <= min(dim(X))") if(nrow(Rmat) != nc | ncol(Rmat) != nc) stop("Input 'Rmat' must be nc-by-nc rotation matrix.") fun <- fun[1] if(fun == "ext"){ signs <- sign(signs) if(length(signs) != nc){ stop("Input 'signs' must be have length equal to 'nc' input.") } } else { signs <- NA signswitch <- FALSE } alg <- alg[1] if(alg == "gradient"){ rate <- rate[1] if(rate <= 0) stop("Must set 'rate' greater than 0") if(!is.null(rateanneal[1])){ if(length(rateanneal) != 2L) stop("Input 'rateanneal' should be two-element vector") if(rateanneal[1] <= 0 || rateanneal[1] >= 90) stop("Input 'rateanneal[1]' should be in range (0, 90)") if(rateanneal[2] <= 0 || rateanneal[2] > 1){ stop("Input 'rateanneal[2]' should be in range (0, 1]") } ralog <- TRUE } else { ralog <- FALSE } } ### center and whiten if(center) X <- scale(X, scale = FALSE) if(nobs >= nvar){ xeig <- eigen(crossprod(X) / nobs, symmetric = TRUE) } else { xeig <- eigen(tcrossprod(X) / nobs, symmetric = TRUE) } # end if(nobs >= nvar) nze <- sum(xeig$values > xeig$values[1] * .Machine$double.eps) if(nze < nc){ warning("Numerical rank of X is less than requested number of components (nc).\nNumber of components has been redefined as rank(X) = ",nc) nc <- nze Rmat <- diag(nc) } Dmat <- sdiag(sqrt(xeig$values[1:nc])) if(nobs >= nvar){ Mprt <- tcrossprod(Dmat, xeig$vectors[, 1:nc, drop = FALSE]) diag(Dmat) <- 1 / diag(Dmat) Pmat <- xeig$vectors[, 1:nc, drop = FALSE] %*% Dmat Xw <- X %*% Pmat # whitened data } else { Mprt <- crossprod(xeig$vectors[, 1:nc, drop = FALSE], X) / sqrt(nobs) diag(Dmat) <- 1 / diag(Dmat)^2 Pmat <- crossprod(Mprt, Dmat) Xw <- xeig$vectors[, 1:nc, drop = FALSE] * sqrt(nobs) # whitened data } # end if(nobs >= nvar) ### check if nc=1 if(nc == 1L){ res <- list(S = Xw, M = Mprt, W = t(Pmat), Y = Xw, Q = t(Pmat), R = matrix(1), vafs = nobs * sum(Mprt^2) / sum(X^2), iter = NA, alg = alg[1], fun = fun[1], signs = signs, rate = rate, converged = TRUE) class(res) <- "icaimax" return(res) } ### which nonlinearity if(fun == "log"){ fun1d <- function(x, sgn = 1){ 2 / (1 + exp(-x)) - 1 } fun2d <- function(x, sgn = 1){ 1 / (cosh(x) + 1) } } else if(fun == "ext"){ fun1d <- function(x, sgn = 1){ x + tanh(x) %*% sdiag(sgn) } fun2d <- function(x, sgn = 1){ 1 + (1 - tanh(x)^2) %*% sdiag(sgn) } } else { fun1d <- function(x, sgn = 1){ tanh(x) } fun2d <- function(x, sgn = 1){ 1 - tanh(x)^2 } } ### which algorithm if(alg[1] == "gradient"){ # gradient descent iter <- 0 vtol <- 1 while(vtol > tol && iter < maxit){ # update all components smat <- Xw %*% Rmat if(signswitch) signs <- sign(colMeans((cosh(smat)^-2) - tanh(smat) * smat)) rnew <- Rmat - rate * crossprod(Xw / nobs, fun1d(smat, signs)) # orthgonalize rsvd <- svd(rnew) rnew <- tcrossprod(rsvd$u, rsvd$v) # check for convergence vtol <- 1 - min(abs(colSums(Rmat * rnew))) iter <- iter + 1 Rmat <- rnew if(ralog && ((acos(1 - vtol) * 180 / pi) < rateanneal[1])) rate <- rate * rateanneal[2] } # end while(vtol>tol && iter tol && iter < maxit){ # update all components smat <- Xw %*% Rmat if(signswitch) signs <- sign(colMeans((cosh(smat)^-2) - tanh(smat) * smat)) Hmat <- matrix(colMeans(fun2d(smat, signs)), nrow = nc, ncol = nc, byrow = TRUE) rnew <- Rmat - crossprod(Xw / nobs, fun1d(smat, signs)) / Hmat # orthgonalize rsvd <- svd(rnew) rnew <- tcrossprod(rsvd$u, rsvd$v) # check for convergence vtol <- 1 - min(abs(colSums(Rmat * rnew))) iter <- iter + 1 Rmat <- rnew } # end while(vtol>tol && iter= 1 component") maxit <- as.integer(maxit[1]) if(maxit < 1) stop("Must set maxit >= 1 iteration") tol <- tol[1] if(tol <= 0) stop("Must set tol > 0") if(nc > min(nobs, nvar)) stop("Too many components. Set nc <= min(dim(X))") alpha <- alpha[1] if(alpha < 1 | alpha > 2) stop("Must set 'alpha' between 1 and 2") if(nrow(Rmat) != nc | ncol(Rmat) != nc) stop("Input 'Rmat' must be nc-by-nc rotation matrix.") ### center and whiten if(center) X <- scale(X, scale = FALSE) if(nobs >= nvar){ xeig <- eigen(crossprod(X) / nobs, symmetric = TRUE) } else { xeig <- eigen(tcrossprod(X) / nobs, symmetric = TRUE) } # end if(nobs >= nvar) nze <- sum(xeig$values > xeig$values[1] * .Machine$double.eps) if(nze < nc){ warning("Numerical rank of X is less than requested number of components (nc).\nNumber of components has been redefined as rank(X) = ",nc) nc <- nze Rmat <- diag(nc) } Dmat <- sdiag(sqrt(xeig$values[1:nc])) if(nobs >= nvar){ Mprt <- tcrossprod(Dmat, xeig$vectors[, 1:nc, drop = FALSE]) diag(Dmat) <- 1 / diag(Dmat) Pmat <- xeig$vectors[, 1:nc, drop = FALSE] %*% Dmat Xw <- X %*% Pmat # whitened data } else { Mprt <- crossprod(xeig$vectors[, 1:nc, drop = FALSE], X) / sqrt(nobs) diag(Dmat) <- 1 / diag(Dmat)^2 Pmat <- crossprod(Mprt, Dmat) Xw <- xeig$vectors[, 1:nc, drop = FALSE] * sqrt(nobs) # whitened data } # end if(nobs >= nvar) ### check if nc=1 if(nc == 1L){ res <- list(S = Xw, M = Mprt, W = t(Pmat), Y = Xw, Q = t(Pmat), R = matrix(1), vafs = nobs * sum(Mprt^2) / sum(X^2), iter = NA, alg = alg[1], fun = fun[1], alpha = alpha, converged = TRUE) class(res) <- "icafast" return(res) } ### define contrast function derivatives if(fun[1] == "kur"){ fun1d <- function(x){ x^3 } fun2d <- function(x){ 3*(x^2) } } else if(fun[1] == "exp"){ fun1d <- function(x){ x*exp(-(x^2)/2) } fun2d <- function(x){ exp(-(x^2)/2)*(1-x^2) } } else { fun1d <- function(x){ tanh(alpha*x) } fun2d <- function(x){ alpha*(1-tanh(alpha*x)^2) } } ### determine method if(alg[1] == "def"){ myiters <- rep(NA, nc) for(j in 1:nc){ if (j < 2){ # first component Rmat[,j] <- Rmat[,j] / sqrt(sum(Rmat[,j]^2)) iter <- 0 vtol <- 1 while(vtol > tol && iter < maxit){ # update first component svec <- Xw %*% Rmat[,j] rnew <- colMeans(Xw * matrix(fun1d(svec), nrow = nobs, ncol = nc)) rnew <- rnew - mean(fun2d(svec)) * Rmat[,j] rnew <- rnew / sqrt(sum(rnew^2)) # check for convergence vtol <- 1 - abs(sum(Rmat[,j] * rnew)) iter <- iter + 1 Rmat[,j] <- rnew } myiters[j] <- iter } else { # decorrelate with previous components Rmat[,j] <- Rmat[,j] / sqrt(sum(Rmat[,j]^2)) svec <- matrix(0, nrow = nc, ncol = 1) for(k in 1:(j-1)){ svec <- svec + sum(Rmat[,k] * Rmat[,j]) * Rmat[,k] } Rmat[,j] <- Rmat[,j] - svec Rmat[,j] <- Rmat[,j] / sqrt(sum(Rmat[,j]^2)) # get j-th component iter <- 0 vtol <- 1 while(vtol>tol && iter tol && iter < maxit){ # update all components smat <- Xw %*% Rmat rnew <- crossprod(Xw, fun1d(smat)) / nobs rnew <- rnew - Rmat %*% sdiag(colMeans(fun2d(smat))) rsvd <- svd(rnew) rnew <- tcrossprod(rsvd$u, rsvd$v) # check for convergence vtol <- 1 - min(abs(colSums(Rmat * rnew))) iter <- iter + 1 Rmat <- rnew } myiters <- iter } # end if(alg[1]=="def") ### sort according to vafs M <- crossprod(Rmat, Mprt) vafs <- rowSums(M^2) ix <- sort(vafs, decreasing = TRUE, index.return = TRUE)$ix M <- M[ix,] Rmat <- Rmat[,ix] vafs <- nobs * vafs[ix] / sum(X^2) ### return results res <- list(S = Xw %*% Rmat, M = t(M), W = t(Pmat %*% Rmat), Y = Xw, Q = t(Pmat), R = Rmat, vafs = vafs, iter = myiters, alg = alg[1], fun = fun[1], alpha = alpha, converged = ifelse(vtol <= tol, TRUE, FALSE)) class(res) <- "icafast" return(res) } print.icafast <- function(x, ...){ nc <- length(x$vafs) cat("\nFastICA with", nc, ifelse(nc == 1L, "component", "components"), "\n\n") cat(" converged: ", x$converged," (", x$iter, " iterations) \n", sep = "") cat(" r-squared:", sum(x$vafs), "\n") cat(" algorithm:", ifelse(x$alg == "par", "parallel", "deflation"), "\n") cat(" function:", x$fun, "\n\n") } ica/R/icajade.R0000644000176200001440000001147414210226503012714 0ustar liggesusersicajade <- function(X, nc, center = TRUE, maxit = 100, tol = 1e-6, Rmat = diag(nc)){ ###### Joint Approximate Diagonalization of Eigenmatrices (JADE) ###### Nathaniel E. Helwig (helwig@umn.edu) ###### Last modified: March 3, 2022 ### initial checks X <- as.matrix(X) nobs <- nrow(X) nvar <- ncol(X) nc <- as.integer(nc[1]) if(nc < 1) stop("Must set nc >= 1 component") maxit <- as.integer(maxit[1]) if(maxit < 1) stop("Must set maxit >= 1 iteration") tol <- tol[1] if(tol <= 0) stop("Must set tol > 0") if(nc > min(nobs, nvar)) stop("Too many components. Set nc <= min(dim(X))") if(nrow(Rmat) != nc | ncol(Rmat) != nc) stop("Input 'Rmat' must be nc-by-nc rotation matrix.") ### center and whiten if(center) X <- scale(X, scale = FALSE) if(nobs >= nvar){ xeig <- eigen(crossprod(X) / nobs, symmetric = TRUE) } else { xeig <- eigen(tcrossprod(X) / nobs, symmetric = TRUE) } # end if(nobs >= nvar) nze <- sum(xeig$values > xeig$values[1] * .Machine$double.eps) if(nze < nc){ warning("Numerical rank of X is less than requested number of components (nc).\nNumber of components has been redefined as rank(X) = ",nc) nc <- nze Rmat <- diag(nc) } Dmat <- sdiag(sqrt(xeig$values[1:nc])) if(nobs >= nvar){ Mprt <- tcrossprod(Dmat, xeig$vectors[, 1:nc, drop = FALSE]) diag(Dmat) <- 1 / diag(Dmat) Pmat <- xeig$vectors[, 1:nc, drop = FALSE] %*% Dmat Xw <- X %*% Pmat # whitened data } else { Mprt <- crossprod(xeig$vectors[, 1:nc, drop = FALSE], X) / sqrt(nobs) diag(Dmat) <- 1 / diag(Dmat)^2 Pmat <- crossprod(Mprt, Dmat) Xw <- xeig$vectors[, 1:nc, drop = FALSE] * sqrt(nobs) # whitened data } # end if(nobs >= nvar) ### check if nc=1 if(nc == 1L){ res <- list(S = Xw, M = Mprt, W = t(Pmat), Y = Xw, Q = t(Pmat), R = matrix(1), vafs = nobs * sum(Mprt^2) / sum(X^2), iter = NA, converged = TRUE) class(res) <- "icajade" return(res) } ### basis eigenmatrices (using Jean-Francois Cardoso's symmetry trick) ncstar <- nc * (nc + 1) / 2 idmat <- diag(nc) emats <- matrix(0, nrow = nc, ncol = nc * ncstar) crng <- 1:nc for(i in 1:nc){ Xi <- Xw[,i] Qij <- crossprod(matrix(Xi^2 / nobs, nrow = nobs, ncol = nc) * Xw, Xw) - idmat - 2 * tcrossprod(idmat[,i], idmat[,i]) emats[,crng] <- Qij crng <- crng + nc if(i > 1){ for(j in 1:(i-1)){ Xj <- Xw[,j] Qij <- crossprod(matrix(Xi * Xj / nobs, nrow = nobs, ncol = nc) * Xw, Xw) - tcrossprod(idmat[,i], idmat[,j]) - tcrossprod(idmat[,j], idmat[,i]) emats[,crng] <- sqrt(2) * Qij crng <- crng + nc } # end if(i>1) } # end for(j in 1:(i-1)) } # end for(i in 1:nc) ### iterative rotation npairs <- nc * (nc - 1) / 2 thetas <- rep(1, npairs) iter <- 0 vtol <- 1 while(vtol > tol && iter < maxit){ # sweep through angle pairs for(p in 1:(nc-1)){ for(q in (p+1):nc){ # Givens angle ip <- seq(p, nc * ncstar, by = nc) iq <- seq(q, nc * ncstar, by = nc) gp <- rbind(emats[p,ip] - emats[q,iq], emats[p,iq] + emats[q,ip]) gg <- tcrossprod(gp) ton <- gg[1,1] - gg[2,2] toff <- gg[1,2] + gg[2,1] theta <- 0.5 * atan2(toff, ton + sqrt(ton^2 + toff^2)) thetas[nc * (p - 1) - p * (p - 1) / 2 + q - p] <- theta # Givens rotation cc <- cos(theta) ss <- sin(theta) gmat <- rbind(c(cc, -ss), c(ss, cc)) pair <- c(p, q) Rmat[,pair] <- Rmat[,pair] %*% gmat emats[pair,] <- crossprod(gmat, emats[pair,]) emats[,c(ip,iq)] <- cbind(cc * emats[,ip] + ss * emats[,iq], -ss * emats[,ip] + cc * emats[,iq]) } } # check for convergence vtol <- max(abs(thetas)) iter <- iter + 1 } # end while(vtol>tol && iter