pcaPP/0000755000176200001440000000000014040447642011262 5ustar liggesuserspcaPP/NAMESPACE0000644000176200001440000000134213124435137012477 0ustar liggesusersuseDynLib(pcaPP, .registration = TRUE) importFrom(mvtnorm, rmvnorm) importFrom("grDevices", "gray", "rainbow") importFrom("graphics", "abline", "lines", "mtext", "par", "plot", "plot.new", "plot.window", "rect", "text", "title") importFrom("stats", "cov", "cov2cor", "mad", "median", "qchisq", "qnorm", "rnorm", "runif", "sd") importFrom("utils", "flush.console", "installed.packages") export(PCAgrid, PCAproj, PCdiagplot, ScaleAdv, cor.fk, covPC, covPCAgrid, covPCAproj, data.Zou, l1median, l1median_BFGS, l1median_CG, l1median_HoCr, l1median_NLM, l1median_NM, l1median_VaZh, objplot, opt.BIC, opt.TPO, plotcov, qn, sPCAgrid) S3method (plot, opt.TPO) S3method (plot, opt.BIC) pcaPP/ChangeLog0000644000176200001440000000327313223576553013047 0ustar liggesusers2017-01-04 Valentin Todorov * * DESCRIPTION (Version): 1.9-73 * * src/hess.cpp - fix warning of the type -Wmismatched-new-delete * (allocated array, deleted as single element). See mail of Prof. Ripley from 28.Nobember 2017 * 2017-06-27 Valentin Todorov * * DESCRIPTION (Version): 1.9-72 * DESCRIPTION (Version): 1.9-71 * DESCRIPTION (Version): 1.9-70 * * test/tpcapp.R - added * src/smat.base.h - fix to compile on gcc-7: lines 737-741 * C functions registered (warning "Found no calls to: R_registerRoutines, * R_useDynamicSymbols" fixed) * 2016-10-10 Valentin Todorov * * DESCRIPTION (Version): 1.9-61 * * R/PCdiagplot.R - remove a require(graphics) * * src/pcaPP.cpp - fix warning - uninitialized variable * * NAMESPASE - add importFrom() for functions in "grDevices", "graphics", "stats" and "utils". * * src/R_meal.h: fix a problem on Solaris by adding ** using namespace std; * - however, I cannot test if this is sufficient * 2014-10-20 Valentin Todorov * * DESCRIPTION (Version): 1.9-60 * 2014-10-20 Valentin Todorov * * DESCRIPTION (Version): 1.2-3 * DESCRIPTION (Depends): removed, no more dependances replaced by Imports * * NAMESPACE: added 'importFrom(mvtnorm, rmvnorm)' * * * The package was ORPHANED. The CRAN team fixed the * location of the vignette according to R 3.1 * Version 1.9-50, 19.9.2014 * pcaPP/man/0000755000176200001440000000000014040371703012027 5ustar liggesuserspcaPP/man/data.Zou.Rd0000644000176200001440000000517612777012547014031 0ustar liggesusers\name{data.Zou} \alias{data.Zou} \title{ Test Data Generation for Sparse PCA examples } \description{ Draws a sample data set, as introduced by Zou et al. (2006). } \usage{ data.Zou (n = 250, p = c(4, 4, 2), ...) } \arguments{ \item{n}{ The required number of observations. } \item{p}{ A vector of length 3, specifying how many variables shall be constructed using the three factors V1, V2 and V3. } \item{...}{ Further arguments passed to or from other functions. } } \details{ This data set has been introduced by Zou et al. (2006), and then been referred to several times, e.g. by Farcomeni (2009), Guo et al. (2010) and Croux et al. (2011). The data set contains two latent factors V1 ~ N(0, 290) and V2 ~ N(0, 300) and a third mixed component V3 = -0.3 V1 + 0.925V2 + e; e ~ N(0, 1).\cr The ten variables Xi of the original data set are constructed the following way:\cr Xi = V1 + ei; i = 1, 2, 3, 4\cr Xi = V2 + ei; i = 5, 6, 7, 8\cr Xi = V3 + ei; i = 9, 10\cr whereas ei ~ N(0, 1) is indepependent for i = 1 , ..., 10 } \value{ A matrix of dimension \code{n x sum (p)} containing the generated sample data set. } \references{ C. Croux, P. Filzmoser, H. Fritz (2011). Robust Sparse Principal Component Analysis Based on Projection-Pursuit, \emph{??} To appear. A. Farcomeni (2009). An exact approach to sparse principal component analysis, \emph{Computational Statistics}, Vol. 24(4), pp. 583-604. J. Guo, G. James, E. Levina, F. Michailidis, and J. Zhu (2010). Principal component analysis with sparse fused loadings, \emph{Journal of Computational and Graphical Statistics.} To appear. H. Zou, T. Hastie, R. Tibshirani (2006). Sparse principal component analysis, \emph{Journal of Computational and Graphical Statistics}, Vol. 15(2), pp. 265-286. } \author{Heinrich Fritz, Peter Filzmoser <\email{P.Filzmoser@tuwien.ac.at}>} \seealso{ \code{\link{sPCAgrid}}, \code{\link{princomp}} } \examples{ ## data generation set.seed (0) x <- data.Zou () ## applying PCA pc <- princomp (x) ## the corresponding non-sparse loadings unclass (pc$load[,1:3]) pc$sdev[1:3] ## lambda as calculated in the opt.TPO - example lambda <- c (0.23, 0.34, 0.005) ## applying sparse PCA spc <- sPCAgrid (x, k = 3, lambda = lambda, method = "sd") unclass (spc$load) spc$sdev[1:3] ## comparing the non-sparse and sparse biplot par (mfrow = 1:2) biplot (pc, main = "non-sparse PCs") biplot (spc, main = "sparse PCs") } \keyword{multivariate} \keyword{robust} pcaPP/man/PCAgrid.Rd0000644000176200001440000002051712777012547013611 0ustar liggesusers\name{PCAgrid} \alias{PCAgrid} \alias{sPCAgrid} \title{ (Sparse) Robust Principal Components using the Grid search algorithm } \description{ Computes a desired number of (sparse) (robust) principal components using the grid search algorithm in the plane. The global optimum of the objective function is searched in planes, not in the p-dimensional space, using regular grids in these planes. } \usage{ PCAgrid (x, k = 2, method = c ("mad", "sd", "qn"), maxiter = 10, splitcircle = 25, scores = TRUE, zero.tol = 1e-16, center = l1median, scale, trace = 0, store.call = TRUE, control, ...) sPCAgrid (x, k = 2, method = c ("mad", "sd", "qn"), lambda = 1, maxiter = 10, splitcircle = 25, scores = TRUE, zero.tol = 1e-16, center = l1median, scale, trace = 0, store.call = TRUE, control, ...) } \arguments{ \item{x}{ a numerical matrix or data frame of dimension (\code{n x p})which provides the data for the principal components analysis. } \item{k}{ the desired number of components to compute } \item{method}{ the scale estimator used to detect the direction with the largest variance. Possible values are \code{"sd"}, \code{"mad"} and \code{"qn"}, the latter can be called \code{"Qn"} too. \code{"mad"} is the default value.} \item{lambda}{ the sparseness constraint's strength(\code{sPCAgrid} only). A single value for all components, or a vector of length \code{k} with different values for each component can be specified. See \code{\link{opt.TPO}} for the choice of this argument. } \item{maxiter}{ the maximum number of iterations. } \item{splitcircle}{ the number of directions in which the algorithm should search for the largest variance. The direction with the largest variance is searched for in the directions defined by a number of equally spaced points on the unit circle. This argument determines, how many such points are used to split the unit circle. } \item{scores}{ A logical value indicating whether the scores of the principal component should be calculated. } \item{zero.tol}{ the zero tolerance used internally for checking convergence, etc. } % \item{anglehalving}{ boolean stating whether angle halving is to be used or not. % Angle halving will usually improve the solution quite a lot.} % \item{fact2dim}{ an integer that is multiplied to splitcircle if x is only % two-dimensional. In higher dimensions, fewer search directions are needed to allow % for faster computation. In two dimensions, more search directions are required to % grant higher precision. \code{fact2dim} is used to take account of this.} \item{center}{ this argument indicates how the data is to be centered. It can be a function like \code{\link{mean}} or \code{\link{median}} or a vector of length \code{ncol(x)} containing the center value of each column. } \item{scale}{ this argument indicates how the data is to be rescaled. It can be a function like \code{\link{sd}} or \code{\link{mad}} or a vector of length \code{ncol(x)} containing the scale value of each column. } \item{trace}{ an integer value >= 0, specifying the tracing level. } % \item{cut.pc}{ a logical value, specifying whether only the first \code{k} % columns of the resulting loadings and scores matrix shall be returned % (\code{TRUE}). If this value is \cpode{FALSE}, the algorithm returns % an \code{p x p} loadings- and an \code{n x p} scores matrix, whereas the % last \code{p - k} components form an arbitrary basis of the complementary % space of the first \code{k} found components.} % \item{pc.ini}{ an optional pre calculated \code{princomp} (S3) object. If % provided, the algorithm searches for additional PCs in the orthogonal space % of the components provided by this object. } % \item{k.ini}{ an optional integer value, specifying how many components of % \code{pc.ini} shall be considered. } % \item{ord.all}{ a logical value, specifying wheter} % \item{HDred}{ } \item{store.call}{ a logical variable, specifying whether the function call shall be stored in the result structure. } \item{control}{ a list which elements must be the same as (or a subset of) the parameters above. If the control object is supplied, the parameters from it will be used and any other given parameters are overridden. } \item{...}{ further arguments passed to or from other functions. } } \details{ In contrast to \code{PCAgrid}, the function \code{sPCAgrid} computes sparse principal components. The strength of the applied sparseness constraint is specified by argument \code{lambda}. %Setting \code{lambda = 0} yields the same estimation for both functions %\code{PCAgrid} and\code{sPCAgrid}. Similar to the function \code{\link{princomp}}, there is a \code{print} method for the these objects that prints the results in a nice format and the \code{plot} method produces a scree plot (\code{\link{screeplot}}). There is also a \code{biplot} method. Angle halving is an extension of the original algorithm. In the original algorithm, the search directions are determined by a number of points on the unit circle in the interval [-pi/2 ; pi/2). Angle halving means this angle is halved in each iteration, eg. for the first approximation, the above mentioned angle is used, for the second approximation, the angle is halved to [-pi/4 ; pi/4) and so on. This usually gives better results with less iterations needed. \cr NOTE: in previous implementations angle halving could be suppressed by the former argument "\code{anglehalving}". This still can be done by setting argument \code{maxiter = 0}. } \value{ The function returns an object of class \code{"princomp"}, i.e. a list similar to the output of the function \code{\link{princomp}}. \item{sdev}{the (robust) standard deviations of the principal components.} \item{loadings}{the matrix of variable loadings (i.e., a matrix whose columns contain the eigenvectors). This is of class \code{"loadings"}: see \code{\link{loadings}} for its \code{\link{print}} method.} \item{center}{the means that were subtracted.} \item{scale}{the scalings applied to each variable.} \item{n.obs}{the number of observations.} \item{scores}{if \code{scores = TRUE}, the scores of the supplied data on the principal components.} \item{call}{the matched call.} \item{obj}{A vector containing the objective functions values. For function \code{PCAgrid} this is the same as \code{sdev}. } \item{lambda}{The lambda each component has been calculated with (\code{\link{sPCAgrid}} only).} } \references{ C. Croux, P. Filzmoser, M. Oliveira, (2007). Algorithms for Projection-Pursuit Robust Principal Component Analysis, \emph{Chemometrics and Intelligent Laboratory Systems}, Vol. 87, pp. 218-225. C. Croux, P. Filzmoser, H. Fritz (2011). Robust Sparse Principal Component Analysis Based on Projection-Pursuit, \emph{??} To appear. } \author{Heinrich Fritz, Peter Filzmoser <\email{P.Filzmoser@tuwien.ac.at}>} \seealso{ \code{\link{PCAproj}}, \code{\link{princomp}} } \note{See the vignette "Compiling pcaPP for Matlab" which comes with this package to compile and use these functions in Matlab.} \examples{ # multivariate data with outliers library(mvtnorm) x <- rbind(rmvnorm(200, rep(0, 6), diag(c(5, rep(1,5)))), rmvnorm( 15, c(0, rep(20, 5)), diag(rep(1, 6)))) # Here we calculate the principal components with PCAgrid pc <- PCAgrid(x) # we could draw a biplot too: biplot(pc) # now we want to compare the results with the non-robust principal components pc <- princomp(x) # again, a biplot for comparison: biplot(pc) ## Sparse loadings set.seed (0) x <- data.Zou () ## applying PCA pc <- princomp (x) ## the corresponding non-sparse loadings unclass (pc$load[,1:3]) pc$sdev[1:3] ## lambda as calculated in the opt.TPO - example lambda <- c (0.23, 0.34, 0.005) ## applying sparse PCA spc <- sPCAgrid (x, k = 3, lambda = lambda, method = "sd") unclass (spc$load) spc$sdev[1:3] ## comparing the non-sparse and sparse biplot par (mfrow = 1:2) biplot (pc, main = "non-sparse PCs") biplot (spc, main = "sparse PCs") } \keyword{multivariate} \keyword{robust} pcaPP/man/plotcov.Rd0000644000176200001440000000414712777012547014027 0ustar liggesusers\name{plotcov} \alias{plotcov} \title{ Compare two Covariance Matrices in Plots} \description{ allows a direct comparison of two estimations of the covariance matrix (e.g. resulting from covPC) in a plot. } \usage{ plotcov(cov1, cov2, method1, labels1, method2, labels2, ndigits, ...) } \arguments{ \item{cov1}{ a covariance matrix (from cov, covMcd, covPC, covPCAgrid, covPCAproj, etc. } \item{cov2}{ a covariance matrix (from cov, covMcd, covPC, covPCAgrid, covPCAproj, etc. } \item{method1}{ legend for ellipses of estimation method1} \item{method2}{ legend for ellipses of estimation method2} \item{labels1}{ legend for numbers of estimation method1} \item{labels2}{ legend for numbers of estimation method2} \item{ndigits}{ number of digits to use for printing covariances, by default ndigits=4} \item{...}{ additional arguments for text or plot} } \details{ Since (robust) PCA can be used to re-compute the (robust) covariance matrix, one might be interested to compare two different methods of covariance estimation visually. This routine takes as input objects for the covariances to compare the output of \code{\link{cov}}, but also the return objects from \code{\link{covPCAgrid}}, \code{\link{covPCAproj}}, \code{\link{covPC}}, and \code{\link[robustbase]{covMcd}}. The comparison of the two covariance matrices is done by numbers (the covariances) and by ellipses. } \value{ only the plot is generated } \references{ C. Croux, P. Filzmoser, M. Oliveira, (2007). Algorithms for Projection-Pursuit Robust Principal Component Analysis, \emph{Chemometrics and Intelligent Laboratory Systems}, Vol. 87, pp. 218-225. } \author{ Heinrich Fritz, Peter Filzmoser <\email{P.Filzmoser@tuwien.ac.at}> } \seealso{ \code{\link{PCAgrid}}, \code{\link{PCAproj}}, \code{\link{princomp}} } \examples{ # multivariate data with outliers library(mvtnorm) x <- rbind(rmvnorm(200, rep(0, 6), diag(c(5, rep(1,5)))), rmvnorm( 15, c(0, rep(20, 5)), diag(rep(1, 6)))) plotcov(covPCAproj(x),covPCAgrid(x)) } \keyword{ multivariate } pcaPP/man/ScaleAdv.Rd0000644000176200001440000000443712777012547014025 0ustar liggesusers\name{ScaleAdv} \alias{ScaleAdv} \title{ centers and rescales data } \description{ Data is centered and rescaled (to have mean 0 and a standard deviation of 1). } \usage{ ScaleAdv(x, center = mean, scale = sd) } \arguments{ \item{x}{ matrix containing the observations. If this is not a matrix, but a data frame, it is automatically converted into a matrix using the function \code{\link{as.matrix}}. In any other case, (eg. a vector) it is converted into a matrix with one single column. } \item{center}{ this argument indicates how the data is to be centered. It can be a function like \code{\link{mean}} or \code{\link{median}} or a vector of length \code{ncol(x)} containing the center value of each column. } \item{scale}{ this argument indicates how the data is to be rescaled. It can be a function like \code{\link{sd}} or \code{\link{mad}} or a vector of length \code{ncol(x)} containing the scale value of each column. } } \value{ The function returns a list containing \item{ x }{centered and rescaled data matrix.} \item{ center }{ a vector of the centers of each column x. If you add to each column of \code{x} the appropriate value from \code{center}, you will obtain the data with the original location of the observations. } \item{ scale }{ a vector of the scale factors of each column x. If you multiply each column of \code{x} by the appropriate value from \code{scale}, you will obtain the data with the original scales. } } \details{ The default \code{scale} being \code{NULL} means that no rescaling is done. } \references{ C. Croux, P. Filzmoser, M. Oliveira, (2007). Algorithms for Projection-Pursuit Robust Principal Component Analysis, \emph{Chemometrics and Intelligent Laboratory Systems}, Vol. 87, pp. 218-225. } \author{ Heinrich Fritz, Peter Filzmoser <\email{P.Filzmoser@tuwien.ac.at}>} \examples{ x <- rnorm(100, 10, 5) x <- ScaleAdv(x)$x # can be used with multivariate data too library(mvtnorm) x <- rmvnorm(100, 3:7, diag((7:3)^2)) res <- ScaleAdv(x, center = l1median, scale = mad) res # instead of using an estimator, you could specify the center and scale yourself too x <- rmvnorm(100, 3:7, diag((7:3)^2)) res <- ScaleAdv(x, 3:7, 7:3) res } \keyword{ multivariate } pcaPP/man/PCAproj.Rd0000644000176200001440000001314112777012547013631 0ustar liggesusers\name{PCAproj} \alias{PCAproj} \title{ Robust Principal Components using the algorithm of Croux and Ruiz-Gazen (2005) } \description{ Computes a desired number of (robust) principal components using the algorithm of Croux and Ruiz-Gazen (JMVA, 2005). } \usage{ PCAproj(x, k = 2, method = c("mad", "sd", "qn"), CalcMethod = c("eachobs", "lincomb", "sphere"), nmax = 1000, update = TRUE, scores = TRUE, maxit = 5, maxhalf = 5, scale = NULL, center = l1median_NLM, zero.tol = 1e-16, control) } \arguments{ \item{x}{ a numeric matrix or data frame which provides the data for the principal components analysis. } \item{k}{ desired number of components to compute } \item{method}{ scale estimator used to detect the direction with the largest variance. Possible values are \code{"sd"}, \code{"mad"} and \code{"qn"}, the latter can be called \code{"Qn"} too. \code{"mad"} is the default value.} \item{CalcMethod}{ the variant of the algorithm to be used. Possible values are \code{"eachobs"}, \code{"lincomb"} and \code{"sphere"}, with \code{"eachobs"} being the default. } \item{nmax}{ maximum number of directions to search in each step (only when using \code{"sphere"} or \code{"lincomb"} as the \code{CalcMethod}). } \item{update}{ a logical value indicating whether an update algorithm should be used.} \item{scores}{ a logical value indicating whether the scores of the principal component should be calculated. } \item{maxit}{ maximim number of iterations. } \item{maxhalf}{ maximum number of steps for angle halving. } \item{scale}{ this argument indicates how the data is to be rescaled. It can be a function like \code{\link{sd}} or \code{\link{mad}} or a vector of length \code{ncol(x)} containing the scale value of each column. } \item{center}{ this argument indicates how the data is to be centered. It can be a function like \code{\link{mean}} or \code{\link{median}} or a vector of length \code{ncol(x)} containing the center value of each column. } \item{zero.tol}{ the zero tolerance used internally for checking convergence, etc. } \item{control}{ a list which elements must be the same as (or a subset of) the parameters above. If the control object is supplied, the parameters from it will be used and any other given parameters are overridden. } } \details{ Basically, this algrithm considers the directions of each observation through the origin of the centered data as possible projection directions. As this algorithm has some drawbacks, especially if \code{ncol(x) > nrow(x)} in the data matrix, there are several improvements that can be used with this algorithm. \itemize{ \item{update}{An updating step basing on the algorithm for finding the eigenvectors is added to the algorithm. This can be used with any \code{CalcMethod} } \item{sphere}{Additional search directions are added using random directions. The random directions are determined using random data points generated from a p-dimensional multivariate standard normal distribution. These new data points are projected to the unit sphere, giving the new search directions.} \item{lincomb}{Additional search directions are added using linear combinations of the observations. It is similar to the \code{"sphere"}-algorithm, but the new data points are generated using linear combinations of the original data \code{b_1*x_1 + ... + b_n*x_n} where the coefficients \code{b_i} come from a uniform distribution in the interval \code{[0, 1]}. } } Similar to the function \code{\link{princomp}}, there is a \code{print} method for the these objects that prints the results in a nice format and the \code{plot} method produces a scree plot (\code{\link{screeplot}}). There is also a \code{\link{biplot}} method. } \value{ The function returns a list of class \code{"princomp"}, i.e. a list similar to the output of the function \code{\link{princomp}}. \item{sdev}{the (robust) standard deviations of the principal components.} \item{loadings}{the matrix of variable loadings (i.e., a matrix whose columns contain the eigenvectors). This is of class \code{"loadings"}: see \code{\link{loadings}} for its \code{\link{print}} method.} \item{center}{the means that were subtracted.} \item{scale}{the scalings applied to each variable.} \item{n.obs}{the number of observations.} \item{scores}{if \code{scores = TRUE}, the scores of the supplied data on the principal components.} \item{call}{the matched call.} } \references{ C. Croux, P. Filzmoser, M. Oliveira, (2007). Algorithms for Projection-Pursuit Robust Principal Component Analysis, \emph{Chemometrics and Intelligent Laboratory Systems}, Vol. 87, pp. 218-225. } \author{ Heinrich Fritz, Peter Filzmoser <\email{P.Filzmoser@tuwien.ac.at}>} \seealso{ \code{\link{PCAgrid}}, \code{\link{ScaleAdv}}, \code{\link{princomp}} } \examples{ # multivariate data with outliers library(mvtnorm) x <- rbind(rmvnorm(200, rep(0, 6), diag(c(5, rep(1,5)))), rmvnorm( 15, c(0, rep(20, 5)), diag(rep(1, 6)))) # Here we calculate the principal components with PCAgrid pc <- PCAproj(x, 6) # we could draw a biplot too: biplot(pc) # we could use another calculation method and another objective function, and # maybe only calculate the first three principal components: pc <- PCAproj(x, 3, "qn", "sphere") biplot(pc) # now we want to compare the results with the non-robust principal components pc <- princomp(x) # again, a biplot for comparision: biplot(pc) } \keyword{ robust } \keyword{ multivariate } pcaPP/man/PCdiagplot.Rd0000644000176200001440000000565012777012547014367 0ustar liggesusers\name{PCdiagplot} \alias{PCdiagplot} \title{Diagnostic plot for principal components} \description{ Computes Orthogonal Distances (OD) and Score Distances (SD) for already computed principal components using the projection pursuit technique. } \usage{ PCdiagplot(x, PCobj, crit = c(0.975, 0.99, 0.999), ksel = NULL, plot = TRUE, plotbw = TRUE, raw = FALSE, colgrid = "black", ...) } \arguments{ \item{x}{ a numeric matrix or data frame which provides the data for the principal components analysis. } \item{PCobj}{ a PCA object resulting from \code{\link{PCAproj}} or \code{\link{PCAgrid}} } \item{crit}{ quantile(s) used for the critical value(s) for OD and SD } \item{ksel}{ range for the number of PCs to be used in the plot; if NULL all PCs provided are used } \item{plot}{ if TRUE a plot is generated, otherwise only the values are returned } \item{plotbw}{ if TRUE the plot uses gray, otherwise color representation } \item{raw}{ if FALSE, the distribution of the SD will be transformed to approach chisquare distribution, otherwise the raw values are reported and used for plotting } \item{colgrid}{ the color used for the grid lines in the plot } \item{\dots}{ additional graphics parameters as used in \code{\link{par}} } } \details{ Based on (robust) principal components, a diagnostics plot is made using Orthogonal Distance (OD) and Score Distance (SD). This plot can provide important information about the multivariate data structure. } \value{ \item{ODist}{matrix with OD for each observation (rows) and each selected PC (cols) } \item{SDist}{matrix with SD for each observation (rows) and each selected PC (cols) } \item{critOD}{matrix with critical values for OD for each selected PC (rows) and each critical value (cols) } \item{critSD}{matrix with critical values for SD for each selected PC (rows) and each critical value (cols) } } \references{ P. Filzmoser and H. Fritz (2007). Exploring high-dimensional data with robust principal components. In S. Aivazian, P. Filzmoser, and Yu. Kharin, editors, Proceedings of the Eighth International Conference on Computer Data Analysis and Modeling, volume 1, pp. 43-50, Belarusian State University, Minsk. M. Hubert, P.J. Rousseeuwm, K. Vanden Branden (2005). ROBCA: a new approach to robust principal component analysis Technometrics 47, pp. 64-79. } \author{Peter Filzmoser <\email{P.Filzmoser@tuwien.ac.at}>} \seealso{\code{\link{PCAproj}}, \code{\link{PCAgrid}}} \examples{ # multivariate data with outliers library(mvtnorm) x <- rbind(rmvnorm(85, rep(0, 6), diag(c(5, rep(1,5)))), rmvnorm( 15, c(0, rep(20, 5)), diag(rep(1, 6)))) # Here we calculate the principal components with PCAgrid pcrob <- PCAgrid(x, k=6) resrob <- PCdiagplot(x,pcrob,plotbw=FALSE) # compare with classical method: pcclass <- PCAgrid(x, k=6, method="sd") resclass <- PCdiagplot(x,pcclass,plotbw=FALSE) } \keyword{robust} pcaPP/man/cor.fk.Rd0000644000176200001440000000504512777012547013521 0ustar liggesusers\name{cor.fk} \alias{cor.fk} \title{ Fast estimation of Kendall's tau rank correlation coefficient} \description{ Calculates Kendall's tau rank correlation coefficient in O (n log (n)) rather than O (n\^2) as in the current R implementation. } \usage{ %cor.fk (x, y = NULL, cor = TRUE) cor.fk (x, y = NULL) } \arguments{ \item{x}{ A vector, a matrix or a data frame of data. } \item{y}{ A vector of data. } % \item{cor}{ A logical value, specifying whether the correlation (\code{TRUE}) or the covariance (\code{FALSE} shall be estimated. )} } \value{ The estimated correlation coefficient. } \details{ The code of this implementation of the fast Kendall's tau correlation algorithm has originally been published by David Simcha. Due to it's runtime (\code{O(n log n)}) it's essentially faster than the current R implementation (\code{O (n\^2)}), especially for large numbers of observations. The algorithm goes back to Knight (1966) and has been described more detailed by Abrevaya (1999) and Christensen (2005). } \references{ Knight, W. R. (1966). A Computer Method for Calculating Kendall's Tau with Ungrouped Data. Journal of the American Statistical Association, \strong{314}(61) Part 1, 436-439.\cr Christensen D. (2005). Fast algorithms for the calculation of Kendall's Tau. Journal of Computational Statistics \strong{20}, 51-62.\cr Abrevaya J. (1999). Computation of the Maximum Rank Correlation Estimator. Economic Letters \strong{62}, 279-285. } \author{ David Simcha, Heinrich Fritz, Christophe Croux, Peter Filzmoser <\email{P.Filzmoser@tuwien.ac.at}>} \seealso{ \code{\link{cor}} } \examples{ set.seed (100) ## creating test data n <- 1000 x <- rnorm (n) y <- x+ rnorm (n) tim <- proc.time ()[1] ## applying cor.fk cor.fk (x, y) cat ("cor.fk runtime [s]:", proc.time ()[1] - tim, "(n =", length (x), ")\n") tim <- proc.time ()[1] ## applying cor (standard R implementation) cor (x, y, method = "kendall") cat ("cor runtime [s]:", proc.time ()[1] - tim, "(n =", length (x), ")\n") ## applying cor and cor.fk on data containing Xt <- cbind (c (x, as.integer (x)), c (y, as.integer (y))) tim <- proc.time ()[1] ## applying cor.fk cor.fk (Xt) cat ("cor.fk runtime [s]:", proc.time ()[1] - tim, "(n =", nrow (Xt), ")\n") tim <- proc.time ()[1] ## applying cor (standard R implementation) cor (Xt, method = "kendall") cat ("cor runtime [s]:", proc.time ()[1] - tim, "(n =", nrow (Xt), ")\n") } \keyword{multivariate} \keyword{robust} pcaPP/man/l1median_NLM.Rd0000644000176200001440000000712714040353376014533 0ustar liggesusers\name{l1median_NLM} \alias{l1median_NM} \alias{l1median_CG} \alias{l1median_BFGS} %\alias{l1median_SA} \alias{l1median_NLM} \alias{l1median_HoCr} \alias{l1median_VaZh} \title{ Multivariate L1 Median } \description{ Computes the multivariate L1 median (also called spatial median) of a data matrix \code{X}. } \usage{ l1median_NM (X, maxit = 200, tol = 10^-8, trace = 0, m.init = .colMedians (X), ...) l1median_CG (X, maxit = 200, tol = 10^-8, trace = 0, m.init = .colMedians (X), ...)%, type = 1) l1median_BFGS (X, maxit = 200, tol = 10^-8, trace = 0, m.init = .colMedians (X), REPORT = 10, ...) l1median_NLM (X, maxit = 200, tol = 10^-8, trace = 0, m.init = .colMedians (X), ...) l1median_HoCr (X, maxit = 200, tol = 10^-8, zero.tol = 1e-15, trace = 0, m.init = .colMedians (X), ...) l1median_VaZh (X, maxit = 200, tol = 10^-8, zero.tol = 1e-15, trace = 0, m.init = .colMedians (X), ...) } \arguments{ \item{X}{ a matrix of dimension \code{n} x \code{p}.} \item{maxit}{ The maximum number of iterations to be performed. } \item{tol}{ The convergence tolerance. } \item{trace}{ The tracing level. Set \code{trace > 0} to retrieve additional information on the single iterations. } \item{m.init}{ A vector of length \code{p} containing the initial value of the L1-median. } % \item{pscale}{ A vector of length \code{p} containing the variables scale to be used. } \item{REPORT}{ A parameter internally passed to \code{\link[stats]{optim}}. } \item{zero.tol}{ The zero-tolerance level used in \code{l1median_VaZh} and \code{l1median_HoCr} for determining the equality of two observations (i.e. an observation and a current center estimate). } \item{\dots}{ Further parameters passed from other functions. } % \item{TMax}{ } % \item{TempInit}{ } } \value{ % returns the vector of the coordinates of the L1 median. % return (list (par = ret$med, value = ret$dpar.out[1], code = ret$npar.out [1], iterations = ret$npar.out [2], iterations_gr = ret$npar.out [3])) \item{par}{ A vector of length \code{p} containing the L1-median. } \item{value}{ The value of the objective function \code{||X - l1median||} which is minimized for finding the L1-median. } \item{code}{ The return code of the optimization algorithm. See \code{\link[stats]{optim}} and \code{\link[stats]{nlm}} for further information. } \item{iterations}{ The number of iterations performed. } \item{iterations_gr}{ When using a gradient function this value holds the number of times the gradient had to be computed. } \item{time}{The algorithms runtime in milliseconds.} } \details{The L1-median is computed using the built-in functions \code{\link[stats]{optim}} and \code{\link[stats]{nlm}}. These functions are a transcript of the \code{L1median} method of package \code{robustX}, porting as much code as possible into C++.} \author{Heinrich Fritz, Peter Filzmoser <\email{P.Filzmoser@tuwien.ac.at}>} \seealso{ \code{\link{median}}} \note{See the vignette "Compiling pcaPP for Matlab" which comes with this package to compile and use some of these functions in Matlab.} \examples{ # multivariate data with outliers library(mvtnorm) x <- rbind(rmvnorm(200, rep(0, 4), diag(c(1, 1, 2, 2))), rmvnorm( 50, rep(3, 4), diag(rep(2, 4)))) l1median_NM (x)$par l1median_CG (x)$par l1median_BFGS (x)$par l1median_NLM (x)$par l1median_HoCr (x)$par l1median_VaZh (x)$par # compare with coordinate-wise median: apply(x,2,median) } \keyword{ multivariate } \keyword{ robust } pcaPP/man/Qn.Rd0000644000176200001440000000241212777012547012710 0ustar liggesusers\name{qn} \alias{qn} \title{ scale estimation using the robust Qn estimator } \description{ Returns a scale estimation as calculated by the (robust) Qn estimator. } \usage{ qn(x, corrFact) } \arguments{ \item{x}{ a vector of data } \item{corrFact}{ the finite sample bias correction factor. By default a value of ~ 2.219144 is used (assuming normality). } } \details{ The Qn estimator computes the first quartile of the pairwise absolute differences of all data values. } \value{ The estimated scale of the data. } \references{ P.J. Rousseeuw, C. Croux (1993) Alternatives to the Median Absolute Deviation, \emph{JASA}, \strong{88}, 1273-1283. } \author{ Heinrich Fritz, Peter Filzmoser <\email{P.Filzmoser@tuwien.ac.at}>} \section{Warning }{ Earlier implementations used a wrong correction factor for the final result. Thus qn estimations computed with package pcaPP version > 1.8-1 differ about 0.12\% from earlier estimations (version <= 1.8-1). } \seealso{ \code{\link{mad}} } \note{See the vignette "Compiling pcaPP for Matlab" which comes with this package to compile and use this function in Matlab.} \examples{ # data with outliers x <- c(rnorm(100), rnorm(10, 10)) qn(x) } \keyword{multivariate} \keyword{robust} pcaPP/man/covPC.Rd0000644000176200001440000000325712777012547013354 0ustar liggesusers\name{covPC} \alias{covPC} \title{ Covariance Matrix Estimation from princomp Object} \description{ computes the covariance matrix from a princomp object. The number of components k can be given as input. } \usage{ covPC(x, k, method) } \arguments{ \item{x}{ an object of class princomp. } \item{k}{ number of PCs to use for covariance estimation (optional). } \item{method}{ method how the PCs have been estimated (optional). } } \details{ There are several possibilities to estimate the principal components (PCs) from an input data matrix, including the functions \code{\link{PCAproj}} and \code{\link{PCAgrid}}. This function uses the estimated PCs to reconstruct the covariance matrix. Not all PCs have to be used, the number k of PCs (first k PCs) can be given as input to the function. } \value{ \item{cov}{ the estimated covariance matrix} \item{center}{ the center of the data, as provided from the princomp object.} \item{method}{ a string describing the method that was used to calculate the PCs.} } \references{ C. Croux, P. Filzmoser, M. Oliveira, (2007). Algorithms for Projection-Pursuit Robust Principal Component Analysis, \emph{Chemometrics and Intelligent Laboratory Systems}, Vol. 87, pp. 218-225. } \author{ Heinrich Fritz, Peter Filzmoser <\email{P.Filzmoser@tuwien.ac.at}> } \seealso{ \code{\link{PCAgrid}}, \code{\link{PCAproj}}, \code{\link{princomp}} } \examples{ # multivariate data with outliers library(mvtnorm) x <- rbind(rmvnorm(200, rep(0, 6), diag(c(5, rep(1,5)))), rmvnorm( 15, c(0, rep(20, 5)), diag(rep(1, 6)))) pc <- princomp(x) covPC(pc, k=2) } \keyword{ multivariate } pcaPP/man/l1median.Rd0000644000176200001440000000254312777012547014031 0ustar liggesusers\name{l1median} \alias{l1median} \title{ Multivariate L1 Median } \description{ Computes the multivariate L1 median (also called spatial median) of a data matrix. } \usage{ l1median(X, MaxStep = 200, ItTol = 10^-8, trace = 0, m.init = .colMedians (X)) } \arguments{ \item{X}{ A matrix containing the values whose multivariate L1 median is to be computed. } \item{MaxStep}{ The maximum number of iterations. } \item{ItTol}{ Tolerance for convergence of the algorithm.} \item{trace}{ The tracing level. } \item{m.init}{ An initial estimate. } } \value{ returns the vector of the coordinates of the L1 median. } \references{ C. Croux, P. Filzmoser, M. Oliveira, (2007). Algorithms for Projection-Pursuit Robust Principal Component Analysis, \emph{Chemometrics and Intelligent Laboratory Systems}, Vol. 87, pp. 218-225. } \author{Heinrich Fritz, Peter Filzmoser <\email{P.Filzmoser@tuwien.ac.at}>} \seealso{ \code{\link{median}}} \examples{ l1median(rnorm(100), trace = -1) # this returns the median of the sample # multivariate data with outliers library(mvtnorm) x <- rbind(rmvnorm(200, rep(0, 4), diag(c(1, 1, 2, 2))), rmvnorm( 50, rep(3, 4), diag(rep(2, 4)))) l1median(x, trace = -1) # compare with coordinate-wise median: apply(x,2,median) } \keyword{ multivariate } \keyword{ robust } pcaPP/man/covPCA.Rd0000644000176200001440000000337312777012547013454 0ustar liggesusers\name{covPCA} \alias{covPCAproj} \alias{covPCAgrid} \title{ Robust Covariance Matrix Estimation } \description{ computes the robust covariance matrix using the \code{PCAgrid} and \code{PCAproj} functions. } \usage{ covPCAproj(x, control) covPCAgrid(x, control) } \arguments{ \item{x}{ a numeric matrix or data frame which provides the data. } \item{control}{ a list whose elements must be the same as (or a subset of) the parameters of the appropriate PCA function (\code{\link{PCAgrid}} or \code{\link{PCAproj}}). } } \details{ The functions \code{covPCAproj} and \code{covPCAgrid} use the functions \code{\link{PCAproj}} and \code{\link{PCAgrid}} respectively to estimate the covariance matrix of the data matrix \code{x}. } \value{ \item{cov}{ the actual covariance matrix estimated from \code{x}} \item{center}{ the center of the data \code{x} that was substracted from them before the PCA algorithms were run.} \item{method}{ a string describing the method that was used to calculate the covariance matrix estimation} } \references{ C. Croux, P. Filzmoser, M. Oliveira, (2007). Algorithms for Projection-Pursuit Robust Principal Component Analysis, \emph{Chemometrics and Intelligent Laboratory Systems}, Vol. 87, pp. 218-225. } \author{ Heinrich Fritz, Peter Filzmoser <\email{P.Filzmoser@tuwien.ac.at}> } \seealso{ \code{\link{PCAgrid}}, \code{\link{ScaleAdv}}, \code{\link{princomp}} } \examples{ # multivariate data with outliers library(mvtnorm) x <- rbind(rmvnorm(200, rep(0, 6), diag(c(5, rep(1,5)))), rmvnorm( 15, c(0, rep(20, 5)), diag(rep(1, 6)))) covPCAproj(x) # compare with classical covariance matrix: cov(x) } \keyword{ robust } \keyword{ multivariate } pcaPP/man/opt.TPO.Rd0000644000176200001440000001603512777012547013603 0ustar liggesusers\name{opt.TPO} \alias{opt.TPO} \alias{opt.BIC} \title{ Model Selection for Sparse (Robust) Principal Components } \description{ These functions compute a suggestion for the sparseness parameter \code{lambda} which is required by function \code{\link{sPCAgrid}}. A range of different values for lambda is tested and according to an objective function, the best solution is selected. Two different approaches (TPO and BIC) are available, which is further discussed in the details section. A graphical summary of the optimization can be obtained by plotting the function's return value (\code{\link{plot.opt.TPO}}, \code{\link{plot.opt.BIC}} for tradeoff curves or \code{\link{objplot}} for an objective function plot). } \usage{ opt.TPO (x, k.max = ncol (x), n.lambda = 30, lambda.max, ...) opt.BIC (x, k.max = ncol (x), n.lambda = 30, lambda.max, ...) } \arguments{ \item{x}{ a numerical matrix or data frame of dimension (\code{n x p}), which provides the data for the principal components analysis. } \item{k.max}{ the maximum number of components which shall be considered for optimizing an objective function (optional). } \item{n.lambda}{ the number of lambdas to be checked for each component (optional). } \item{lambda.max}{ the maximum value of lambda to be checked (optional). If omitted, the lambda which yields "full sparseness" (i.e. loadings of only zeros and ones) is computed and used as default value. } \item{...}{ further arguments passed to \code{\link{sPCAgrid}} } } \details{ % explain difference between TPO and BIC The choice for a particular lambda is done by optimizing an objective function, which is calculated for a set of \code{n.lambda} models with different lambdas, ranging from 0 to \code{lambda.max}. If \code{lambda.max} is not specified, the minimum lambda yielding "full sparseness" is used. "Full sparseness" refers to a model with minimum possible absolute sum of loadings, which in general implies only zeros and ones in the loadings matrix. The user can choose between two optimization methods: TPO (Tradeoff Product Optimization; see below), or the BIC (see Guo et al., 2011; Croux et al., 2011). The main difference is, that optimization based on the BIC always chooses the same lambda for all PCs, and refers to a particular choice of \code{k}, the number of considered components. TPO however is optimized separately for each component, and so delivers different lambdas within a model and does not depend on a decision on \code{k}. \cr This characteristic can be noticed in the return value of the function: \code{\link{opt.TPO}} returns a single model with \code{k.max} PCs and different values of \code{lambda} for each PC. On the contrary \code{\link{opt.BIC}} returns \code{k.max} distinct models with \code{k.max} different lambdas, whereas for each model a different number of components \code{k} has been considered for the optimization. Applying the latter method, the user finally has to select one of these \code{k.max} models manually, e.g. by considering the cumulated explained variance, whereas the TPO method does not require any further decisions. % TPO The tradeoff made in the context of sparse PCA refers to the loss of explained variance vs. the gain of sparseness. TPO (Tradeoff Product Optimization) maximizes the area under the tradeoff curve (see \code{\link{plot.opt.TPO}}), in particular it maximizes the explained variance multiplied by the number of zero loadings of a particular component. As in this context the according criterion is minimized, the negative product is considered. % explain problem of ordered / not ordered PCs Note that in the context of sparse PCA, there are two sorting orders of PCs, which must be considered: Either according to the objective function's value, (item \code{$pc.noord})or the variance of each PC(item \code{$pc}). As in none-sparse PCA the objective function is identical to the PCs' variance, this is not an issue there.\cr The sPCAgrid algorithm delivers the components in decreasing order, according to the objective function (which apart from the variance also includes sparseness terms), whereas the method \code{\link{sPCAgrid}} subsequently re-orders the components according to their explained variance. } \value{ The functions return an S3 object of type "opt.TPO" or "opt.BIC" respectively, containing the following items: \item{pc}{ An S3 object of type \code{princomp} (\code{\link{opt.TPO}}), or a list of such objects of length \code{k.max} (\code{\link{opt.BIC}}), as returned by \code{\link{sPCAgrid}}.} \item{pc.noord}{An S3 object of type \code{princomp} (\code{\link{opt.TPO}}), or a list of such objects of length \code{k.max} (\code{\link{opt.BIC}}), as returned by \code{\link{sPCAgrid}}.\cr Here the PCs have not been re-ordered according to their variance, but are still ordered according to their objective function's value as returned by the \code{\link{sPCAgrid}} - algorithm. This information is used for according tradeoff curves and the objective function plot.} \item{x}{ The input data matrix as provided by the user. } \item{k.ini, opt}{ These items contain optimization information, as used in functions \code{\link{plot.opt.TPO}}, \code{\link{plot.opt.BIC}} and \code{\link{objplot}}.} } \references{ C. Croux, P. Filzmoser, H. Fritz (2011). Robust Sparse Principal Component Analysis Based on Projection-Pursuit, \emph{??} To appear. } \author{Heinrich Fritz, Peter Filzmoser <\email{P.Filzmoser@tuwien.ac.at}>} \seealso{ \code{\link{sPCAgrid}}, \code{\link{princomp}} } \examples{ set.seed (0) ## generate test data x <- data.Zou (n = 250) k.max <- 3 ## max number of considered sparse PCs ## arguments for the sPCAgrid algorithm maxiter <- 25 ## the maximum number of iterations method <- "sd" ## using classical estimations ## Optimizing the TPO criterion oTPO <- opt.TPO (x, k.max = k.max, method = method, maxiter = maxiter) oTPO$pc ## the model selected by opt.TPO oTPO$pc$load ## and the according sparse loadings. ## Optimizing the BIC criterion oBIC <- opt.BIC (x, k.max = k.max, method = method, maxiter = maxiter) oBIC$pc[[1]] ## the first model selected by opt.BIC (k = 1) ## Tradeoff Curves: Explained Variance vs. sparseness par (mfrow = c (2, k.max)) for (i in 1:k.max) plot (oTPO, k = i) for (i in 1:k.max) plot (oBIC, k = i) ## Tradeoff Curves: Explained Variance vs. lambda par (mfrow = c (2, k.max)) for (i in 1:k.max) plot (oTPO, k = i, f.x = "lambda") for (i in 1:k.max) plot (oBIC, k = i, f.x = "lambda") ## Objective function vs. lambda par (mfrow = c (2, k.max)) for (i in 1:k.max) objplot (oTPO, k = i) for (i in 1:k.max) objplot (oBIC, k = i) } \keyword{multivariate} \keyword{robust} pcaPP/man/plot.opt.TPO.Rd0000644000176200001440000001162412777012547014557 0ustar liggesusers\name{plot.opt.TPO} \alias{plot.opt.TPO} \alias{plot.opt.BIC} \title{ Tradeoff Curves for Sparse PCs } \description{ Tradeoff curves of one or more sparse PCs for a series of lambdas, which contrast the loss of explained variance and the gain of sparseness. } \usage{ \method{plot}{opt.TPO} (x, k, f.x = c ("l0", "pl0", "l1", "pl1", "lambda"), f.y = c ("var", "pvar"), ...) \method{plot}{opt.BIC} (x, k, f.x = c ("l0", "pl0", "l1", "pl1", "lambda"), f.y = c ("var", "pvar"), ...) } \arguments{ \item{x}{ An \code{\link{opt.TPO}} or \code{\link{opt.BIC}} object. } \item{k}{ This function plots the tradeoff curve of the \code{k}-th component for \code{opt.TPO}-objects, or the first \code{k} components for \code{opt.BIC}-objects. } \item{f.x, f.y}{ A string, specifying which information shall be plotted on the x and y - axis. See the details section for more information.} \item{...}{ Further arguments passed to or from other functions. } } \details{ The argument \code{f.x} can obtain the following values: \itemize{ \item \code{"l0"}: l0 - sparseness, which corresponds to the number of zero loadings of the considered component(s). \item \code{"pl0"}: l0 - sparseness in percent (l0 - sparseness ranges from \code{0} to \code{p-1} for each component). \item \code{"l1"}: l1 - sparseness, which corresponds to the negative sum of absolute loadings of the considered component(s).\cr (The exact value displayed for a single component is \code{sqrt (p) - S}, with \code{S} as the the absolute sum of loadings.) \cr As this value is a part of the objective function which selects the candidate directions within the \code{\link{sPCAgrid}} function, this option is provided here. \item \code{"pl1"} The "l1 - sparseness" in percent (l1 - sparseness ranges from \code{0} to \code{sqrt (p-1)} for each component). \item \code{"lambda"}: The lambda used for computing a particular model. } The argument \code{f.y} can obtain the following values: \itemize{ \item \code{"var"}: The (cumulated) explained variance of the considered component(s). The value shown here is calculated using the variance estimator specified via the \code{method} argument of function \code{\link{sPCAgrid}}. \item \code{"pvar"}: The (cumulated) explained variance of the considered component(s) in percent. The 100\%-level is assumed as the sum of variances of all columns of argument \code{x}.\cr Again the same variance estimator is used as specified via the \code{method} argument of function \code{\link{sPCAgrid}}.\cr } The subtitle summarizes the result of the applied criterion for selecting a value of lambda: \itemize{ \item The name of the applied method (TPO/BIC). \item The selected value of \code{lambda} for the \code{k}-th component (\code{\link{opt.TPO}}) or all computed components (\code{\link{opt.BIC}}). \item The empirical cumulated variance (ECV) of the first \code{k} components in percent. \item The obtained l0-sparseness of the first \code{k} components. } This function operates on the return object of function \code{\link{opt.TPO}} or \code{\link{opt.BIC}}. The model (\code{lambda}) selected by the minimization of the corresponding criterion is highlighted by a dashed vertical line. The component the argument \code{k} refers to, corresponds to the \code{$pc.noord} item of argument \code{x}. For more info on the order of sparse PCs see the details section of \code{\link{opt.TPO}}. } %\value{none } \references{ C. Croux, P. Filzmoser, H. Fritz (2011). Robust Sparse Principal Component Analysis Based on Projection-Pursuit, \emph{??} To appear. } \author{Heinrich Fritz, Peter Filzmoser <\email{P.Filzmoser@tuwien.ac.at}>} \seealso{ \code{\link{sPCAgrid}}, \code{\link{princomp}} } \examples{ set.seed (0) ## generate test data x <- data.Zou (n = 250) k.max <- 3 ## max number of considered sparse PCs ## arguments for the sPCAgrid algorithm maxiter <- 25 ## the maximum number of iterations method <- "sd" ## using classical estimations ## Optimizing the TPO criterion oTPO <- opt.TPO (x, k.max = k.max, method = method, maxiter = maxiter) ## Optimizing the BIC criterion oBIC <- opt.BIC (x, k.max = k.max, method = method, maxiter = maxiter) ## Tradeoff Curves: Explained Variance vs. sparseness par (mfrow = c (2, k.max)) for (i in 1:k.max) plot (oTPO, k = i) for (i in 1:k.max) plot (oBIC, k = i) ## Explained Variance vs. lambda par (mfrow = c (2, k.max)) for (i in 1:k.max) plot (oTPO, k = i, f.x = "lambda") for (i in 1:k.max) plot (oBIC, k = i, f.x = "lambda") } \keyword{multivariate} \keyword{robust} pcaPP/man/objplot.Rd0000644000176200001440000000423112777012547014004 0ustar liggesusers\name{objplot} \alias{objplot} \title{ Objective Function Plot for Sparse PCs } \description{ Plots an objective function (TPO or BIC) of one or more sparse PCs for a series of lambdas. } \usage{ objplot (x, k, ...) } \arguments{ \item{x}{ An \code{\link{opt.TPO}} or \code{\link{opt.BIC}} object. } \item{k}{ This function displays the objective function's values of the \code{k}-th component for \code{opt.TPO}-objects, or the first \code{k} components for \code{opt.BIC}-objects. } \item{...}{ Further arguments passed to or from other functions. } } \details{ This function operates on the return object of function \code{\link{opt.TPO}} or \code{\link{opt.BIC}}. The model (\code{lambda}) selected by the minimization of the corresponding criterion is highlighted by a dashed vertical line. The component the argument \code{k} refers to, corresponds to the \code{$pc.noord} item of argument \code{x}. For more info on the order of sparse PCs see the details section of \code{\link{opt.TPO}}. } %\value{none } \references{ C. Croux, P. Filzmoser, H. Fritz (2011). Robust Sparse Principal Component Analysis Based on Projection-Pursuit, \emph{??} To appear. } \author{Heinrich Fritz, Peter Filzmoser <\email{P.Filzmoser@tuwien.ac.at}>} \seealso{ \code{\link{sPCAgrid}}, \code{\link{princomp}} } \examples{ set.seed (0) ## generate test data x <- data.Zou (n = 250) k.max <- 3 ## max number of considered sparse PCs ## arguments for the sPCAgrid algorithm maxiter <- 25 ## the maximum number of iterations method <- "sd" ## using classical estimations ## Optimizing the TPO criterion oTPO <- opt.TPO (x, k.max = k.max, method = method, maxiter = maxiter) ## Optimizing the BIC criterion oBIC <- opt.BIC (x, k.max = k.max, method = method, maxiter = maxiter) ## Objective function vs. lambda par (mfrow = c (2, k.max)) for (i in 1:k.max) objplot (oTPO, k = i) for (i in 1:k.max) objplot (oBIC, k = i) } \keyword{multivariate} \keyword{robust} pcaPP/DESCRIPTION0000644000176200001440000000131214040447642012765 0ustar liggesusersPackage: pcaPP Version: 1.9-74 Date: 2021-04-22 VersionNote: Released 1.9-73 on 2018-01-04 on CRAN Title: Robust PCA by Projection Pursuit Author: Peter Filzmoser, Heinrich Fritz, Klaudius Kalcher Maintainer: Valentin Todorov Imports: mvtnorm Suggests: robustbase Description: Provides functions for robust PCA by projection pursuit. The methods are described in Croux et al. (2006) , Croux et al. (2013) , Todorov and Filzmoser (2013) . License: GPL (>= 3) NeedsCompilation: yes Repository: CRAN Packaged: 2021-04-22 22:08:03 UTC; valen Date/Publication: 2021-04-23 04:40:02 UTC pcaPP/build/0000755000176200001440000000000013300576522012357 5ustar liggesuserspcaPP/build/vignette.rds0000644000176200001440000000033212777012561014721 0ustar liggesusersuQ 0\U(/ C1DAznDKM1fg2̐[68.V['>Ϡ&'X@3dA,]F,+MHq72kik0 Tz^fsZL+g5+,8qSʺɒtjtH㫦D{#/,.3vIkJґR^pcaPP/tests/0000755000176200001440000000000013300576522012422 5ustar liggesuserspcaPP/tests/tpcapp.Rout.save0000644000176200001440000001626013123717020015517 0ustar liggesusers R Under development (unstable) (2017-05-08 r72665) -- "Unsuffered Consequences" Copyright (C) 2017 The R Foundation for Statistical Computing Platform: x86_64-w64-mingw32/x64 (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > ## this will render the output independent from the version of the package > suppressPackageStartupMessages(library(pcaPP)) > > ## Sparse loadings > set.seed (0) > ##x <- data.Zou() > data(iris) > x <- iris[, 1:4] > > l1median_NM (x)$par [1] 5.931944 2.913282 4.215406 1.364975 > l1median_CG (x)$par [1] 5.932216 2.912279 4.215837 1.364750 > l1median_BFGS (x)$par [1] 5.932216 2.912279 4.215837 1.364750 > l1median_NLM (x)$par [1] 5.932216 2.912279 4.215837 1.364750 > l1median_HoCr (x)$par [1] 5.932216 2.912279 4.215837 1.364750 > l1median_VaZh (x)$par [1] 5.932216 2.912279 4.215837 1.364750 > > # compare with coordinate-wise median: > apply(x,2,median) Sepal.Length Sepal.Width Petal.Length Petal.Width 5.80 3.00 4.35 1.30 > > pc <- PCAgrid(x) > pc Call: PCAgrid(x = x) Standard deviations: [1] 2.3555356 0.9095565 4 variables and 150 observations. > summary(pc) Importance of components: [,1] [,2] Standard deviation 2.3555356 0.9095565 Proportion of Variance 0.8702457 0.1297543 Cumulative Proportion 0.8702457 1.0000000 > pc$loadings Loadings: Comp.1 Comp.2 Sepal.Length 0.589 -0.618 Sepal.Width 0.174 Petal.Length 0.598 0.749 Petal.Width 0.543 -0.163 Comp.1 Comp.2 SS loadings 1.00 1.00 Proportion Var 0.25 0.25 Cumulative Var 0.25 0.50 > pc$scores Comp.1 Comp.2 [1,] -2.791519460 -1.304428269 [2,] -2.921720995 -1.267984502 [3,] -3.094390048 -1.184566289 [4,] -3.036232432 -0.990326562 [5,] -2.847966568 -1.225246155 [6,] -2.316930680 -1.227763426 [7,] -3.034282033 -1.029294612 [8,] -2.793136680 -1.185134557 [9,] -3.218791382 -0.976577184 [10,] -2.913781498 -1.159347616 [11,] -2.550040927 -1.379942552 [12,] -2.851201009 -0.986658731 [13,] -3.034948391 -1.189945935 [14,] -3.508870813 -1.105959455 [15,] -2.486269684 -1.799588594 [16,] -2.247359234 -1.475864129 [17,] -2.556030025 -1.527547488 [18,] -2.737211646 -1.320701930 [19,] -2.196952220 -1.414201690 [20,] -2.670019387 -1.193504288 [21,] -2.437908677 -1.282302147 [22,] -2.618184048 -1.227195159 [23,] -3.322744244 -1.277970595 [24,] -2.454216458 -1.163245624 [25,] -2.671876500 -0.761820684 [26,] -2.743251740 -1.179857376 [27,] -2.624746217 -1.142735864 [28,] -2.672825041 -1.291247159 [29,] -2.735072351 -1.383610383 [30,] -2.915065539 -0.959728243 [31,] -2.858618431 -1.038910357 [32,] -2.448842723 -1.464741501 [33,] -2.712298010 -1.170470245 [34,] -2.538533811 -1.429567429 [35,] -2.859473685 -1.175621278 [36,] -2.977406137 -1.444807021 [37,] -2.615615966 -1.626433906 [38,] -2.961193964 -1.147207588 [39,] -3.276093744 -1.034105991 [40,] -2.734217097 -1.246899462 [41,] -2.855906065 -1.333883041 [42,] -3.180173667 -1.234065019 [43,] -3.271148796 -0.999271573 [44,] -2.513658115 -1.157865978 [45,] -2.376612229 -0.909993888 [46,] -2.926332764 -1.222493258 [47,] -2.664552365 -1.102284611 [48,] -3.093534795 -1.047855368 [49,] -2.608960510 -1.318177647 [50,] -2.855383990 -1.277497781 [51,] 0.944798547 -0.252278522 [52,] 0.526039193 -0.047854782 [53,] 1.057263977 -0.074312455 [54,] -0.433979126 0.009091732 [55,] 0.634843715 -0.104342507 [56,] -0.004903408 0.347378043 [57,] 0.643449570 0.164945702 [58,] -1.366371442 -0.078702751 [59,] 0.587620145 -0.116142881 [60,] -0.606315000 0.172835607 [61,] -1.197792083 -0.060244461 [62,] 0.047171823 0.001297281 [63,] -0.304777128 -0.268329019 [64,] 0.407104882 0.251354000 [65,] -0.599324044 -0.247953982 [66,] 0.586242816 -0.309239061 [67,] 0.049737584 0.411430044 [68,] -0.350479086 0.017232851 [69,] 0.383475287 -0.098497059 [70,] -0.538505058 -0.060237448 [71,] 0.573689229 0.436986807 [72,] -0.068099260 -0.274411656 [73,] 0.688911637 0.191773724 [74,] 0.296016781 0.266484114 [75,] 0.290456471 -0.217451116 [76,] 0.524850760 -0.264891364 [77,] 0.876844322 -0.123471530 [78,] 1.105342801 0.074198839 [79,] 0.282943440 0.146953213 [80,] -0.770520160 -0.388095545 [81,] -0.659671951 -0.090835767 [82,] -0.773754601 -0.149508121 [83,] -0.361413131 -0.165206503 [84,] 0.690955323 0.545521228 [85,] -0.068101581 0.534959854 [86,] 0.349613624 0.217765596 [87,] 0.819875139 -0.100674676 [88,] 0.276476880 -0.185243448 [89,] -0.297977388 0.144193304 [90,] -0.429034177 0.043926150 [91,] -0.241770172 0.377401082 [92,] 0.349802520 0.193825194 [93,] -0.304110769 -0.107677696 [94,] -1.309924333 -0.157884865 [95,] -0.245619974 0.166887693 [96,] -0.233590783 0.173648076 [97,] -0.181755443 0.139957206 [98,] 0.172617306 -0.093921306 [99,] -1.371076498 -0.425927061 [100,] -0.244002754 0.047593981 [101,] 1.909292764 0.992780951 [102,] 0.736039599 0.620230054 [103,] 2.096225912 0.436558712 [104,] 1.280148828 0.737243684 [105,] 1.737241394 0.715928467 [106,] 2.809247679 0.652356294 [107,] -0.266446237 0.724151014 [108,] 2.287768508 0.644216739 [109,] 1.625486934 0.570407258 [110,] 2.506761266 0.564094445 [111,] 1.215146861 0.258688099 [112,] 1.209106767 0.399532653 [113,] 1.680367819 0.322069366 [114,] 0.666708045 0.555940865 [115,] 1.010051141 0.556278956 [116,] 1.438700391 0.421524051 [117,] 1.340685631 0.556185066 [118,] 3.002029704 0.788601413 [119,] 3.146217501 0.713213277 [120,] 0.564510303 0.399762829 [121,] 1.972397649 0.412483586 [122,] 0.555431049 0.595011381 [123,] 2.868689336 0.646976648 [124,] 0.856780025 0.177787157 [125,] 1.748415331 0.585977929 [126,] 2.056941838 0.533395224 [127,] 0.740558081 0.182023256 [128,] 0.746358283 0.353568595 [129,] 1.499519377 0.609240585 [130,] 1.823831591 0.381216098 [131,] 2.278973757 0.398868932 [132,] 2.831928733 0.472780879 [133,] 1.553827190 0.592966924 [134,] 0.815878732 0.393917382 [135,] 0.937660987 0.873616514 [136,] 2.677908707 0.183313988 [137,] 1.618358079 0.726687759 [138,] 1.284238522 0.635367181 [139,] 0.627663864 0.340387484 [140,] 1.681985039 0.202775654 [141,] 1.846618987 0.427376511 [142,] 1.611276157 -0.054609716 [143,] 0.736039599 0.620230054 [144,] 2.033027739 0.624140523 [145,] 1.965646585 0.520883283 [146,] 1.550739354 0.126448902 [147,] 0.965917727 0.201625094 [148,] 1.269976749 0.298799697 [149,] 1.385581011 0.654834295 [150,] 0.748068790 0.626990436 > > proc.time() user system elapsed 0.51 0.07 0.56 pcaPP/tests/tpcapp.R0000644000176200001440000000072313124436246014040 0ustar liggesusers## this will render the output independent from the version of the package suppressPackageStartupMessages(library(pcaPP)) ## Sparse loadings set.seed (0) ##x <- data.Zou() data(iris) x <- iris[, 1:4] l1median_NM (x)$par l1median_CG (x)$par l1median_BFGS (x)$par l1median_NLM (x)$par l1median_HoCr (x)$par l1median_VaZh (x)$par # compare with coordinate-wise median: apply(x,2,median) pc <- PCAgrid(x) pc summary(pc) pc$loadings pc$scores pcaPP/src/0000755000176200001440000000000013300576522012047 5ustar liggesuserspcaPP/src/ML_package.cpp0000644000176200001440000002443513300577052014545 0ustar liggesusers#ifdef MATLAB_MEX_FILE #include "ML_package.h" #include "L1Median.h" #include "qnn.h" #include "PCAgrid.h" #include "PCAproj.h" void mexFunction(int nlhs, mxArray* plhs[], int nrhs, mxArray *prhs[]) { if (nrhs < 1) { meal_error ("At least one argument needed.") ; return ; } mxArray *pSwitch = prhs [0] ; if (mxGetM (pSwitch) != 1 || mxGetN (pSwitch) != 1) { meal_error ("First argument has to be of size 1x1.") ; return ; } int nSwitch = (int) *mxGetPr (pSwitch) ; switch (nSwitch) { case 0: ML_l1median_HoCr (nlhs, plhs, nrhs - 1, prhs + 1) ; break ; case 1: ML_l1median_VaZh (nlhs, plhs, nrhs - 1, prhs + 1) ; break ; case 2: ML_qn (nlhs, plhs, nrhs - 1, prhs + 1) ; break ; case 3: ML_PCAgrid (nlhs, plhs, nrhs - 1, prhs + 1) ; break ; case 4: ML_sPCAgrid (nlhs, plhs, nrhs - 1, prhs + 1) ; break ; case 5: ML_PCAproj (nlhs, plhs, nrhs - 1, prhs + 1) ; break ; case 6: ML_PCAprojU (nlhs, plhs, nrhs - 1, prhs + 1) ; break ; default: meal_error ("Unknown switch argument received.") ; break ; } ; } void ML_l1median_HoCr (int nlhs, mxArray* plhs[], int nrhs, mxArray *prhs[]) //(int *pnParIn, int *pnParOut, double *pdParIn, double *pdX, double *pdMed) { if (nlhs != 1) meal_error ("1 output argument expected") ; if (nrhs != 3) meal_error ("3 input arguments expected") ; // Data Matrix mxArray *mxX = prhs [0] ; const int n = mxGetM (mxX), p = mxGetN (mxX) ; double *pdX = mxGetPr (mxX) ; // Median Vector mxArray *mxMed = prhs [1] ; if (mxGetM (mxMed) * mxGetN (mxMed) != (t_size) p) meal_error ("Length of the median vector is expected to be p.") ; double *pdMed = mxGetPr (mxMed) ; // Parameter Vector mxArray *mxPar = prhs [2] ; if (mxGetM (mxPar) * mxGetN (mxPar)!= 4) meal_error ("Parameter array of dimension 5x1 expected") ; double *pdParIn = mxGetPr (mxPar) ; const int &dwMaxit = (int) pdParIn[0], dwTrace = (int) pdParIn[1] ; const double &dTol = pdParIn[2], &dZeroTol = pdParIn[3] ; plhs [0] = mxCreateDoubleMatrix (1, 2, mxREAL) ; double *pdParOut = mxGetPr (plhs [0]) ; double &dCode = pdParOut [0] ; int nIterCount ; TRY( dCode = l1median_HoCr (SMatD (pdX, n, p), SVecD (pdMed, p), dZeroTol, dTol, dwMaxit, dwTrace, &nIterCount) ; ) // Out Parameter Vector pdParOut [1] = nIterCount ; return ; } void ML_l1median_VaZh (int nlhs, mxArray* plhs[], int nrhs, mxArray *prhs[]) //(int *pnParIn, int *pnParOut, double *pdParIn, double *pdX, double *pdMed) { if (nlhs != 1) meal_error ("1 output argument expected") ; if (nrhs != 3) meal_error ("3 input arguments expected") ; // Data Matrix mxArray *mxX = prhs [0] ; const int n = mxGetM (mxX), p = mxGetN (mxX) ; double *pdX = mxGetPr (mxX) ; // Median Vector mxArray *mxMed = prhs [1] ; if (mxGetM (mxMed) * mxGetN (mxMed) != (t_size) p) meal_error ("Length of the median vector is expected to be p.") ; double *pdMed = mxGetPr (mxMed) ; // Parameter Vector mxArray *mxPar = prhs [2] ; if (mxGetM (mxPar) * mxGetN (mxPar)!= 4) meal_error ("Parameter array of dimension 5x1 expected") ; double *pdParIn = mxGetPr (mxPar) ; const int &dwMaxit = (int) pdParIn[0], dwTrace = (int) pdParIn[1] ; const double &dTol = pdParIn[2], &dZeroTol = pdParIn[3] ; int nCode, nIterCount ; TRY( CL1Median_VZ (n, p, nCode, nIterCount, pdParIn, pdX, pdMed, NULL) ; //, pdWeights) ; ) // Out Parameter Vector plhs [0] = mxCreateDoubleMatrix (1, 2, mxREAL) ; double *pdParOut = mxGetPr (plhs [0]) ; pdParOut [0] = nCode ; pdParOut [1] = nIterCount ; return ; } void ML_qn (int nlhs, mxArray* plhs[], int nrhs, mxArray *prhs[]) { if (nlhs != 1) meal_error ("1 output argument expected") ; if (nrhs != 2) meal_error ("2 input arguments expected") ; // Get data const int n = mxGetM (prhs[0]) * mxGetN (prhs[0]) ; double *pdX = mxGetPr (prhs[0]) ; // Get Corrfact if (mxGetM (prhs[1]) != 1 || mxGetN (prhs[1]) != 1) meal_error ("Parameter 2 is supposed to be a scalar.") ; const double dCorrFact = *mxGetPr (prhs[1]) ; // GetQn (output) plhs[0] = mxCreateDoubleMatrix (1, 1, mxREAL) ; double &dQn = *mxGetPr (plhs [0]) ; TRY( qn_nc (dQn, pdX, n) ; dQn *= qn_corrN (n, dCorrFact) ; ) } void ML_PCAgrid (int nlhs, mxArray* plhs[], int nrhs, mxArray *prhs[]) { if (nlhs != 3) meal_error ("3 output argument expected") ; if (nrhs != 4) meal_error ("4 input arguments expected") ; // Get pnParIn if (mxGetM (prhs[0]) * mxGetN (prhs[0]) != 7) meal_error ("pnParamIn: vector of length 7 expected.") ; double *pdnParamIn = mxGetPr (prhs[0]) ; int pnParamIn[9] ; Double2Int (pnParamIn + 2, pdnParamIn, 7) ; int nk = pnParamIn[2] ; // Get pdParIn if (mxGetM (prhs[1]) * mxGetN (prhs[1]) != 1) meal_error ("pdParIn: vector of length 1 expected.") ; double *pdParamIn = mxGetPr (prhs[1]) ; // Get pdData int &n = pnParamIn[0], &p = pnParamIn[1] ; n = mxGetM (prhs[2]) ; p = mxGetN (prhs[2]) ; double *pdData = mxGetPr (prhs[2]) ; // Get pdLoadings if (mxGetM (prhs[3]) != (t_size) p || mxGetN (prhs[3]) != (t_size) p) meal_error ("pdLoadings: matrix of dimension pxp expected.") ; double *pdLoadings = mxGetPr (prhs[3]) ; // Get pnParOut (output) plhs[0] = mxCreateDoubleMatrix (1, 1, mxREAL) ; double *pdnParamOut = mxGetPr (plhs[0]) ; int pnParamOut [1] ; // Get pdSdev (output) plhs[1] = mxCreateDoubleMatrix (1, nk, mxREAL) ; double *pdSDev = mxGetPr (plhs[1]) ; // Get pdObj (output) plhs[2] = mxCreateDoubleMatrix (1, nk, mxREAL) ; double *pdObj = mxGetPr (plhs[2]) ; TRY( CPCAGrid (pnParamIn, pnParamOut, pdParamIn, pdData, pdLoadings, pdSDev, pdObj/*, pdMaxMaha*/).Calc () ; ) Int2Double (pdnParamOut, pnParamOut, 1) ; } void ML_sPCAgrid (int nlhs, mxArray* plhs[], int nrhs, mxArray *prhs[]) { if (nlhs != 3) meal_error ("expected 3 output argument") ; if (nrhs != 6) meal_error ("expected 6 input arguments") ; // Get pnParIn if (mxGetM (prhs[0]) * mxGetN (prhs[0]) != 10) meal_error ("pnParamIn: expected vector of length 10.") ; double *pdnParamIn = mxGetPr (prhs[0]) ; int pnParamIn[12] ; Double2Int (pnParamIn + 2, pdnParamIn, 10) ; int nk = pnParamIn[2] ; int nPhd = pnParamIn[10] ; // Get pdParIn if (mxGetM (prhs[1]) * mxGetN (prhs[1]) != 1) meal_error ("pdParIn: expected vector of length 1.") ; double *pdParamIn = mxGetPr (prhs[1]) ; // Get pdData int &n = pnParamIn[0], &p = pnParamIn[1] ; n = mxGetM (prhs[2]) ; p = mxGetN (prhs[2]) ; double *pdData = mxGetPr (prhs[2]) ; // Get pdLoadings if (mxGetM (prhs[3]) != (t_size) p || mxGetN (prhs[3]) != (t_size) p) meal_error ("pdLoadings: expected matrix of dimension pxp.") ; double *pdLoadings = mxGetPr (prhs[3]) ; // Get pdLambda if (mxGetM (prhs[4]) * mxGetN (prhs[4]) != (t_size) nk) meal_error ("pdLambda: expected vector of length k.") ; double *pdLambda = mxGetPr (prhs[4]) ; // Get pdBackTransHD double *pdBackTransHD = NULL ; if( mxGetM (prhs[5]) * mxGetN (prhs[5])) // only if this matrix holds any values.. { if (mxGetM (prhs[5]) != (t_size) nPhd || mxGetN (prhs[5]) != (t_size) p) meal_error ("pdBackTransHD: expected matrix of dimension k.") ; pdBackTransHD = mxGetPr (prhs[5]) ; } // Get pnParOut (output) plhs[0] = mxCreateDoubleMatrix (1, 1, mxREAL) ; double *pdnParamOut = mxGetPr (plhs[0]) ; int pnParamOut [1] ; // Get pdSdev (output) plhs[1] = mxCreateDoubleMatrix (1, nk, mxREAL) ; double *pdSDev = mxGetPr (plhs[1]) ; // Get pdObj (output) plhs[2] = mxCreateDoubleMatrix (1, nk, mxREAL) ; double *pdObj = mxGetPr (plhs[2]) ; TRY( CsPCAGrid (pnParamIn, pnParamOut, pdParamIn, pdData, pdLoadings, pdSDev, pdObj/*, pdMaxMaha*/, pdLambda, pdBackTransHD).Calc () ; ) Int2Double (pdnParamOut, pnParamOut, 1) ; } void ML_PCAproj (int nlhs, mxArray* plhs[], int nrhs, mxArray *prhs[]) { if (nlhs != 3) meal_error ("3 output argument expected") ; if (nrhs != 3) meal_error ("3 input arguments expected") ; // Get pnParIn if (mxGetM (prhs[0]) * mxGetN (prhs[0]) != 4) meal_error ("pnParamIn: vector of length 4 expected.") ; double *pdnParamIn = mxGetPr (prhs[0]) ; int pnParamIn[6] ; Double2Int (pnParamIn + 2, pdnParamIn, 4) ; int nk = pnParamIn[3] ; // Get pdParIn if (mxGetM (prhs[1]) * mxGetN (prhs[1]) != 1) meal_error ("pdParIn: vector of length 1 expected.") ; double *pdParamIn = mxGetPr (prhs[1]) ; // Get pdX int &n = pnParamIn[0], &p = pnParamIn[1] ; n = mxGetM (prhs[2]) ; p = mxGetN (prhs[2]) ; double *pdX = mxGetPr (prhs[2]) ; // Get pdZ (Scores) plhs[0] = mxCreateDoubleMatrix (n, nk, mxREAL) ; double *pdZ = mxGetPr (plhs[0]) ; // Get pdL (Loadings) plhs[1] = mxCreateDoubleMatrix (p, nk, mxREAL) ; double *pdL = mxGetPr (plhs[1]) ; // Get pdSdev (output) plhs[2] = mxCreateDoubleMatrix (1, nk, mxREAL) ; double *pdSDev = mxGetPr (plhs[2]) ; TRY( CPCAproj (pnParamIn, pdParamIn, pdX, pdZ, pdL, pdSDev).Calc () ; ) } void ML_PCAprojU (int nlhs, mxArray* plhs[], int nrhs, mxArray *prhs[]) { if (nlhs != 3) meal_error ("3 output argument expected") ; if (nrhs != 3) meal_error ("3 input arguments expected") ; // Get pnParIn if (mxGetM (prhs[0]) * mxGetN (prhs[0]) != 6) meal_error ("pnParamIn: vector of length 4 expected.") ; double *pdnParamIn = mxGetPr (prhs[0]) ; int pnParamIn[8] ; Double2Int (pnParamIn + 2, pdnParamIn, 6) ; int nk = pnParamIn[3] ; // Get pdParIn if (mxGetM (prhs[1]) * mxGetN (prhs[1]) != 1) meal_error ("pdParIn: vector of length 1 expected.") ; double *pdParamIn = mxGetPr (prhs[1]) ; // Get pdX int &n = pnParamIn[0], &p = pnParamIn[1] ; n = mxGetM (prhs[2]) ; p = mxGetN (prhs[2]) ; double *pdX = mxGetPr (prhs[2]) ; // Get pdZ (Scores) plhs[0] = mxCreateDoubleMatrix (n, nk, mxREAL) ; double *pdZ = mxGetPr (plhs[0]) ; // Get pdL (Loadings) plhs[1] = mxCreateDoubleMatrix (p, nk, mxREAL) ; double *pdL = mxGetPr (plhs[1]) ; // Get pdSdev (output) plhs[2] = mxCreateDoubleMatrix (1, nk, mxREAL) ; double *pdSDev = mxGetPr (plhs[2]) ; TRY( CPCAprojU (pnParamIn, pdParamIn, pdX, pdZ, pdL, pdSDev).Calc () ; ) } #endif // #ifdef MATLAB_MEX_FILE pcaPP/src/qnn.cpp0000644000176200001440000001667313300577052013363 0ustar liggesusers#include "qnn.h" double pull (double const * const pA, const int n, int k) { ASSERT_TEMPRANGE (0, 0) ; double * pB = tempRef (0, pB, n) ; Copy (pB, pA, n) ; double ax, buffer ; int l = 0, lr = n - 1, jnc, j ; while (l < lr) // 20 // 2do: put into pull fct { ax = pB[k] ; jnc = l ; j = lr ; while (jnc <= j) // 30 { while (pB[jnc] < ax) // 40 ++jnc ; while (pB[j] > ax) // 50 --j ; if(jnc <= j) // 60 { sm_swap (pB [jnc], pB[j], buffer) ; ++jnc ; --j ; } } // 70 if (j < k) l = jnc ; if (k < jnc) lr = j ; } return pB [k] ; } double whimed (double * const pA, int * const pIw, int n) { ASSERT_TEMPRANGE (1, 2) ; int i ; //= (n + 1) >> 1 ; double * pAcand = tempRef (2, pAcand, n) ; int * pIWcand = tempRef (1, pIWcand, n) ; int64_t nWtotal ; sum (pIw, n, nWtotal) ; if (!nWtotal) return meal_NaN () ; int64_t nTemp, nWrest = 0,nWleft= 0, nWmid = 0,nWright = 0 ; int nKcand, nn = n ; while (1) { double dTrial = pull(pA, nn, (nn >> 1)) ; nWleft = nWright = nWmid = 0 ; for (i = 0; i < nn; ++i) { if (pA[i] < dTrial) nWleft += pIw [i] ; else if (pA [i] > dTrial) nWright += pIw [i] ; else nWmid += pIw [i] ; } nTemp = nWrest + nWleft ; if ((nTemp << 1)> nWtotal) { nKcand = 0 ; for (i = 0; i < nn; ++i) { if (pA [i] < dTrial) { pAcand [nKcand] = pA [i] ; pIWcand [nKcand] = pIw [i] ; ++nKcand ; } } nn = nKcand ; } else if (((nTemp + nWmid) << 1) > nWtotal) return dTrial ; else { nKcand = 0 ; for (i = 0; i < nn; ++i) { if(pA [i] > dTrial) { pAcand [nKcand] = pA [i] ; pIWcand [nKcand] = pIw [i] ; ++nKcand ; } } nn = nKcand ; nWrest += nWleft + nWmid ; } Copy (pA, pAcand, nn) ; Copy (pIw, pIWcand, nn) ; } } #ifdef _MSC_VER #define NO_INLINE // MS compilers don't make problems here when using the helper functions.. #else #define NO_INLINE __attribute__ ((noinline)) // other compilers (e.g. MinGW) are not supposed to inline these functions... #endif // workaround of some compiler optimization - issue: // when computing a-b < x, whereas a-b == x the resulting value was // sometimes "true" on windows machines (using MS VS6.0 and Mingw, various versions) // in some very rare occasions this caused the qn algo to end in an infinite loop. BOOL NO_INLINE isgr_s (const double &a, const double &b) // { // the same code worked without problems on linux. return a > b ; // an assumption is, that some compilers "optimize" the expression } // // "a-b < x" BOOL NO_INLINE isle_s (const double &a, const double &b) // to { // "a - b - x < 0" or "a - x - b < 0" (or sth similar) return a < b ; // } // which then gives numerical problems. // // QUICKFIX: // Thus by using functions "isgr_s" and "isle_s" which are not allowed to be // inlined, this optimization is avoided and the algorithm runs smoothly. \o/ // // SOLUTION: // Directly turning off the corresponding optimization for these lines. // ("#pragma optimize ("", off")" didn't help so far) double qn_raw (double *pY, const int n) { TEMP_GUARD ; ASSERT_TEMPRANGE (3, 8) ; const int ns1 = n - 1 ; double * const pWork = tempArray (8, n) ; int * const pLeft = tempArray (7, n), * const pRight = tempArray (6, n), * const pWeight = tempArray (5, n), * const pQ = tempArray (4, n), * const pP = tempArray (3, n) ; tempArray (0, n) ; tempArray (1, n) ; tempArray (2, n) ; int i ; double dTrial ; const int64_t h = n/2+1 ; int64_t k = h * (h-1) >> 1 , jhelp = (n*((int64_t)n+1)) >> 1, knew = k + jhelp, nL = jhelp, nR = ((int64_t) n) * n, dwSumQ, dwSumP, j ; meal_sort (pY, n) ; for (i = n - 1; i != -1; --i) { pLeft[i] = n - i ; pRight [i] = n ; } while (nR - nL > n) //F 200 continue { j = 0 ; for (i = 1; i < n; ++i) { if (pLeft[i] < pRight [i]) { pWeight [j] = pRight[i] - pLeft[i] ; //F weight(j)=right(i)-left(i)+1 jhelp = pLeft[i] + (pWeight[j] >> 1) ; //F jhelp=left(i)+weight(j)/2 pWork[j] = pY[i] - pY[n - jhelp - 1] ; //F work(j)=y(i)-y(n+1-jhelp) ++j ; } } dTrial = whimed (pWork, pWeight, int (j)) ; //F trial=whimed(work,weight,j-1) dwSumP = dwSumQ = j = 0 ; //F j = n + 1 for (i = n - 1; i != -1; --i) { while (j < n && isle_s ((pY[i] - pY[ns1 - j]), dTrial)) //F if ((j.lt.n).and.((y(i)-y(n-j)).lt.trial)) then ++j ; // while (j < n && (pY[i] - pY[ns1 - j]) < dTrial) //F if ((j.lt.n).and.((y(i)-y(n-j)).lt.trial)) then // ++j ; pP[i] = int (j) ; dwSumP += int (j) ; //F sumP+P(i) } j = n ; for (i = 0; i < n; i++) { while (isgr_s(pY[i] - pY[n - j], dTrial)) //F if ((y(i)-y(n-j+2)).gt.trial) then --j ; // while (pY[i] - pY[n - j] > dTrial) //F if ((y(i)-y(n-j+2)).gt.trial) then // --j ; pQ[i] = int (j) ; dwSumQ += int (j) ; } if (knew <= dwSumP) { Copy (pRight, pP, n) ; nR = dwSumP ; } else if (knew > dwSumQ) { Copy (pLeft, pQ, n) ; nL = dwSumQ ; } else return dTrial ; } int jj ; j = 0 ; //j=1 for (i = 1; i < n; ++i) //F do 90 i=2,n { if (pLeft[i] < pRight[i]) //F if (left(i).le.right(i)) then { for (jj = pLeft[i]; jj < pRight[i]; ++jj) //F do 100 jj=left(i),right(i) { pWork[j] = pY[i] - pY[ns1-jj] ; //F work(j)=y(i)-y(n-jj+1) ++j ; } } //F 100 } //F 90 return pull (pWork, int (j), int (knew-nL - 1)) ; //F Qn=pull(work,j-1,knew-nL) } double qn_corrN (const int n, const double dQnCNorm) { if (n <= 9) { static const double adCorrFact [] = {0.400, 0.993, 0.514, 0.845, 0.612, 0.859, 0.670, 0.874} ; return dQnCNorm * adCorrFact[n - 2] ; } if (n & 1) return dQnCNorm * n / (n + 1.4) ; // odd return dQnCNorm * n / (n + 3.8) ; // even } void qn_nc (double &dQn, const double *pX, const int n) { TEMP_GUARD ; ASSERT_TEMPRANGE (9, 9) ; double * const pY = tempArray (9, n) ; Copy (pY, pX, n) ; dQn = qn_raw (pY, n) ; } void qn_V (double &dQn, double *pX, const int n) { dQn = qn_raw (pX, n) ; dQn *= qn_corrN (n) ; } void qn (double &dQn, const double *pX, const int n) { qn_nc (dQn, pX, n) ; dQn *= qn_corrN (n) ; } /* double qn (const double *pX, t_size n) { double dQn ; qn (dQn, pX, n) ; return dQn ; } EXPORT void ex_pull (int *pnParIn, double *pnParOut, double const * const pA) { pnParOut[0] = pull (pA, pnParIn[0], pnParIn[1]) ; } EXPORT void ex_whimed (int *pnParIn, double *pnParOut, double * const pA, int * const pIw) { pnParOut[0] = whimed (pA, pIw, pnParIn[0]) ; } */ /* void qn (const double *x, int *npLength, double *pdQn) // used by sPCApp: 2do: change scale function definition ... { qn (*pdQn, x, *npLength) ; } */ double qn (const SVDataD &a) { double dRet ; qn (dRet, a.GetData (), a.size ()) ; return dRet ; } double qn (const SCDataD &a) { double dRet; qn (dRet, a.GetData (), a.size ()) ; return dRet ; } pcaPP/src/hess.cpp0000644000176200001440000000332713300577052013521 0ustar liggesusers#include "R_package.h" #include "math.h" void Hess_Sub (int p, double *pdX_i, double *pdMu, double *pdHess, double *pdTempP) { int l, k ; double dNorm = 0 ; for (l = p - 1; l != -1; l--) { double &dCur = pdTempP [l] = pdX_i[l] - pdMu[l] ; dNorm += dCur * dCur ; } dNorm = 1 / sqrt (dNorm) ; double dNorm3 = pow (dNorm, 3.0) ; for (l = p - 1; l != -1; l--) { pdHess [l * p + l] += dNorm ; //for (k = p - 1; k != -1; k--) for (k = l; k != -1; k--) pdHess [l * p + k] -= pdTempP [l] * pdTempP[k] * dNorm3 ; } } void Hess (int p, int n, double *pdX, double *pdMu, double *pdHess, double *pdTempP1, double *pdTempP2) { int i, j ; for (i = p - 1; i != -1; i--) for (j = p - 1; j != -1; j--) pdHess [i + j * p] = 0 ; for (i = n - 1; i != -1; i--) { for (j = p - 1; j != -1; j--) pdTempP2 [j] = pdX[i + j * n] ; Hess_Sub (p, pdTempP2, pdMu, pdHess, pdTempP1) ; } for (i = p - 1; i != -1; i--) for (j = i - 1; j != -1; j--) pdHess [i + j * p] = pdHess [i * p + j] ; } void Hess_Sub_R (int *pnPar, double *pdX_i, double *pdMu, double *pdHess) { const int &p = pnPar[0] ; double *pdTempP = new double [p] ; Hess_Sub (pnPar [0], pdX_i, pdMu, pdHess, pdTempP) ; // VT::04.12.2017 // Causes an warning in clang++: "'delete' applied to a pointer that was allocated with 'new[]'; did you mean 'delete[]'? [-Wmismatched-new-delete]" // - replace delete by delete[] // delete pdTempP ; delete[] pdTempP ; } void Hess_R (int *pnPar, double *pdX, double *pdMu, double *pdHess) { double *pdTempP1 = new double [pnPar[0]], *pdTempP2 = new double [pnPar[0]] ; Hess (pnPar[0], pnPar[1], pdX, pdMu, pdHess, pdTempP1, pdTempP2) ; // VT::04.12.2017 // - as above delete[] pdTempP1 ; delete[] pdTempP2 ; } pcaPP/src/smat.h0000644000176200001440000000251313300577052013164 0ustar liggesusers/* SMat - Simple Matrix Classes v0.1beta Copyright (C) 2011 by Heinrich Fritz (heinrich_fritz@hotmail.com) This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . */ #ifndef SMAT_H #define SMAT_H #ifndef SMAT_FLAG_NO_INI //#include "smat.ini.h" // ON ERROR / IF NOT FOUND: create an empty "smat.ini.h" file in your source directory. // smat.ini.h is a user-defined header file for providing smat with additional declarations. #endif // #ifndef SMAT_FLAG_NO_INI #include "smat.def.h" #include "smat.base.h" #include "smat.elop.h" #include "smat.math.h" #include "smat.mem.h" #include "smat.matop.h" #include "smat.misc.h" #include "smat.random.h" #include "smat.sort.h" #include "smat.stat.h" #include "smat.meal.h" #endif // #ifndef SMAT_H pcaPP/src/smat_meal_passrng_hpp.h0000644000176200001440000000277613300577052016601 0ustar liggesusers#ifndef SMAT_MEAL_PASSRNG_HPP #define SMAT_MEAL_PASSRNG_HPP #ifndef SMAT_MEAL_H #error "File 'smat.meal.h' not included. Please include before including 'smat_meal_passrng.hpp'." #endif #ifndef SMAT_MEAL_PASSRNG_H #error "File 'smat_meal_passrng.h' not included. Please include before including 'smat_meal_passrng.hpp'." #endif // when including this files make sure, that "smat_meal_passrng.h" and "smat.meal.h" has been included first! CPassRng::CPassRng () : m_pCurData (NULL) , m_pDataEnd (NULL) { } double CPassRng::Get () { THROW (m_pCurData < m_pDataEnd) ; return *(m_pCurData++) ; } void CPassRng::Set (double *pData, t_size n) { m_data.Require (n) ; m_data.Copy (pData, n) ; m_pCurData = m_data ; m_pDataEnd = m_data.GetDataEnd () ; } CPassRng &GetPassRng_runif () { static CPassRng obj ; return obj ; } CPassRng &GetPassRng_rnorm () { static CPassRng obj ; return obj ; } CPassRng &GetPassRng_rexp () { static CPassRng obj ; return obj ; } void pass_runif (double *pd, int n) { GetPassRng_runif ().Set (pd, n) ; } void pass_rnorm (double *pd, int n) { GetPassRng_rnorm ().Set (pd, n) ; } void pass_rexp (double *pd, int n) { GetPassRng_rexp ().Set (pd, n) ; } void meal_PutRNGstate () {} void meal_GetRNGstate () {} double meal_unif_rand () { return GetPassRng_runif ().Get () ; } double meal_norm_rand () { return GetPassRng_rnorm ().Get () ; } double meal_exp_rand () { return GetPassRng_rexp ().Get () ; } #endif // #ifndef SMAT_MEAL_PASSRNG_HPP pcaPP/src/L1Median.h0000644000176200001440000000270113300577052013611 0ustar liggesusers #ifdef ES_DEV_ENV #include "../../../SMat/smat.h" #else #include "smat.h" #endif int l1median_HoCr (const SCMatD &mX, const SVecD &vdMedian, double dZeroTol, double dTol, int dwMaxit, int nTrace, int *pdwIterCount = NULL) ; class CL1Median_VZ { public: CL1Median_VZ (int *pnParIn, int *pnParOut, double *pdParIn, double *pdDat, double *pdMed, double *pdWeights = NULL) ; CL1Median_VZ (int n, int p, int &nCode, int &nIter, double *pdParIn, double *pdX, double *pdMed, double *pdWeights = NULL) ; BOOL Iter () ; t_size CheckRowSums (const double &dThreshold) ; protected: void Calc (double *pdWeights) ; t_size m_dwN, m_dwP, m_dwMaxIt, m_dwUseWeights ; // t_size input parameters int m_nTrace ; // int input parameters int &m_nRetCode, &m_nIter ; // int output parameters double &m_dTol, &m_dZeroTol ; // double input parameters const t_size m_dwNHalf ; int m_nEqs ; SMatD m_mX, m_mXc ; SVecD m_vMed, m_vRt, m_vTt, m_vOldMed ; SVecD m_vWeights, m_vRowSums, m_vTemp ; SVecN m_mIsZero ; // User Operators public: class AaCmD_BpaAmA { CALC_4_2(void) { a = c - d; b += sm_sqr (a) ; } } ; class if_C_ApaBdD { CALC_4_1(void) { if (c) a += b / d ; } } ; class if_C_Apa_inv_b { CALC_3_1(void) { if (c) a += 1 / b ; } } ; class Apa_abs_c_Bpa_abs_DmC { CALC_4_2(void) { a += fabs (c) ; b += fabs (d - c) ; } }; } ; double calObj (const double *pdData, const double *pdM, int n, int p) ; pcaPP/src/pcaPP_init.c0000644000176200001440000001274313300577052014247 0ustar liggesusers// VT::27.06.2017 - this file was added to fix the warning "Found no calls to: R_registerRoutines, R_useDynamicSymbols" // // About registration of native symbols see for example: https://www.r-bloggers.com/1-easy-package-registration/ // also here http://r.789695.n4.nabble.com/Registration-of-native-routines-td4728874.html // - about Windows - take the 64 bit version of mingw! // #include // for NULL #include #include #include /* EXPORT void C_kendallNlogN (double* arr1, double* arr2, int *pnPar, double *dRet) ; EXPORT void C_l1median_BFGS (int *pnParam_In, int *pnParam_Out, double *pdParam_In, double *pdParam_Out, double *pdData, double *pdMRet) ; EXPORT void C_l1median_CG(int *pnParam, int *pnParam_Out, double *pdParam, double *pdParam_Out, double *pdData, double *pdMRet) ; EXPORT void C_l1median_HoCr (int *pnParIn, int *pnParOut, double *pdParIn, double *pdX, double *pdMed) ; EXPORT void C_l1median_NLM (int *pnParam, double *pdParam, double *pdData, double *pdMRet) ; EXPORT void C_l1median_NLM_Hess (int *pnParam, double *pdParam, double *pdData, double *pdMRet) ; EXPORT void C_l1median_NM(int *pnParam, double *pdParam, double *pdData, double *pdMRet) ; EXPORT void C_l1Median_VZ (int *pnParIn, int *pnParOut, double *pdParIn, double *pdX, double *pdMed) ; EXPORT void C_PCAgrid (int *pnParamIn, int *pnParamOut, double *pdParamIn, double *pdData, double *pdLoadings, double *pdSDev, double *pdObj) ; EXPORT void C_sPCAgrid (int *pnParamIn, int *pnParamOut, double *pdParamIn, double *pdData, double *pdLoadings, double *pdSDev, double *pdObj, double *pdLambda, double *pdBackTransHD) ; EXPORT void C_pcaProj (int *pnParIn, double *pdParIn, double *pdX, double *pdZ, double *pdL, double *pdSDev) ; EXPORT void C_pcaProj_up (int *pnParIn, double *pdParIn, double *pdX, double *pdZ, double *pdL, double *pdSDev) ; EXPORT void C_qn (int *pnParIn, double *pdParIn, double *pdParOut, double *pdX) ; */ /* .C calls */ extern void C_kendallNlogN(void *, void *, void *, void *); extern void C_l1median_BFGS(void *, void *, void *, void *, void *, void *); extern void C_l1median_CG(void *, void *, void *, void *, void *, void *); extern void C_l1median_HoCr(void *, void *, void *, void *, void *); extern void C_l1median_NLM(void *, void *, void *, void *); extern void C_l1median_NLM_Hess(void *, void *, void *, void *); extern void C_l1median_NM(void *, void *, void *, void *); extern void C_l1Median_VZ(void *, void *, void *, void *, void *); extern void C_PCAgrid(void *, void *, void *, void *, void *, void *, void *); extern void C_pcaProj(void *, void *, void *, void *, void *, void *); extern void C_pcaProj_up(void *, void *, void *, void *, void *, void *); extern void C_qn(void *, void *, void *, void *); extern void C_sPCAgrid(void *, void *, void *, void *, void *, void *, void *, void *, void *); static R_NativePrimitiveArgType C_kendallNlogN_t[] = { REALSXP, REALSXP, INTSXP, REALSXP }; static R_NativePrimitiveArgType C_l1median_BFGS_t[] = { INTSXP, INTSXP, REALSXP, REALSXP, REALSXP, REALSXP }; static R_NativePrimitiveArgType C_l1median_CG_t[] = { INTSXP, INTSXP, REALSXP, REALSXP, REALSXP, REALSXP }; static R_NativePrimitiveArgType C_l1median_HoCr_t[] = { INTSXP, INTSXP, REALSXP, REALSXP, REALSXP }; static R_NativePrimitiveArgType C_l1median_NLM_t[] = { INTSXP, REALSXP, REALSXP, REALSXP }; static R_NativePrimitiveArgType C_l1median_NLM_Hess_t[] = { INTSXP, REALSXP, REALSXP, REALSXP }; static R_NativePrimitiveArgType C_l1median_NM_t[] = { INTSXP, REALSXP, REALSXP, REALSXP }; static R_NativePrimitiveArgType C_l1median_VZ_t[] = { INTSXP, INTSXP, REALSXP, REALSXP, REALSXP }; static R_NativePrimitiveArgType C_PCAgrid_t[] = { INTSXP, INTSXP, REALSXP, REALSXP, REALSXP, REALSXP, REALSXP }; static R_NativePrimitiveArgType C_sPCAgrid_t[] = { INTSXP, INTSXP, REALSXP, REALSXP, REALSXP, REALSXP, REALSXP, REALSXP, REALSXP }; static R_NativePrimitiveArgType C_pcaProj_t[] = { INTSXP, REALSXP, REALSXP, REALSXP, REALSXP, REALSXP }; static R_NativePrimitiveArgType C_pcaProj_up_t[] = { INTSXP, REALSXP, REALSXP, REALSXP, REALSXP, REALSXP }; static R_NativePrimitiveArgType C_qn_t[] = { INTSXP, REALSXP, REALSXP, REALSXP }; static const R_CMethodDef CEntries[] = { {"C_kendallNlogN", (DL_FUNC) &C_kendallNlogN, 4, C_kendallNlogN_t}, {"C_l1median_BFGS", (DL_FUNC) &C_l1median_BFGS, 6, C_l1median_BFGS_t}, {"C_l1median_CG", (DL_FUNC) &C_l1median_CG, 6, C_l1median_CG_t}, {"C_l1median_HoCr", (DL_FUNC) &C_l1median_HoCr, 5, C_l1median_HoCr_t}, {"C_l1median_NLM", (DL_FUNC) &C_l1median_NLM, 4, C_l1median_NLM_t}, {"C_l1median_NLM_Hess", (DL_FUNC) &C_l1median_NLM_Hess, 4, C_l1median_NLM_Hess_t}, {"C_l1median_NM", (DL_FUNC) &C_l1median_NM, 4, C_l1median_NM_t}, {"C_l1Median_VZ", (DL_FUNC) &C_l1Median_VZ, 5, C_l1median_VZ_t}, {"C_PCAgrid", (DL_FUNC) &C_PCAgrid, 7, C_PCAgrid_t}, {"C_pcaProj", (DL_FUNC) &C_pcaProj, 6, C_pcaProj_t}, {"C_pcaProj_up", (DL_FUNC) &C_pcaProj_up, 6, C_pcaProj_up_t}, {"C_qn", (DL_FUNC) &C_qn, 4, C_qn_t}, {"C_sPCAgrid", (DL_FUNC) &C_sPCAgrid, 9, C_sPCAgrid_t}, {NULL, NULL, 0} }; void R_init_pcaPP(DllInfo *dll) { R_registerRoutines(dll, CEntries, NULL, NULL, NULL); R_useDynamicSymbols(dll, FALSE); R_forceSymbols(dll, TRUE); } pcaPP/src/smat.math.h0000644000176200001440000000320013300577052014106 0ustar liggesusers/* SMat - Simple Matrix Classes v0.1beta Copyright (C) 2011 by Heinrich Fritz (heinrich_fritz@hotmail.com) This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . */ void sme_eigen_sqr_R (const SCMatD &A, SVecD &vVal, SVMatD &mVec, BOOL bOrder) ; // temp4 void sme_eigen_sqr (const SCMatD &A, const SVecD &vVal, const SVMatD &mVec, BOOL bOrder) ; // temp4 void sme_eigen_sqr_NC (const SCMatD &A, const SVecD &vVal, const SVMatD &mVec, BOOL bOrder) ; // temp4 void sme_eigen_sqr_RV (const SVMatD &A, SVecD &vVal, SVMatD &mVec, BOOL bOrder) ; // temp3 void sme_eigen_sqr_V (const SVMatD &A, const SVecD &vVal, const SVMatD &mVec, BOOL bOrder) ; // temp3 void sme_eigen_sqr_NCV (const SVMatD &A, const SVecD &vVal, const SVMatD &mVec, BOOL bOrder) ; // temp3 void sme_eigen_sym_2x2_norm_raw (double * const pdEval, double *const pdEVec, const double *const pd, const double &dZeroTol) ; void sme_eigen_sym_2x2_norm_raw_NC (double * const pdEval, double *const pdEVec, const double *const pd, const double &dZeroTol) ; //2do: implement solver pcaPP/src/smat.elop.h0000644000176200001440000010702213300577052014123 0ustar liggesusers/* SMat - Simple Matrix Classes v0.1beta Copyright (C) 2011 by Heinrich Fritz (heinrich_fritz@hotmail.com) This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . */ #ifndef SMAT_ELOP_H #define SMAT_ELOP_H #include "smat.base.h" #include // move to smat.def.h #include "smat.meal.h" // ?? move to smat.def.h ?? #define CALC_1_0(TYPE) public: template inline static TYPE Calc (const TA &a) #define CALC_1_1(TYPE) public: template inline static TYPE Calc ( TA &a) #define CALC_2_0(TYPE) public: template inline static TYPE Calc (const TA &a, const TB &b) #define CALC_2_1(TYPE) public: template inline static TYPE Calc ( TA &a, const TB &b) #define CALC_2_2(TYPE) public: template inline static TYPE Calc ( TA &a, TB &b) #define CALC_3_0(TYPE) public: template inline static TYPE Calc (const TA &a, const TB &b, const TC &c) #define CALC_3_1(TYPE) public: template inline static TYPE Calc ( TA &a, const TB &b, const TC &c) #define CALC_3_2(TYPE) public: template inline static TYPE Calc ( TA &a, TB &b, const TC &c) #define CALC_3_3(TYPE) public: template inline static TYPE Calc ( TA &a, TB &b, TC &c) #define CALC_4_0(TYPE) public: template inline static TYPE Calc (const TA &a, const TB &b, const TC &c, const TD &d) #define CALC_4_1(TYPE) public: template inline static TYPE Calc ( TA &a, const TB &b, const TC &c, const TD &d) #define CALC_4_2(TYPE) public: template inline static TYPE Calc ( TA &a, TB &b, const TC &c, const TD &d) #define CALC_4_3(TYPE) public: template inline static TYPE Calc ( TA &a, TB &b, TC &c, const TD &d) #define CALC_4_4(TYPE) public: template inline static TYPE Calc ( TA &a, TB &b, TC &c, TD &d) #define CALC_5_1(TYPE) public: template inline static TYPE Calc ( TA &a, const TB &b, const TC &c, const TD &d, const TE &e) // some functions: Renamed 4 Clang (clang complains when calling ::exp from a method of a class named "exp" ) static inline double r4c_exp (double a0) { return ::exp (a0) ; } static inline double r4c_log (double a0) { return ::log (a0) ; } static inline double r4c_pow (double a0, double a1) { return ::pow (a0, a1) ; } class SOP // standard operators { // 2do: renamo to OP public: class assign { CALC_2_1(void) { a = (TA) b ; } } ; class add { CALC_3_1(void) { a = (TA) (b + c) ; } } ; class subtract { CALC_3_1(void) { a = (TA) (b - c) ; } } ; typedef subtract sub ; class divide { CALC_3_1(void) { a = (TA) (b / c) ; } } ; class divide_r { CALC_3_1(void) { a = (TA) (c / b) ; } } ; class multiply { CALC_3_1(void) { a = (TA) (b * c) ; } } ; class pow { CALC_3_1(void) { a = (TA) ::r4c_pow(b, c) ; } } ; class pow_r { CALC_3_1(void) { a = (TA) ::r4c_pow(c, b) ; } } ; class mod { CALC_3_1(void) { a = (TA) (b % c) ; } } ; class neg { CALC_2_1(void) { a = -b ; } } ; class inv { CALC_2_1(void) { a = (TA) (1 / b) ; } } ; class exp { CALC_2_1(void) { a = (TA) ::r4c_exp ((double) b) ; } } ; class log { CALC_2_1(void) { a = (TA) ::r4c_log ((double) b) ; } } ; class pow2 { CALC_2_1(void) { a = (TA) (b * b) ; } } ; class sign { CALC_2_1(void) { a = (b > 0) ? (TA) 1 : (b < 0) ? (TA) -1: (TA) 0 ; } } ; class abs { CALC_2_1(void) { a = (b < 0) ? (TA) -b : (TA) b ; } } ; /* class or { CALC_3_1(void) { c = (TC) (a | b) ; } } ; class and { CALC_3_1(void) { c = (TC) (a & b) ; } } ; class OR { CALC_3_1(void) { c = (TC) (a || b) ; } } ; class AND { CALC_3_1(void) { c = (TC) (a && b) ; } } ; class xor { CALC_3_1(void) { c = (TC) (a ^ b) ; } } ; class NOT { CALC_2_1(void) { b = !a ; } } ; class not { CALC_2_1(void) { b = ~a ; } } ; */ class gr { CALC_3_1(void) { a = (TA) (b > c) ; } } ; class greq { CALC_3_1(void) { a = (TA) (b >= c) ; } } ; class eq { CALC_3_1(void) { a = (TA) (b == c) ; } } ; class le { CALC_3_1(void) { a = (TA) (b < c) ; } } ; class leeq { CALC_3_1(void) { a = (TA) (b <= c) ; } } ; // 2 arguments class a_plus { CALC_2_1(void) { a += (TA) b ; } } ; class a_minus { CALC_2_1(void) { a -= (TA) b ; } } ; class a_multiply { CALC_2_1(void) { a *= (TA) b ; } } ; class a_divide { CALC_2_1(void) { a /= (TA) b ; } } ; class a_divide_r { CALC_2_1(void) { a = ((TA) b / a) ; } } ; class a_mod { CALC_2_1(void) { a %= (TA) b ; } } ; class a_or { CALC_2_1(void) { a |= (TA) b ; } } ; class a_and { CALC_2_1(void) { a &= (TA) b ; } } ; class a_xor { CALC_2_1(void) { a ^= (TA) b ; } } ; class a_OR { CALC_2_1(void) { a = a || (TA) b ; } } ; class a_AND { CALC_2_1(void) { a = a &&(TA) b ; } } ; // 1 argument class a_neg { CALC_1_1(void) { a = -a ; } } ; class a_exp { CALC_1_1(void) { a = (TA) ::r4c_exp ((double) a) ; } } ; class a_log { CALC_1_1(void) { a = (TA) ::r4c_log ((double) a) ; } } ; class a_sqrt { CALC_1_1(void) { a = (TA) ::sqrt ((double) a) ; } } ; class a_pow2 { CALC_1_1(void) { a = sm_sqr(a) ; } } ; class a_pow3 { CALC_1_1(void) { a = sm_sqr(a) * a ; } } ; class a_pow4 { CALC_1_1(void) { a = sm_sqr (sm_sqr (a)) ; } } ; class a_abs { CALC_1_1(void) { if (a < 0) a = -a ; } } ; class a_pow { CALC_2_1(void) { a = ::r4c_pow ((double) a, (double)b) ; } } ; class a_not { CALC_1_1(void) { a = ~a ; } } ; class a_NOT { CALC_1_1(void) { a = !a ; } } ; class a_inv { CALC_1_1(void) { a = 1 / a ; } } ; class a_limit { CALC_3_1(void) { ASSERT (b <= c) ; if (a < b) a = b ; else if (a > c) a = c ; } } ; class a_limit_l { CALC_2_1(void) { if (a < b) a = b ; } } ; class a_limit_u { CALC_2_1(void) { if (a < b) a = b ; } } ; class a_minmax { CALC_3_2(void) { ASSERT (a <= b) ; if (a > c) a = c ; else if (b < c) b = c ; } } ; class is_greater { CALC_2_0(BOOL) { return a > b ; } } ; class is_greatereq { CALC_2_0(BOOL) { return a >= b ; } } ; class is_less { CALC_2_0(BOOL) { return a < b ; } } ; class is_lesseq { CALC_2_0(BOOL) { return a <= b ; } } ; // class 2 operators class ApaBmC { CALC_3_1(void) { a += (TA) (b * c) ; } } ; class ApaBdC { CALC_3_1(void) { a += (TA) (b / c) ; } } ; class ApaCdB { CALC_3_1(void) { a += (TA) (c / b) ; } } ; class Apa1dB { CALC_2_1(void) { a += (TA) (1 / b) ; } } ; class AsaBmC { CALC_3_1(void) { a -= (TA) (b * c) ; } } ; class Aa_abs_AsB { CALC_2_1(void) { a = fabs (a - b) ; } } ; class Apa_sqr_B { CALC_2_1(void) { a += sm_sqr (b) ; } } ; class Apa_sqr_BsC { CALC_3_1(void) { a += sm_sqr (b-c) ; } } ; class Apa_sqrt_B { CALC_2_1(void) { a += ::sqrt (b) ; } } ; class Apa_sqr_CdB { CALC_3_1(void) { a += (TA) sm_sqr (c / b) ; } } ; class BdaC_Apa_sqr_B{ CALC_3_2(void) { b /= c ; a += (TA) sm_sqr (b) ; } } ; class Apa_sq_BsC { CALC_3_1(void) { a += sm_sqr (b - c) ; } } ; // calculation of var class ApaC_Bpa_sq_C { CALC_3_2(void) { a += c; b += sm_sqr (c) ; } } ; // calculation of var using steiner // class ApaBmB { CALC_2_1(void) { a += sm_sqr (b) ; } } ; // class ApaBmB_BmaC { CALC_3_2(void) { a += sm_sqr (b) ; b *= c ; } } ; // class ApaBmBpCmC_BmaC { CALC_3_2(void) { a += sm_sqr (b) + sm_sqr (c) ; b *= c ; } } ; class ApaBmB { CALC_2_1(void) { a += ::r4c_pow (b, 2.0) ; } } ; class ApaBmB_BmaC { CALC_3_2(void) { a += ::r4c_pow (b, 2.0) ; b *= c ; } } ; class ApaBmBpCmC_BmaC { CALC_3_2(void) { a += ::r4c_pow (b, 2.0) + ::r4c_pow (c, 2.0) ; b *= c ; } } ; class AmaB_BmaC { CALC_3_2(void) { a *= b ; b *= c; } } ; class AmaBmD_BmaC { CALC_4_2(void ) { a *= b * d ; b *= c; } } ; class ApaBmB_BpaCmD { CALC_4_2(void ) { a += sm_sqr (b); b += c * d ; } } ; class inc_a_if_b { CALC_2_1(void) { if (b) a += 1 ; } } ; class inc_a_if_b_equals_c { CALC_3_1(void) { if (b == (TB) c) a += 1 ; } } ; class inc_a_if_b_less_c { CALC_3_1(void) { if (b < (TB) c) a += 1 ; } } ; class inc_a_if_b_lesseq_c { CALC_3_1(void) { if (b <= (TB) c) a += 1 ; } } ; class inc_a_if_b_greater_c { CALC_3_1(void) { if (b > (TB) c) a += 1 ; } } ; class inc_a_if_b_greatereq_c { CALC_3_1(void) { if (b >= (TB) c) a += 1 ; } } ; class a_max_idx { CALC_2_1(void) { if (a < (t_size) b) a = (t_size) b ; } } ; } ; template class EO { public: template static void MMcVc_R (const SVMat &a, const SCMat &b, const SCData &c) { THROW (a.nrow () == c.size ()) ; a.Require (b) ; MMcVc_NC (a, b, c) ; } template static void MMcVc (const SVMat &a, const SCMat &b, const SCData &c) { THROW (a.EqualDims (b)) ; THROW (a.nrow () == c.size ()) ; MMcVc_NC (a, b, c) ; } template static void MMcVc_NC (const SVMat &a, const SCMat &b, const SCData &c) { ASSERT (a.EqualDims (b)) ; ASSERT (a.nrow () == c.size ()) ; TA * pA = a ; TA * const pEndA = a.GetDataEnd () ; TB const * pB = b ; TC const * pC ; TC const * const pEndC = c.GetDataEnd () ; while (pA < pEndA) { pC = c ; while (pC < pEndC) { F::Calc (*pA, *pB, *pC) ; ++pA ; ++pB ; ++pC ; } } } template static void MMcVct_R (const SVMat &a, const SCMat &b, const SCData &c) { THROW (a.ncol () == c.size ()) ; a.Require (b) ; MMcVct_NC (a, b, c) ; } template static void MMcVct (const SVMat &a, const SCMat &b, const SCData &c) { THROW (a.EqualDims (b)) ; THROW (a.ncol () == c.size ()) ; MMcVct_NC (a, b, c) ; } template static void MMcVct_NC (const SVMat &a, const SCMat &b, const SCData &c) { ASSERT (a.EqualDims (b)) ; ASSERT (a.ncol () == c.size ()) ; TA * pA = a, * pColEndA ; TA * const pEndA = a.GetDataEnd () ; TB const * pB = b ; TC const * pC = c ; while (pA < pEndA) { pColEndA = pA + a.GetColInc () ; while (pA < pColEndA) { F::Calc (*pA, *pB, *pC) ; ++pA ; ++pB ; } ++pC ; } } template static void MVMcVct (const SVMat &a, const SVData &b, const SCMat &c, const SCData &d) { THROW (a.EqualDims (c)) ; THROW (b.size () == c.nrow ()) ; THROW (d.size () == c.ncol ()) ; MVMcVct_NC (a, b, c, d) ; } template static void MVMcVct_NC (const SVMat &a, const SVData &b, const SCMat &c, const SCData &d) { ASSERT (a.EqualDims (c)) ; ASSERT (b.size () == c.nrow ()) ; ASSERT (d.size () == c.ncol ()) ; TA * pA = a, * const pEndA = a.GetDataEnd () ; TB * pB, * const pStartB = b, *const pEndB = b.GetDataEnd () ; const TC * pC = c ; const TD * pD = d ; while (pA < pEndA) { pB = pStartB ; while (pB < pEndB) { F::Calc (*pA, *pB, *pC, *pD) ; ++pA ; ++pB ; ++pC ; } ++pD ; } } template static void MVcVct_R (const SVMat &a, const SCData &b, const SCData &c) { a.Require (b.size (), c.size ()) ; MVcVct_NC (a, b, c) ; } template static void MVcVct (const SVMat &a, const SCData &b, const SCData &c) { THROW (a.nrow () == b.size ()) ; THROW (a.ncol () == c.size ()) ; MVcVct_NC (a, b, c) ; } template static void MVcVct_NC (const SVMat &a, const SCData &b, const SCData &c) { ASSERT (a.nrow () == b.size ()) ; ASSERT (a.ncol () == c.size ()) ; TA * pA = a ; const TA * const pEndA = a.GetDataEnd () ; const TB * pB ; const TB * const pEndB = b.GetDataEnd () ; const TC * pC = c ; while (pA < pEndA) { pB = b ; while (pB < pEndB) { F::Calc (*pA, *pB, *pC) ; ++pA ; ++pB ; } ++pC ; } } template static void MsMcVcVbc_R (const SVMat &a, const SCMat &b, const SCVec &c, const SCVec &d) { THROW (a.ncol () == b.ncol ()) ; THROW (b.nrow () == c.size ()) ; THROW (b.nrow () == d.size ()) ; d.Require (CountTrue (d), b.ncol ()) ; MsMcVcVbc_NC (a, b, c, d) ; } template static void MsMcVcVbc (const SVMat &a, const SCMat &b, const SCVec &c, const SCVec &d) { THROW (a.ncol () == b.ncol ()) ; THROW (b.nrow () == c.size ()) ; THROW (b.nrow () == d.size ()) ; THROW (CountTrue (d) == a.nrow ()) ; MsMcVcVbc_NC (a, b, c, d) ; } template static void MsMcVcVbc_NC (const SVMat &a, const SCMat &b, const SCVec &c, const SCVec &d) { // b for binary index! ASSERT (a.ncol () == b.ncol ()) ; ASSERT (b.nrow () == c.size ()) ; ASSERT (b.nrow () == d.size ()) ; ASSERT (CountTrue (d) == a.nrow ()) ; TA *pA = a ; const TB *pB = b, * const pEndB = b.GetDataEnd () ; const TC * const pStartC = c ; const TD * const pStartD = d, * const pEndD = d.GetDataEnd () ; while (pB < pEndB) { const TD *pD = pStartD ; const TC *pC = pStartC ; while (pD < pEndD) { if (*pD) { F::Calc (*pA, *pB, *pC) ; ++pA ; } ++pB ; ++pC ; ++pD ; } } } template static void MsMcVctVbc_R (const SVMat &a, const SCMat &b, const SCVec &c, const SCVec &d) { THROW (a.ncol () == b.ncol ()) ; THROW (b.ncol () == c.size ()) ; THROW (b.nrow () == d.size ()) ; d.Require (CountTrue (d), b.ncol ()) ; MsMcVctVbc_NC (a, b, c, d) ; } template static void MsMcVctVbc (const SVMat &a, const SCMat &b, const SCVec &c, const SCVec &d) { THROW (a.ncol () == b.ncol ()) ; THROW (b.ncol () == c.size ()) ; THROW (b.nrow () == d.size ()) ; THROW (CountTrue (d) == a.nrow ()) ; MsMcVctVbc_NC (a, b, c, d) ; } template static void MsMcVctVbc_NC (const SVMat &a, const SCMat &b, const SCVec &c, const SCVec &d) { // b for binary index! ASSERT (a.ncol () == b.ncol ()) ; ASSERT (b.ncol () == c.size ()) ; ASSERT (b.nrow () == d.size ()) ; ASSERT (CountTrue (d) == a.nrow ()) ; TA *pA = a ; const TB *pB = b, * const pEndB = b.GetDataEnd () ; const TC *pC = c ; const TD * const pStartD = d, * const pEndD = d.GetDataEnd () ; while (pB < pEndB) { const TD *pD = pStartD ; while (pD < pEndD) { if (*pD) { F::Calc (*pA, *pB, *pC) ; ++pA ; } ++pB ; ++pD ; } ++pC ; } } template static void MsVetMcdScgVceg_R (SVMat &a, const SVData &b, const SCMat &c, const TD &d, const SCData &e) { // g for group. THROW (c.ncol () == b.nsize ()) ; THROW (c.nrow () == e.size ()) ; a.Require (CountMatches (e, d), c.ncol ()) ; MsVetMcdScgVceg_NC (a, b, c, d, e) ; } template static void MsVetMcdScgVceg (const SVMat &a, const SVData &b, const SCMat &c, const TD &d, const SCData &e) { // g for group. THROW (a.ncol () == c.ncol ()) ; THROW (a.ncol () == b.size ()) ; THROW (c.nrow () == e.size ()) ; THROW (CountMatches (e, d) == a.nrow ()) ; MsVetMcdScgVceg_NC (a, b, c, d, e) ; } template static void MsVetMcdScgVceg_NC (const SVMat &a, const SVData &b, const SCMat &c, const TD &d, const SCData &e) { // g for group. ASSERT (a.ncol () == c.ncol ()) ; ASSERT (a.ncol () == b.size ()) ; ASSERT (c.nrow () == e.size ()) ; ASSERT (CountMatches (e, d) == a.nrow ()) ; //t_size dwColIncA = a.GetColInc () ; TA * pA = a ; TA const * const pEndA = a.GetDataEnd () ; TB * pB = b ; TC const * pC = c ; TE const * pE ; TE const * pEndE = e.GetDataEnd () ; for (; pA < pEndA; ) // for each column of A { pE = e ; while (pE < pEndE) { if (d == (TD) *pE) { F::Calc (*pA, *pB, *pC) ; ++pA ; } ++pC ; ++pE ; } ++pB ; } } template static void MsVetMcdVcei_R (const SVMat &a, const SVData &b, const SCMat &c, const SCData &d) { // Main dimension: matrix c // Constant index vector d of size c.nrow () // Matrix a refers to the columns and subsetted rows of matrix c // Vector d is of size c.ncol () // F.Calc is executed for each element of c[,d] THROW (b.size () == c.ncol ()) ; THROW (getMaxIdx (d) < c.nrow ()) ; a.Require (d.size (), c.ncol ()) ; MsVetMcdVcei_NC (a, b, c, d) ; } template static void MsVetMcdVcei (const SVMat &a, const SVData &b, const SCMat &c, const SCData &d) { // Main dimension: matrix c // Constant index vector d of size c.nrow () // Matrix a refers to the columns and subsetted rows of matrix c // Vector d is of size c.ncol () // F.Calc is executed for each element of c[,d] THROW (a.ncol () == c.ncol ()) ; THROW (a.nrow () == d.size ()) ; THROW (b.size () == c.ncol ()) ; THROW (getMaxIdx (d) < c.nrow ()) ; //2do: check array d for max index! MsVetMcdVcei_NC (a, b, c, d) ; } template static void MsVetMcdVcei_NC (const SVMat &a, const SVData &b, const SCMat &c, const SCData &d) { ASSERT (a.ncol () == c.ncol ()) ; ASSERT (a.nrow () == d.size ()) ; ASSERT (b.size () == c.ncol ()) ; ASSERT (getMaxIdx (d) < c.nrow ()) ; //t_size dwColIncA = a.GetColInc () ; t_size dwColIncC = c.GetColInc () ; TA * pA = a ; TA const * const pEndA = a.GetDataEnd () ; TB * pB = b ; TC const * pC = c ; TD const * pD ; TD const * pEndD = d.GetDataEnd () ; for (; pA < pEndA; ) { for (pD = d; pD < pEndD; ++pD) { F::Calc (*pA, *pB, pC [(t_size) *pD]) ; ++pA ; } ++pB ; pC += dwColIncC ; } } template static void MVcet (const SVMat &a, const SCData &b) { THROW (a.ncol () == b.size ()) ; MVcet_NC (a, b) ; } template static void MVcet_NC (const SVMat &a, const SCData &b) { ASSERT (a.ncol () == b.size ()) ; TA *pA = a ; TA const * const pEndA = a.GetDataEnd (); TA const * pColEndA ; const t_size dwColIncA = a.GetColInc () ; TB const * pB = b ; for (; pA < pEndA; ++pB) for (pColEndA = pA + dwColIncA; pA < pColEndA; ++pA) F::Calc (*pA, *pB) ; } template // matrix impl static inline void SSVc (TA &a, TB &b, const SCData &c) { SSVc_raw (a, b, c.GetData (), c.GetDataEnd ()) ; } template // raw impl. static void SSVc_raw (TA &a, TB &b, const TC * pC, TC const * const pEndC) { while (pC < pEndC) { F::Calc (a, b, *pC) ; ++ pC ; } } template // matrix impl static inline void SSVcVc (TA &a, TB &b, const SCData &c, const SCData &d) { THROW (c.size () == d.size ()) ; SSVcVc_NC (a, b, c, d) ; } template // matrix impl static inline void SSVcVc_NC (TA &a, TB &b, const SCData &c, const SCData &d) { ASSERT (c.size () == d.size ()) ; SSVcVc_raw (a, b, c.GetData (), c.GetDataEnd (), d.GetData ()) ; } template // raw impl. static void SSVcVc_raw (TA &a, TB &b, const TC * pC, TC const * const pEndC, const TD * pD) { while (pC < pEndC) { F::Calc (a, b, *pC, *pD) ; ++ pC ; ++ pD ; } } template static inline void SScScVcVc_NC (TA &a, const TB &b, const TC &c, const SCData &d, const SCData &e) { ASSERT (d.size () == e.size ()) ; const TD *pD = d, * const pEndD = d.GetDataEnd () ; const TE *pE = e ; while (pD < pEndD) { F::Calc (a, b, c, *pD, *pE) ; ++ pD ; ++ pE ; } } template // matrix impl static inline void SScVc (TA &a, const TB &b, const SCData &c) { SScVc_raw (a, b, c.GetData (), c.GetDataEnd ()) ; } template // raw impl. static void SScVc_raw (TA &a, const TB &b, TC const * pC, TC const * const pEndC) { while (pC < pEndC) { F::Calc (a, b, *pC) ; ++ pC ; } } template static void SVc (TA &a, const SCData &b) { SVc_raw (a, b.GetData (), b.GetDataEnd ()) ; } template static void SVc_raw (TA &a, TB const * pB, TB const * const pEndB) { for (; pB < pEndB; ++pB) F::Calc (a, *pB) ; } template static void SV (TA &a, SCData &b) { TB *pB ; TB * const pEnd = b.GetDataEnd () ; for (pB = b; pB < pEnd; ++pB) F::Calc (a, *pB) ; } template // matrix impl static inline void SVcVc (TA &a, const SCData &b, const SCData &c) { THROW (b.size () == c.size ()) ; SVcVc_NC (a, b, c) ; } template // matrix impl static inline void SVcVc_NC (TA &a, const SCData &b, const SCData &c) { ASSERT (b.size () == c.size ()) ; SVcVc_raw (a, b.GetData (), b.GetDataEnd (), c.GetData ()) ; } template // raw impl. static void SVcVc_raw (TA &a, TB const * pB, TB const * const pEndB, TC const * pC) { while (pB < pEndB) { F::Calc (a, *pB, *pC) ; ++ pB ; ++ pC ; } } template // raw impl. static void SVSc (TA &a, const SVData &b, const TC &c) { TB *pB = b, * const pEndB = b.GetDataEnd () ; for (; pB < pEndB; ++pB) F::Calc (a, *pB, c) ; } template static void V (const SVData &a) { TA *pa = a.GetData () ; const TA *const paEnd = a.GetDataEnd () ; for (; pa < paEnd; pa++) F::Calc (*pa) ; } template // matrix impl static inline void SVVc (TA &a, const SVData &b, const SCData &c) { THROW (b.size () == c.size ()) ; SVVc_NC (a, b, c) ; } template // matrix impl static inline void SVVc_NC (TA &a, const SVData &b, const SCData &c) { ASSERT (b.size () == c.size ()) ; SVVc_raw (a, b.GetData (), b.GetDataEnd (), c.GetData ()) ; } template // raw impl. static void SVVc_raw (TA &a, TB * pB, TB * const pEndB, TC const * pC) { while (pB < pEndB) { F::Calc (a, *pB, *pC) ; ++ pB ; ++ pC ; } } template static void VetMcdScgVceg (const SVData &b, const SCMat &c, const TD &d, const SCData &e) { // g for group. THROW (c.nrow () == e.size ()) ; VetMcdScgVceg_NC (b, c, d, e) ; } template static void VetMcdScgVceg_NC (const SVData &b, const SCMat &c, const TD &d, const SCData &e) { // g for group. ASSERT (c.nrow () == e.size ()) ; //t_size dwColIncA = a.GetColInc () ; TB * const pEndB = b.GetDataEnd () ; TB * pB = b ; TC const * pC = c ; TE const * pE ; TE const * pEndE = e.GetDataEnd () ; for (; pB < pEndB; ) // for each column of A { pE = e ; while (pE < pEndE) { if (d == (TD) *pE) F::Calc (*pB, *pC) ; ++pC ; ++pE ; } ++pB ; } } template static void VetMcdVcei (const SVData &b, const SCMat &c, const SCData &d) { // Main dimension: matrix c // Constant index vector d of size c.nrow () // Vector d is of size c.ncol () // F.Calc is executed for each element of c[,d] THROW (b.size () == c.ncol ()) ; THROW (getMaxIdx (d) < c.nrow ()) ; //2do: check array d for max index! VetMcdVcei_NC (b, c, d) ; } template static void VetMcdVcei_NC (const SVData &b, const SCMat &c, const SCData &d) { ASSERT (b.size () == c.ncol ()) ; ASSERT (getMaxIdx (d) < c.nrow ()) ; //t_size dwColIncA = a.GetColInc () ; t_size dwColIncC = c.GetColInc () ; TB * pB = b ; TB const * pEndB = b.GetDataEnd () ; TC const * pC = c ; TD const * pD ; TD const * pEndD = d.GetDataEnd () ; for (; pB < pEndB; ) { for (pD = d; pD < pEndD; ++pD) F::Calc (*pB, pC [(t_size) *pD]) ; ++pB ; pC += dwColIncC ; } } template static void VVcVc (const SVData &a, const SCData &b, const SCData &c) { THROW (a.size () == b.size ()) ; THROW (a.size () == c.size ()) ; VVcVc_NC (a, b, c) ; } template static void VVcVc_NC (const SVData &a, const SCData &b, const SCData &c) { ASSERT (a.size () == b.size ()) ; ASSERT (a.size () == c.size ()) ; const TA *pEndA = a.GetDataEnd () ; TA *pA = a.GetData () ; const TB * pB = b.GetData () ; const TC * pC = c.GetData () ; while (pA < pEndA) { F::Calc (*pA, *pB, *pC) ; ++pA ; ++pB ; ++pC ; } } template static void VMc (const SVData &a, const SCMat &b) { THROW (a.size () == b.nrow ()) ; VMc_NC (a, b) ; } template static void VMc_NC (const SVData &a, const SCMat &b) { ASSERT (a.size () == b.nrow ()) ; TA * pA, * const pStartA = a, * const pEndA = a.GetDataEnd () ; const TB * pB = b, * const pEndB = b.GetDataEnd () ; while (pB < pEndB) { pA = pStartA ; while (pA < pEndA) { F::Calc (*pA, *pB) ; ++pA ; ++pB ; } } } template static void VMcVct (const SVData &a, const SCMat &b, const SCData &c) { THROW (a.size () == b.nrow ()) ; THROW (c.size () == b.ncol ()) ; VMcVct_NC (a, b, c) ; } template static void VMcVct_NC (const SVData &a, const SCMat &b, const SCData &c) { ASSERT (a.size () == b.nrow ()) ; ASSERT (c.size () == b.ncol ()) ; TA * const pStartA = a, * const pEndA = a.GetDataEnd () ; const TB * pB = b, * const pEndB = b.GetDataEnd () ; const TC * pC = c ; while (pB < pEndB) { TA *pA = pStartA ; while (pA < pEndA) { F::Calc (*pA, *pB, *pC) ; ++pA ; ++pB ; } ++pC ; } } template static inline void VetMcd (const SVData &a, const SCMat &b) { THROW (a.size () == b.ncols ()) ; VetMcd_NC (a, b) ; } template static inline void VetMcd_NC (const SVData &a, const SCMat &b) { ASSERT (a.size () == b.ncol ()) ; TA *pA = a ; TA *const pEndA = a.GetDataEnd () ; const TB *pbColEnd, *pB = b ; for ( ; pA < pEndA; ++pA) for (pbColEnd = pB + b.nrow (); pB < pbColEnd; ++pB) F::Calc (*pA, *pB) ; } template static void VtMcVc (const SVData &a, const SCMat &b, const SCData &c) { THROW (a.size () == b.ncol ()) ; THROW (c.size () == b.nrow ()) ; VtMcVc_NC (a, b, c) ; } template static void VtMcVc_NC (const SVData &a, const SCMat &b, const SCData &c) { ASSERT (a.size () == b.ncol ()) ; ASSERT (c.size () == b.nrow ()) ; TA * pA = a ; const TB * pB = b ; const TC * pC = c ; const TB * const pEndB = b.GetDataEnd () ; const TC * const pEndC = c.GetDataEnd () ; while (pB < pEndB) { pC = c ; while (pC < pEndC) { F::Calc (*pA, *pB, *pC) ; ++pB ; ++pC ; } ++pA ; } } template static void VSc (const SVData &a, const TB &b) { TA * pA = a ; TA * const pEnd = a.GetDataEnd () ; while (pA < pEnd) { F::Calc (*pA, b) ; ++pA ; } } template static void VScSc (const SVData &a, const TB &b, const TC &c) { TA * pA = a ; TA * const pEndA = a.GetDataEnd () ; while (pA < pEndA) { F::Calc (*pA, b, c) ; ++ pA ; } } template static void VScScVc (const SVData &a, const TB &b, const TC &c, const SCData &d) { THROW (a.size () == d.size ()) ; VScScVc_NC (a, b, c, d) ; } template static void VScScVc_NC (const SVData &a, const TB &b, const TC &c, const SCData &d) { ASSERT (a.size () == d.size ()) ; TA * pA = a, * const pEndA = a.GetDataEnd () ; TD const * pD = d ; while (pA < pEndA) { F::Calc (*pA, b, c, *pD) ; ++ pA ; ++ pD ; } } template static void SVScVc (TA &a, const SVData &b, const TC &c, const SCData &d) { THROW (b.size () == d.size ()) ; SVScVc_NC (a, b, c, d) ; } template static void SVScVc_NC (TA &a, const SVData &b, const TC &c, const SCData &d) { ASSERT (b.size () == d.size ()) ; TB * pB = b, * const pEndB = b.GetDataEnd () ; TD const * pD = d ; while (pB < pEndB) { F::Calc (a, *pB, c, *pD) ; ++pB ; ++pD ; } } template static void VScVc (const SVData &a, const TB &b, const SCData &c) { THROW (a.size () == c.size ()) ; VScVc_NC (a, b, c) ; } template static void VScVc_NC (const SVData &a, const TB &b, const SCData &c) { ASSERT (a.size () == c.size ()) ; TA * pA = a ; TA * const pEndA = a.GetDataEnd () ; TC const * pC = c ; while (pA < pEndA) { F::Calc (*pA, b, *pC) ; ++pA ; ++pC ; } } template static void VtMc (const SVData &a, const SCMat &b) { THROW (a.size () == b.ncol ()) ; VtMc_NC (a, b) ; } template static void VtMc_NC (const SVData &a, const SCMat &b) { ASSERT (a.size () == b.ncol ()) ; TA *pA = a, * const pEndA = a.GetDataEnd () ; const TB *pB = b ; while (pA < pEndA) { TB const * const pColEndB = pB + b.GetColInc () ; while (pB < pColEndB) { F::Calc (*pA, *pB) ; ++pB ; } ++pA ; } } template static void VtMcVcVc (const SVData &a, const SCMat &b, const SCData &c, const SCData &d) { THROW (a.size () == b.ncol ()) ; THROW (c.size () == b.nrow ()) ; THROW (d.size () == b.nrow ()) ; VtMcVcVc_NC (a, b, c, d) ; } template static void VtMcVcVc_NC (const SVData &a, const SCMat &b, const SCData &c, const SCData &d) { ASSERT (a.size () == b.ncol ()) ; ASSERT (c.size () == b.nrow ()) ; ASSERT (d.size () == b.nrow ()) ; TA *pA = a, * const pEndA = a.GetDataEnd () ; const TB *pB = b ; const TC *pC, * const pStartC = c, * const pEndC = c.GetDataEnd () ; const TD *pD, * const pStartD = d ; while (pA < pEndA) { pC = pStartC ; pD = pStartD ; while (pC < pEndC) { F::Calc (*pA, *pB, *pC, *pD) ; ++pB ; ++pC ; ++pD ; } ++pA ; } } template static void VsVcVbc (const SVData &a, const SCData &b, const SCData &c) { THROW (b.size () == c.size ()) ; THROW (CountTrue (c) == a.size ()) ; VsVcVbc_NC (a, b, c) ; } template static void VsVcVbc_NC (const SVData &a, const SCData &b, const SCData &c) { ASSERT (b.size () == c.size ()) ; ASSERT (CountTrue (c) == a.size ()) ; TA *pA = a ; const TB *pB = b, * const pEndB = b.GetDataEnd () ; const TC *pC = c ; while (pB < pEndB) { if (*pC) { F::Calc (*pA, *pB) ; ++ pA ; } ++ pB ; ++ pC ; } } template static void VVc (const SVData &a, const SCData &b) { THROW (a.size () == b.size ()) ; VVc_NC (a, b) ; } template static void VVc_NC (const SVData &a, const SCData &b) { ASSERT (a.size () == b.size ()) ; VVc_raw (a.GetData (), a.GetDataEnd (), b.GetData ()) ; } template static void VVc_raw (TA *pdA, TA * const pdEndA, TB const *pdB) { while (pdA < pdEndA) { F::Calc (*pdA, *pdB) ; ++pdA ; ++pdB ; } } template static void VVSc (const SVData &a, const SVData &b, const TC &c) { THROW (a.size () == b.size ()) ; VVSc_NC (a, b, c) ; } template static void VVSc_NC (const SVData &a, const SVData &b, const TC &c) { ASSERT (a.size () == b.size ()) ; TA *pA = a ; TB *pB = b, * const pEndB = b.GetDataEnd () ; while (pB < pEndB) { F::Calc (*pA, *pB, c) ; ++ pA ; ++ pB ; } } template static void VVScSc (const SVData &a, const SVData &b, const TC &c, const TD &d) { THROW (a.size () == b.size ()) ; VVScSc_NC (a, b, c, d) ; } template static void VVScSc_NC (const SVData &a, const SVData &b, const TC &c, const TD &d) { ASSERT (a.size () == b.size ()) ; TA *pA = a ; TB *pB = b, * const pEndB = b.GetDataEnd () ; while (pB < pEndB) { F::Calc (*pA, *pB, c, d) ; ++ pA ; ++ pB ; } } template static const TA &Vc_transitive (const SCData &a) { const TA * pA = a ; const TA * const pEndA = a.GetDataEnd () ; const TA * pRet = pA ; while (++pA < pEndA) if (F::Calc (*pA, *pRet)) pRet = pA ; return *pRet ; } template static TA &V_transitive (const SVData &a) { TA * pA = a ; const TA * const pEndA = a.GetDataEnd () ; TA * pRet = pA ; while (++pA < pEndA) if (F::Calc (*pA, *pRet)) pRet = pA ; return *pRet ; } template static void V_pairs (const SVData &a) { TA * pA = a ; const TA * const pEndA = a.GetDataEnd () ; while (++pA < pEndA) F::Calc (pA[0], pA[-1]) ; } template static void V_pairs_r (const SVData &a) { // computes each pair in reverse order. size = 10: (8, 9); (7, 8); ...; (0, 1) TA * pA = a.GetDataEnd () ; const TA * const pEndA = a ; while (--pA > pEndA) F::Calc (pA[-1], pA[0]) ; } } ; #endif // #ifndef SMAT_ELOP_H pcaPP/src/smat.meal.h0000644000176200001440000000740013300577052014101 0ustar liggesusers/* SMat - Simple Matrix Classes v0.1beta Copyright (C) 2011 by Heinrich Fritz (heinrich_fritz@hotmail.com) This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . */ // smat.meal.h // Mathematical Environment Abstraction Layer #ifndef SMAT_MEAL_H #define SMAT_MEAL_H //////////// // BLAS // //////////// // Level 1 double meal_dot (const int *n, const double *dx, const int *incx, const double *dy, const int *incy); double meal_nrm2 (const int *n, const double *dx, const int *incx); void meal_scal (const int *n, const double *alpha, double *dx, const int *incx) ; void meal_axpy(const int *n, const double *alpha, const double *dx, const int *incx, double *dy, const int *incy) ; // Level 2 #ifdef IMPL_BLAS_R_CONST_ERROR void meal_ger (const int *m, const int *n, const double *alpha, double *x, const int *incx, double *y, const int *incy, double *a, const int *lda) ; #else void meal_ger (const int *m, const int *n, const double *alpha, const double *x, const int *incx, const double *y, const int *incy, double *a, const int *lda) ; #endif // Level 3 void meal_gemm (const char *transa, const char *transb, const int *m, const int *n, const int *k, const double *alpha, const double *a, const int *lda, const double *b, const int *ldb, const double *beta, double *c, const int *ldc) ; ////////////// // LAPACK // ////////////// //svd void meal_gesv (const int* n, const int* nrhs, double* a, const int* lda, int* ipiv, double* b, const int* ldb, int* info) ; void meal_gesvd (const char* jobu, const char* jobvt, const int* m, const int* n, double* a, const int* lda, double* s, double* u, const int* ldu, double* vt, const int* ldvt, double* work, const int* lwork, int* info) ; //invert void meal_geev(const char* jobvl, const char* jobvr, const int* n, double* a, const int* lda, double* wr, double* wi, double* vl, const int* ldvl, double* vr, const int* ldvr, double* work, const int* lwork, int* info) ; ///////////////////// // Sort Routines // ///////////////////// void meal_sort (double *d, int l) ; void meal_sort_order (double *, int *, int) ; void meal_sort_order_rev (double *d, int *o, int l) ; /////////////////////////////// // Random Number Generator // /////////////////////////////// void meal_PutRNGstate () ; void meal_GetRNGstate () ; double meal_unif_rand () ; double meal_norm_rand (); double meal_exp_rand (); // void meal_runif (double *d, int l) ; // void meal_runif (double *d, int l, double dL, double dU) ; // void meal_runif_r (double *d, int l) ; // void meal_SampleNoReplace(int k, int n, int *y, int *x) ; //////////////////////////////////// // special values and constants // //////////////////////////////////// double meal_NaN () ; double meal_PosInf () ; double meal_NegInf () ; double meal_NaReal () ; int meal_NaInt () ; double meal_PI () ; ////////////////////////// // printing functions // ////////////////////////// void meal_printf (const char *, ...) ; void meal_warning (const char *) ; void meal_error (const char *) ; ////////////////// // Exceptions // ////////////////// void meal_OnException (const char * szDate, const char * szFile, int nLine) ; void meal_OnUException () ; #endif // #ifndef SMAT_MEAL_H pcaPP/src/PCAgrid.h0000644000176200001440000000555613300577052013503 0ustar liggesusers#ifndef INCLUDE_PCAPP_PCAGRID_H #define INCLUDE_PCAPP_PCAGRID_H #include "pcaPP.h" double ngpf (const double &d) ; class CPCAGrid { public: CPCAGrid (int *pnParamIn, int *pnParamOut, double *pdParamIn, double *pdData, double *pdLoadings, double *pdSDev, double *pdObj/*, double *pdMaxMaha*/) ; int Calc () ; protected: // void GridPlane (double &dNL, double &dNCL, double &dScat, double &dObj, double dCurSplit) ; void GridPlane (double dCurSplit) ; void EvalDirection (const double dCos, const double dSin) ; virtual double CalcObj (const double dCos, const double dSin, double &dScat, double &dScatOrth) ; double CalcProjScat (const double dCos, const double dSin) ; double CalcScatTrimmed (double dCos, double dSin, double dScat, double dScatOrth) ; double CalcVarTrimmed (double dCos, double dSin, double dScat, double dScatOrth) ; virtual void OnCalcPC () {} virtual void InitPenalty () {} // void CalcMaha (const double dScat) ; double ApplyMethod (const SCVecD &v) ; void ApplyMethod (const SCMatD &m, SVecD &v) ; double ApplyMethodMean (const SCMatD &m) ; inline SMatD &TempY () { return m_mY[m_dwTempYIdx] ; } inline SMatD &TempYC () { return m_mY[1-m_dwTempYIdx] ; } void SwapTempY () { m_dwTempYIdx = 1 - m_dwTempYIdx ;} void BackTransform () ; void RemoveLoading (/*DWORD i*/) ; void AddLoading (const double &dNL, const double &dNCL) ; const t_size m_dwN, m_dwP, m_dwK, m_dwSplitCircle, m_dwMaxIter, m_dwMethod, m_dwTrace, m_dwkIni, m_dwCheckOrth ; int &m_nReturn ; const double m_dZeroTol ; SMatD m_mX, m_mL, m_mY[2] ; //, m_mTempPP, m_mTempPN ; SVecD m_vAfin, m_vAfinBest, m_vScl, m_vYOpt, m_vSDev, m_vObj ; //, m_vTempN, m_vTempN2, m_vTempN3; SVecD m_vCurY, m_vProj ;//, m_vMaxMaha ; SVecN m_vOrd ; t_size m_dwCurK, m_dwCurP ;// iteration variables t_size m_dwPSub, m_dwTempYIdx ; /// double m_dBestObj, m_dCurScat, m_dCurScatOrth, m_dNL, m_dNCL ; double * const m_pdProj, * const m_pdCurLC, * const m_pdCurLCEnd, *m_pdCurY ; // , * const m_pdEndProj } ; class CsPCAGrid : public CPCAGrid { public: CsPCAGrid (int *pnParamIn, int *pnParamOut, double *pdParamIn, double *pdData, double *pdLoadings, double *pdSDev, double *pdObj/*, double *pdMaxMaha*/, double *pdLambda, double *pdBackTransHD) ; protected: virtual void OnCalcPC () ; double GetPenalty (const double& dCos, const double& dSin) ; virtual double CalcObj (const double dCos, const double dSin, double &dScat, double &dScatOrth) ; virtual void InitPenalty () ; const int m_nGloScatter, m_nSpeedUp ; const t_size m_dwPHD ; const double m_dQ, m_dS ; const BOOL m_bUseQ, m_bUseS ; SMatD m_mBackTransHD, m_mBackProj ; SVecD m_vLambda, m_vLoadHD, m_vTempP, m_vTempPSub, m_vSumLoadOthers, m_vSumLoadThis ; double m_dGloScatter, m_dCurLambda ; double m_dLoadSumThis, m_dLoadSumOther ; } ; #endif // #ifndef INCLUDE_PCAPP_PCAGRID_H pcaPP/src/ML_package.h0000644000176200001440000000207513300577052014206 0ustar liggesusers#ifdef MATLAB_MEX_FILE #ifdef ES_DEV_ENV // #include "../../../RDev/R.Inc.h" #include "../../../SMat/smat.def.h" #include "../../../SMat/smat.h" #include "../../../MLDev/ML_meal.h" #else // #include "R.Inc.h" #include "smat.def.h" #include "smat.h" #include "ML_meal.h" #endif #define MEX_FUNCTION_EXPORTS #ifdef MEX_FUNCTION_EXPORTS #define MEX_FUNCTION_API __declspec(dllexport) #else #define MEX_FUNCTION_API __declspec(dllimport) MEX_FUNCTION_API void mexFunction(int nlhs, mxArray* plhs[], int nrhs, mxArray* prhs[]); #endif void ML_l1median_HoCr (int nlhs, mxArray* plhs[], int nrhs, mxArray *prhs[]) ; void ML_l1median_VaZh (int nlhs, mxArray* plhs[], int nrhs, mxArray *prhs[]) ; void ML_qn (int nlhs, mxArray* plhs[], int nrhs, mxArray *prhs[]) ; void ML_PCAgrid (int nlhs, mxArray* plhs[], int nrhs, mxArray *prhs[]) ; void ML_sPCAgrid (int nlhs, mxArray* plhs[], int nrhs, mxArray *prhs[]) ; void ML_PCAprojU (int nlhs, mxArray* plhs[], int nrhs, mxArray *prhs[]) ; void ML_PCAproj (int nlhs, mxArray* plhs[], int nrhs, mxArray *prhs[]) ; #endif pcaPP/src/smat.base.h0000644000176200001440000013222613300577052014102 0ustar liggesusers/* SMat - Simple Matrix Classes v0.1beta Copyright (C) 2011 by Heinrich Fritz (heinrich_fritz@hotmail.com) This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . */ #ifndef ES_SMAT_BASE_H #define ES_SMAT_BASE_H #include "smat.def.h" #include #ifdef _DEBUG #define ASSERT_TEMPRANGE(L, U) SDataRefCont::CRefRange temp_assert_temprange(L, U, &GetPermTempRefRange ()) #else #define ASSERT_TEMPRANGE(L, U) #endif ////////////////////////// // Forward References // ////////////////////////////// template class SMat ; template class SCMat ; template class SVMat ; template class SVec ; template class SCVec ; template class SVVec ; template class SCData ; template class SVData ; /////////////////////////////// // Basic type declarations // /////////////////////////////// #define SMAT_TYPE (TYPE, TOKEN) \ \ typedef SMat SMat##TOKEN ; \ typedef SCMat SCMat##TOKEN ; \ typedef SVMat SVMat##TOKEN ; \ typedef SVec SVec##TOKEN ; \ typedef SCVec SCVec##TOKEN ; \ typedef SVVec SVVec##TOKEN ; \ typedef SCData SCData##TOKEN ; \ typedef SVData SVData##TOKEN ; //2do: use SMAT_TYPE - macro // double typedef SMat SMatD ; typedef SCMat SCMatD ; typedef SVMat SVMatD ; typedef SVec SVecD ; typedef SCVec SCVecD ; typedef SVVec SVVecD ; typedef SCData SCDataD ; typedef SVData SVDataD ; // int typedef SMat SMatN ; typedef SCMat SCMatN ; typedef SVMat SVMatN ; typedef SVec SVecN ; typedef SCVec SCVecN ; typedef SVVec SVVecN ; typedef SCData SCDataN ; typedef SVData SVDataN ; //////////////// // SDataRef // //////////////// class SDataRef { protected: SDataRef () ; // SDataRef (const t_size dwRef) ; public: SDataRef (const t_size dwCount) ; // SDataRef (const t_size dwCount, const t_size dwRef) ; SDataRef (const t_size dwCount, void * const pData) ; ~SDataRef () ; SDataRef *Reference (SDataRef *&pRef) ; SDataRef *Dereference (SDataRef *&pRef) ; static void sDeref (SDataRef *&pRef) ; SDataRef *Ref (SDataRef *&pRef) ; SDataRef *Ref_NDR (SDataRef *&pRef) ;// No DeRereference inline t_count GetRef () const { return m_dwRef ; } inline t_size GetSize () const { return GetSizeRef () ; } inline BOOL IsOwner () const { return m_bOwner ; } inline void *GetEnd () const { return GetDataEndRef () ; } BOOL Require (t_size s, SDataRef *&pRef) ; SDataRef *Recreate (t_size dwSize, SDataRef *&pRef) ; inline void *GetData () const { return GetDataRef () ; } inline BOOL IsStatic () const { return m_bStatic ; } static SDataRef &Empty () ; void FreeIfIdle () ; //inline t_size GetItemSize () { return m_dwItemSize ; } protected: inline void SetStatic () { m_bStatic = TRUE ; } inline void IncRef () { ++m_dwRef ; } inline void DecRef () { --m_dwRef ; } void Alloc (t_size dwSize) ; void Alloc_NF (t_size dwSize) ; // void CalcDataEnd (); void Free () ; void CheckFree () ; BOOL Deref () ; void *m_pData, *m_pDataEnd ; t_size m_dwRef, m_dwCount ; //const t_size m_dwItemSize ; const BOOL m_bOwner ; BOOL m_bStatic ; private: void *& GetDataRef () { return m_pData ; } void *& GetDataEndRef () { return m_pDataEnd ; } t_size & GetSizeRef () { return m_dwCount ; } void * const& GetDataRef () const { return m_pData ; } void * const& GetDataEndRef () const { return m_pDataEnd ; } const t_size & GetSizeRef () const { return m_dwCount ; } } ; void Deref (SDataRef *&pRef) ; class SDataRef_Static: public SDataRef { typedef SDataRef t_base ; public: SDataRef_Static (const t_size dwCount = 0, const BOOL bStatic = TRUE) ; ~SDataRef_Static () ; SDataRef_Static &Require (t_size dwSize) ; protected: } ; class SDataRefCont { typedef SDataRef_Static t_item ; typedef t_item* t_pitem ; public: SDataRefCont () ; ~SDataRefCont () ; class CRefRange { public: CRefRange (const t_size dwL = NAI, const t_size dwU = NAI, CRefRange *pPerm = NULL) : m_dwL (dwL), m_dwU (dwU), m_pPerm (pPerm) { ASSERT (dwL <= dwU) ; if (pPerm) { ASSERT (m_pPerm->GetL () > dwU) ; pPerm->Get (m_dwLOld, m_dwUOld) ; pPerm->Set (dwL, dwU) ; } } ~CRefRange () { if (m_pPerm) m_pPerm->Set (m_dwLOld, m_dwUOld) ; } t_size GetL () const { return m_dwL ; } t_size GetU () const { return m_dwU ; } void Get (t_size &dwL, t_size &dwU) const { dwL = m_dwL, dwU = m_dwU ; } void Set (t_size dwL, t_size dwU) { m_dwL = dwL, m_dwU = dwU ; } protected: t_size m_dwL, m_dwU ; t_size m_dwLOld, m_dwUOld ; CRefRange *m_pPerm ; } ; inline t_size GetSize () { return sizeRef () ; } inline t_size GetMemSize () { return GetSize () * sizeof (t_pitem) ; } inline t_pitem * GetData () { return dataRef (); } void Require (t_size dwCount) ; t_item &Item (t_size dwIdx) ; void FreeIfIdle (); protected: void Free () ; inline t_size &sizeRef () { return m_dwSize ; } inline t_pitem* &dataRef () { return m_ppData; } t_pitem *m_ppData ; t_size m_dwSize ; } ; SDataRefCont &GetTempCont () ; SDataRefCont::CRefRange &GetPermTempRefRange () ; void RequireTemp (t_size dwCount) ; SDataRef_Static &tempRef (t_size dwIdx) ; void FreeTempCont () ; template T *tempRef (t_size dwIdx, T * & p, t_size dwSize) { SDataRef_Static &ref = tempRef (dwIdx) ; ref.Require (dwSize * sizeof (T)) ; return p = (T *) ref.GetData () ; } template T *tempArray (t_size dwIdx, t_size dwSize) { SDataRef_Static &ref = tempRef (dwIdx) ; ref.Require (dwSize * sizeof (T)) ; return (T *) ref.GetData () ; } //////////////////// // CDataCont_NT // //////////////////// class CDataCont_NT { public: CDataCont_NT () { ++GetInstanceCount () ; } ~CDataCont_NT () { if (!--GetInstanceCount ()) FreeTempCont () ; } private: static t_size &GetInstanceCount () ; } ; #define TEMP_GUARD CDataCont_NT __TEMP_GUARD ///////////////// // SVData // ///////////////// template class SVData :public CDataCont_NT// No Dimension { typedef SVData t_this ; typedef SDataRef_Static t_tempRef ; public: // Destuctor // ~SVData () { SDataRef::sDeref (m_pDataRef) ; } // Constructor // SVData () { Ref_NDR (SDataRef::Empty ()) ; ResetOffsetSize () ; } SVData (SDataRef &ref) { Ref_NDR (ref) ; t_this::ResetOffset (Bytes2Size (ref.GetSize ())) ; } SVData (SDataRef_Static &ref) { Ref_NDR (ref) ; t_this::ResetOffset (0) ; } SVData (SDataRef &ref, t_size dwSize) { Ref_NDR (ref) ; t_this::ResetOffset (dwSize) ; } SVData (SDataRef_Static &ref, t_size dwSize) : m_dwOffset (0) { Ref_NDR (ref) ; t_this::Require (dwSize) ; } SVData (SDataRef &ref, t_size dwOffset, t_size dwSize) : m_dwOffset (dwOffset) { Ref_NDR (ref) ; t_this::SetSize (dwSize) ; } SVData (SDataRef_Static &ref, t_size dwOffset, t_size dwSize) { Ref_NDR (ref) ; t_this::Require (dwOffset, dwSize) ; } SVData (const t_this &p) { Ref_NDR (p.GetDataRef ()) ; t_this::ResetOffsetSize () ; } SVData (const t_this &p, t_size dwSize) { Ref_NDR (p.GetDataRef ()) ; t_this::ResetOffset (dwSize) ; } SVData (const t_this &p, t_size dwOffset, t_size dwSize) : m_dwOffset (dwOffset) { Ref_NDR (p.GetDataRef ()) ; t_this::SetSize (dwSize) ; } SVData (const t_size dwSize) { Ref_NDR (*new SDataRef (Size2Bytes (dwSize))) ; t_this::ResetOffset_NC (dwSize) ; } SVData (T * const pData, const t_size dwSize) { Ref_NDR (*new SDataRef (Size2Bytes (dwSize), pData)) ; t_this::ResetOffset_NC (dwSize) ; } SVData (SDataRef_Static &ref, const t_this &p) // this is supposed to copy the data from p to ref. { Ref_NDR (ref) ; if (&ref == &p.GetDataRef ()) // they act on the same reference. thus no need to copy the data t_this::SetOffset_NC (p.GetOffset (), p.GetSize ()) ; else { m_dwOffset = 0 ; Require (p.GetSize ()) ; memcpy (ref.GetData (), p.GetData (), Size2Bytes (p.GetSize ())) ; } } t_this & operator = (const t_this &p) { Ref (p.GetDataRef ()) ; GetSizeRef () = p.GetSize () ; GetOffsetRef () = p.GetOffset () ; GetEndRef () = p.GetEnd () ; return *this ; } inline t_size size () const { return GetSizeRef () ; } inline T &operator () (const t_size dwIdx) const { return GetData (dwIdx) ; } inline operator T * () const { return GetData () ; } inline T *GetDataEnd () const { return GetRawData () + GetEnd () ; } inline T *GetData () const { return GetRawData () + GetOffset () ; } inline T *GetData (t_size dwIdx) const { THROW (dwIdx < GetSize ()) ; return GetData_NC (dwIdx) ; } inline T *GetData_NC (t_size dwIdx) const { ASSERT (dwIdx < GetSize ()) ; return GetData () + dwIdx ; } void Reset (const T& v) const { T *pCur ; T *const pEnd = t_this::GetDataEnd () ; for (pCur = t_this::GetData (); pCur < pEnd; pCur++) *pCur = v ; } void Set (T * const pData, const t_size dwSize) { Ref (*new SDataRef (Size2Bytes (dwSize), pData)) ; t_this::ResetOffset_NC (dwSize) ; } protected: void Redim () { t_this::ResetOffsetSize () ; } void Redim (const t_size dwSize) { t_this::ResetOffset (dwSize) ; } void Redim_NC (const t_size dwSize) { t_this::ResetOffset_NC (dwSize) ; } void Reshape (t_size dwSize) { t_this::SetSize (dwSize) ; } void Reshape (t_size dwOffset, t_size dwSize) { t_this::SetOffset (dwOffset, dwSize) ; } void Reshape_NC (t_size dwSize) { t_this::SetSize_NC (dwSize) ; } void Reshape_NC (t_size dwOffset, t_size dwSize) { t_this::SetOffset_NC (dwOffset, dwSize) ; } void Recreate (t_size dwSize) { t_this::GetDataRef ()->Recreate (Size2Bytes (dwSize), t_this::GetDataRef ()) ; t_this::ResetOffset (dwSize) ; } void Require (t_size dwSize) { if (t_this::GetDataRef ().Require (Size2Bytes (dwSize), m_pDataRef)) t_this::ResetOffset (dwSize) ; else t_this::SetSize (dwSize) ; } void Require (t_size dwOffset, t_size dwSize) { t_this::GetDataRef ().Require (Size2Bytes (dwOffset + dwSize), m_pDataRef) ; t_this::SetOffset_NC (dwOffset, dwSize) ; } inline T &Item (const t_size dwIdx) const { THROW (dwIdx < GetSize ()) ; return GetData () [dwIdx] ; } inline T &Item_NC (const t_size dwIdx) const { ASSERT (dwIdx < GetSize ()) ; return GetData () [dwIdx] ; } void SetDataRef (SDataRef &ref) { ref.Ref (m_pDataRef) ; } void SetDataRef_NDR (SDataRef &ref) { ref.Ref_NDR (m_pDataRef) ; } inline SDataRef &GetDataRef () const { return *m_pDataRef; } inline T *GetRawData () const { return (T *) GetDataRef ().GetData () ; } inline t_size GetRawSize () const { return GetDataRef ().GetSize () ; } inline t_size GetOffset () const { return m_dwOffset ; } inline t_size GetSize () const { return size () ; } inline t_size GetEnd () const { return GetEndRef () ; } void ResetOffsetSize () { ResetOffset_NC (Bytes2Size (GetRawSize ())) ; } inline BOOL GetDataIntegrity () { return Size2Bytes (GetEnd ()) <= GetRawSize () ; } void Ref (SDataRef &ref) { ref.Ref (m_pDataRef) ; } void Ref_NDR (SDataRef &ref) { ref.Ref_NDR (m_pDataRef) ; } BOOL HasRawCap (t_size dwSize) { return Size2Bytes (dwSize) <= GetRawSize () ; } inline t_size Size2Bytes (t_size dwSize) { return dwSize * sizeof (T) ; } inline t_size Bytes2Size (t_size dwBytes) { return dwBytes / sizeof (T) ; } void SetOffset (t_size dwOffset, t_size dwSize) { #ifdef PEDANTIC THROW (dwOffset + dwSize <= GetSize () + GetOffset ()) ; #else THROW (HasRawCap (dwOffset + dwSize)) ; #endif m_dwOffset = dwOffset ; SetSize_NC (dwSize) ; } void SetOffset_NC (t_size dwOffset, t_size dwSize) { #ifdef PEDANTIC ASSERT (dwOffset + dwSize <= GetSize () + GetOffset ()) ; #else ASSERT (HasRawCap (dwOffset + dwSize)) ; #endif m_dwOffset = dwOffset ; SetSize_NC (dwSize) ; } void Offset (t_size dwOffset, t_size dwSize) { #ifdef PEDANTIC THROW (dwOffset + dwSize <= GetSize ()) ; #else THROW (HasRawCap (m_dwOffset + dwOffset + dwSize)) ; #endif m_dwOffset += dwOffset ; SetSize_NC (dwSize) ; } void Offset_NC (t_size dwOffset, t_size dwSize) { #ifdef PEDANTIC ASSERT (dwOffset + dwSize <= GetSize ()) ; #else ASSERT (HasRawCap (m_dwOffset + dwOffset + dwSize)) ; #endif m_dwOffset += dwOffset ; SetSize_NC (dwSize) ; } void SetSize (t_size dwSize) { THROW (HasRawCap (GetOffset () + dwSize)) ; SetSize_NC (dwSize) ; } void SetSize_NC (t_size dwSize) { ASSERT (HasRawCap (GetOffset () + dwSize)) ; GetSizeRef () = dwSize ; GetEndRef () = m_dwOffset + GetSize () ; } void ResetOffset (t_size dwSize) { THROW (HasRawCap (dwSize)) ; ResetOffset_NC (dwSize) ; } void ResetOffset_NC (t_size dwSize) { ASSERT (HasRawCap (dwSize)) ; GetOffsetRef () = 0 ; GetEndRef () = GetSizeRef () = dwSize ; } private: inline t_size &GetSizeRef () { return m_dwSize ; } inline t_size &GetOffsetRef () { return m_dwOffset ; } inline t_size &GetEndRef () { return m_dwEnd ; } inline const t_size &GetSizeRef () const { return m_dwSize ; } inline const t_size &GetOffsetRef () const { return m_dwOffset ; } inline const t_size &GetEndRef () const { return m_dwEnd ; } SDataRef *m_pDataRef ; t_size m_dwSize, m_dwOffset, m_dwEnd ; } ; template class SCData : protected SVData { typedef SCData t_this ; typedef SVData t_base ; protected: // Conststructors // SCData (const t_base &dat) : t_base (dat) { } SCData (const t_base &dat, const t_size dwSize) : t_base (dat, dwSize) { } SCData (const t_base &dat, const t_size dwOffset, const t_size dwSize) : t_base (dat, dwOffset, dwSize) { } public: SCData () { } SCData (const t_this &p) : t_base (p) { } SCData (const t_size dwSize) : t_base (dwSize) { } SCData (T * const pData, const t_size dwSize) : t_base (pData, dwSize) { } SCData (SDataRef_Static &ref) : t_base (ref) { } SCData (SDataRef &ref, const t_size dwSize) : t_base (ref, dwSize) { } SCData (SDataRef_Static &ref, const t_size dwSize) : t_base (ref, dwSize) { } SCData (SDataRef &ref, const t_size dwOffset, const t_size dwSize) : t_base (ref, dwOffset, dwSize) { } SCData (SDataRef_Static &ref, const t_size dwOffset, const t_size dwSize) : t_base (ref, dwOffset, dwSize) { } SCData (SDataRef &ref, const t_this &p) : t_base (ref, p) { } // this is supposed to copy the data from p. SCData (SDataRef_Static &ref, const t_this &p) : t_base (ref, p) { } // this is supposed to copy the data from p. inline const T *GetDataEnd () const { return t_base::GetDataEnd () ; } inline const T *GetData () const { return t_base::GetData () ; } inline const T *GetData (t_size dwIdx) const { return t_base::GetData (dwIdx) ; } inline const T *GetData_NC (t_size dwIdx) const { return t_base::GetData_NC (dwIdx) ; } inline t_size size () const { return t_base::size () ; } inline t_size GetSize () const { return t_this::size () ; } inline const T &operator () (const t_size dwIdx) const { return *GetData (dwIdx) ; } inline operator const T * () const { return GetData () ; } }; //////////////// // CDimCont // //////////////// template class CDimCont { typedef CDimCont

t_this ; public: CDimCont (const t_this &dc) { memcpy (GetDims (), dc.GetDims (), sizeof (m_adwDim)) ; } CDimCont () {} BOOL EqualDims (const t_this &dc) const { t_size i ; for (i = 0; i < P; i++) if (GetDim(i) != dc.GetDim (i)) return FALSE ; return TRUE ; } const t_size size () const { return DimProd () ; } const t_size DimProd () const { t_size ret = 1 ; t_size i ; for (i = 0; i < P; i++) ret *= GetDim_NC (i) ; return ret ; } void SetDim (const t_this &dc) { memcpy (GetDims (), dc.GetDims (), sizeof (m_adwDim)) ; } const t_this &dim () const { return *this ; } inline t_size GetDim () const { return P ; } inline const t_size GetDim (t_size p) const { THROW (p < P) ; return m_adwDim [p] ; } inline const t_size GetDim_NC (t_size p) const { ASSERT (p < P) ; return m_adwDim [p] ; } inline const t_size * GetDimPtr (t_size p) const { THROW (p < P) ; return m_adwDim + p ; } inline const t_size * GetDimPtr_NC (t_size p) const { ASSERT (p < P) ; return m_adwDim + p ; } inline const int * GetDimPtrS_NC (t_size p) const { ASSERT (p < P) ; return (int *) (m_adwDim + p) ; } protected: inline t_size & GetDimRef (t_size p) { THROW (p < P) ; return m_adwDim [p] ; } inline t_size & GetDimRef_NC (t_size p) { ASSERT (p < P) ; return m_adwDim [p] ; } inline t_size *GetDims () { return m_adwDim ; } inline const t_size *GetDims () const { return m_adwDim ; } t_size m_adwDim [P] ; } ; typedef SVData SSVecN ; /////////////// // Vectors // /////////////// template class SCVec : public SCData, public CDimCont<1> { typedef SCData t_base ; typedef SCVec t_this ; typedef CDimCont <1> tb_DimCont ; typedef SVData tb_DataCont ; public: // Constructors // SCVec (const tb_DataCont &dat) : t_base (dat) { SetDim_NC (0) ; } SCVec (const tb_DataCont &dat, const t_size dwSize) : t_base (dat, dwSize) { SetDim_NC (dwSize) ; } SCVec (const tb_DataCont &dat, const t_size dwOffset, const t_size dwSize) : t_base (dat, dwOffset, dwSize) { SetDim_NC (dwSize) ; } SCVec () { SetDim_NC (0) ; } SCVec (const t_this &p) : t_base (p), tb_DimCont (p) { /*SetDim_NC (p.size ()) ;*/ } SCVec (const t_size dwSize) : t_base (dwSize) { SetDim_NC (dwSize) ; } SCVec (T * const pData, const t_size dwSize) : t_base (pData, dwSize) { SetDim_NC (dwSize) ; } SCVec (SDataRef_Static &ref) : t_base (ref) { SetDim_NC (0) ; } SCVec (SDataRef &ref, const t_size dwSize) : t_base (ref, dwSize) { SetDim_NC (dwSize) ; } SCVec (SDataRef_Static &ref, const t_size dwSize) : t_base (ref, dwSize) { SetDim_NC (dwSize) ; } SCVec (SDataRef &ref, const t_size dwOffset, const t_size dwSize) : t_base (ref, dwOffset, dwSize) { SetDim_NC (dwSize) ; } SCVec (SDataRef_Static &ref, const t_size dwOffset, const t_size dwSize) : t_base (ref, dwOffset, dwSize) { SetDim_NC (dwSize) ; } SCVec (SDataRef &ref, const t_this &p) : t_base (ref, p), tb_DimCont (p) { } SCVec (SDataRef_Static &ref, const t_this &p) : t_base (ref, p), tb_DimCont (p) { } SCVec (SDataRef &ref, const tb_DimCont &p) : t_base (ref, p.size ()), tb_DimCont (p) { } SCVec (SDataRef_Static &ref, const tb_DimCont &p) : t_base (ref, p.size ()), tb_DimCont (p) { } inline t_size size () const { return t_this::GetDim_NC (0) ; } // Data Access // inline const T &operator () (const t_size &dwIdx) const { return t_this::Item (dwIdx) ; } inline const T &Item (const t_size &dwIdx) const { return t_base::Item (dwIdx) ; } inline const T &Item_NC (const t_size &dwIdx) const { return t_base::Item_NC (dwIdx) ; } inline const T *GetDataEnd () const { return t_base::GetDataEnd () ; } inline const T *GetData () const { return t_base::GetData () ; } inline const T *GetData (const t_size &dwIdx) const { return t_base::GetData (dwIdx) ; } inline const T *GetData_NC (const t_size &dwIdx) const { return t_base::GetData_NC (dwIdx) ; } inline const T GetValue (const t_size &dwIdx) const { return *tb_DataCont::GetData (dwIdx) ; } inline const T GetValue_NC (const t_size &dwIdx) const { return *tb_DataCont::GetData_NC (dwIdx) ; } protected: const t_this &operator = (const t_this &p ) const { THROW (0) ;} // this MUST never be called, as you can't change a constant matrix! Thus it's protected! // VT::25.06.2017 // // Fix to compile on gcc-7: fix proposed by Prof. Ripley: // change 0 to 0U (unsigned) and comment out the const function (second line) // inline t_size &nsizeRef () { return t_this::GetDimRef_NC (0U) ; } // inline const t_size &nsizeRef () const { return t_this::GetDimRef_NC (0U) ; } inline void SetDim (const t_size dwSize) { THROW (dwSize <= t_base::GetSize ()) ; t_this::nsizeRef () = dwSize ; } inline void SetDim_NC (const t_size dwSize) { ASSERT (dwSize <= t_base::GetSize ()) ; t_this::nsizeRef () = dwSize ; } inline void SetDim (const tb_DimCont & m) { THROW (m.DimProd () <= t_base::GetSize ()) ; tb_DimCont::SetDim (m) ; } inline void SetDim_NC (const tb_DimCont & m) { ASSERT (m.DimProd () <= t_base::GetSize ()) ; tb_DimCont::SetDim (m) ; } } ; template class SVVec ; template class SVec : public SCVec { typedef SVec t_this ; typedef SCVec tc_this ; typedef SVVec tv_this ; typedef SCVec t_base ; typedef SVData tb_DataCont ; typedef SCData tb_DataContC ; typedef CDimCont <1> tb_DimCont ; // typedef CTempContainer t_TempContainer ; // friend class CTempContainer ; public: typedef T t_data ; // Constructors // SVec () { } SVec (const t_this &p) : t_base (p) { } SVec (const t_size dwSize) : t_base (dwSize) { } SVec (T * const pData, const t_size dwSize) : t_base (pData, dwSize) { } SVec (SDataRef_Static &ref) : t_base (ref) { } SVec (SDataRef &ref, const t_size dwSize) : t_base (ref, dwSize) { } SVec (SDataRef_Static &ref, const t_size dwSize) : t_base (ref, dwSize) { } SVec (SDataRef &ref, const t_size dwOffset, const t_size dwSize) : t_base (ref, dwOffset, dwSize) { } SVec (SDataRef_Static &ref, const t_size dwOffset, const t_size dwSize) : t_base (ref, dwOffset, dwSize) { } SVec (SDataRef &ref, const tc_this &p) : t_base (ref, p) { } SVec (SDataRef_Static &ref, const tc_this &p) : t_base (ref, p) { } SVec (SDataRef &ref, const tb_DimCont &p) : t_base (ref, p) { } SVec (SDataRef_Static &ref, const tb_DimCont &p) : t_base (ref, p) { } SVec (const tb_DataCont &dat) : t_base (dat) { } SVec (const tb_DataCont &dat, const t_size dwSize) : t_base (dat, dwSize) { } SVec (const tb_DataCont &dat, const t_size dwOffset, const t_size dwSize) : t_base (dat, dwOffset, dwSize) { } t_this &operator = (const t_this &p ) { tb_DimCont::operator = (p) ; tb_DataCont::operator = (p) ; return *this ; } // Re-Creation / Re-structuring // void Reshape (const t_size dwSize) { t_base::Reshape (dwSize) ; t_this::SetDim_NC (dwSize) ; } void Reshape_NC (const t_size dwSize) { t_base::Reshape (dwSize) ; t_this::SetDim_NC (dwSize) ; } void Reshape (const t_size dwOffset, const t_size dwSize) { t_base::Reshape (dwOffset, dwSize) ; t_this::SetDim_NC (dwSize) ; } void Redim (const t_size dwSize) { t_base::Redim (dwSize) ; t_this::SetDim_NC (dwSize) ; } void Redim_NC (const t_size dwSize) { t_base::Redim_NC (dwSize) ; t_this::SetDim_NC (dwSize) ; } void Recreate (const t_size dwSize) { t_base::Recreate (dwSize) ; t_this::SetDim_NC (dwSize) ; } void Require (const tc_this &v) {Require (v.size ()) ; } void Require (const t_size dwSize) { t_base::Require (dwSize) ; t_this::SetDim_NC (dwSize) ; } // Cast Operators // const tb_DataCont &operator *() const { return *(const tb_DataCont *) this ; } tb_DataCont &operator *() { return *( tb_DataCont *) this ; } const tv_this &operator !() const {return * (const tv_this*) this ; } tv_this &operator !() {return * ( tv_this*) this ; } operator T * () const { return GetData () ; } tc_this &Const () {return *( tc_this) this ; } const tc_this &Const () const {return *(const tc_this) this ; } // Copy Operations // // 2do: move to global functions! void Copy_R (const tc_this &vec) { Require (vec) ; Copy_NC (vec) ; } void Copy (const tc_this &vec) const { THROW (this->EqualDims (vec)) ; Copy_NC (vec) ; } void Copy (const tb_DataContC &vec) const { ASSERT (t_this::size () == vec.size ()) ; Copy_NC (vec) ; } void Copy_NC (const tc_this &vec) const { ASSERT (this->EqualDims (vec)) ; memcpy (t_this::GetData (), vec.GetData (), t_this::GetSize () * sizeof (T)) ; } void Copy_NC (const tb_DataContC &vec) const { ASSERT (t_this::size () == vec.size ()) ; memcpy (t_this::GetData (), vec.GetData (), t_this::GetSize () * sizeof (T)) ; } void Copy (T const * const p, t_size n) const { THROW (n < t_this::size ()) ; Copy_NC (p, n) ; } void Copy_NC (T const * const p, t_size n) const { ASSERT (n < t_this::size ()) ; memcpy (t_this::GetData (), p, n * sizeof (T)) ; } void Copy_NC (T const * const p) const { memcpy (t_this::GetData (), p, t_this::GetSize () * sizeof (T)) ; } // Data Access // inline T &operator () (const t_size &dwIdx) const { return t_this::Item (dwIdx) ; } inline T &Item (const t_size &dwIdx) const { return tb_DataCont::Item (dwIdx) ; } inline T &Item_NC (const t_size &dwIdx) const { return tb_DataCont::Item_NC (dwIdx) ; } inline T *GetDataEnd () const { return tb_DataCont::GetDataEnd () ; } inline T *GetData () const { return tb_DataCont::GetData () ; } inline T *GetData (const t_size &dwIdx) const { return tb_DataCont::GetData (t_this::GetIdx (dwIdx)) ; } inline T *GetData_NC (const t_size &dwIdx) const { return tb_DataCont::GetData_NC (t_this::GetIdx (dwIdx)) ; } inline void Reset (const T &v) const { t_base::Reset (v) ; } void Set (T *pData, t_size dwSize) { t_base::Set (pData, dwSize) ; t_base::SetDim_NC (dwSize) ; } const t_this GetDataRef (t_size dwStart, t_size dwEnd) const { ASSERT (dwStart <= dwEnd) ; ASSERT (dwEnd <= t_this::size ()) ; return t_this (**this, dwStart, dwEnd - dwStart) ; } protected: // const t_this &operator = (t_this &p ) const { THROW (FALSE) ; return NULL ; } // this MUST never be called, as you can't change a constant matrix/vector! Thus it's protected! } ; template class SVVec : public SVec { typedef SVec t_base ; typedef SVVec t_this ; SVVec () {} // the constructor is private. this type cannot be created. public: t_this &operator = (const t_base &p ) { t_base::operator = (p) ; return *this ; } } ; ////////////// // Matrix // ////////////// template class SCMat : public SCData, public CDimCont<2> { typedef SCData t_base ; typedef SCMat t_this ; typedef CDimCont <2> tb_DimCont ; typedef SVData tb_DataCont ; public: // Constructors // SCMat (const tb_DataCont &dat) : t_base (dat) { SetDim_NC (0, 0) ; } SCMat (const tb_DataCont &dat, const t_size dwRows, const t_size dwCols) : t_base (dat, dwRows * dwCols) { SetDim_NC (dwRows, dwCols) ; } SCMat (const tb_DataCont &dat, const t_size dwOffset, const t_size dwRows, const t_size dwCols) : t_base (dat, dwOffset, dwRows * dwCols) { SetDim_NC (dwRows, dwCols) ; } SCMat () { SetDim_NC (0, 0) ; } SCMat (const t_this &p) : t_base (p), tb_DimCont (p) { } SCMat (const t_size dwRows, const t_size dwCols) : t_base (dwRows * dwCols) { SetDim_NC (dwRows, dwCols) ; } SCMat (T * const pData, const t_size dwRows, const t_size dwCols) : t_base (pData, dwRows * dwCols) { SetDim_NC (dwRows, dwCols) ; } SCMat (SDataRef_Static &ref) : t_base (ref) { SetDim_NC (0, 0) ; } SCMat (SDataRef &ref, const t_size dwRows, const t_size dwCols) : t_base (ref, dwRows * dwCols) { SetDim_NC (dwRows, dwCols) ; } SCMat (SDataRef_Static &ref, const t_size dwRows, const t_size dwCols) : t_base (ref, dwRows * dwCols) { SetDim_NC (dwRows, dwCols) ; } SCMat (SDataRef &ref, const t_size dwOffset, const t_size dwRows, const t_size dwCols) : t_base (ref, dwOffset, dwRows * dwCols) { SetDim_NC (dwRows, dwCols) ; } SCMat (SDataRef_Static &ref, const t_size dwOffset, const t_size dwRows, const t_size dwCols) : t_base (ref, dwOffset, dwRows * dwCols) { SetDim_NC (dwRows, dwCols) ; } SCMat (SDataRef &ref, const t_this &p) : t_base (ref, p), tb_DimCont (p) { } SCMat (SDataRef_Static &ref, const t_this &p) : t_base (ref, p), tb_DimCont (p) { } SCMat (SDataRef &ref, const tb_DimCont &p) : t_base (ref, p.size ()), tb_DimCont (p) { } SCMat (SDataRef_Static &ref, const tb_DimCont &p) : t_base (ref, p.size ()), tb_DimCont (p) { } // Data Access // inline const T &operator () (const t_size &dwRow, const t_size &dwCol) const { return Item (dwRow, dwCol) ; } inline const T &Item (const t_size &dwRow, const t_size &dwCol) const { return t_base::Item (GetIdx (dwRow, dwCol)) ; } inline const T &Item_NC (const t_size &dwRow, const t_size &dwCol) const { return t_base::Item_NC (GetIdx (dwRow, dwCol)) ; } inline const T *GetDataEnd () const { return t_base::GetDataEnd () ; } inline const T *GetData () const { return t_base::GetData () ; } inline const T *GetData (const t_size &dwRow, const t_size &dwCol) const { return t_base::GetData (GetIdx (dwRow, dwCol)) ; } inline const T *GetData_NC (const t_size &dwRow, const t_size &dwCol) const { return t_base::GetData_NC (GetIdx (dwRow, dwCol)) ; } inline const T GetValue (const t_size &dwRow, const t_size &dwCol) const { return *tb_DataCont::GetData (t_this::GetIdx (dwRow, dwCol)) ; } inline const T GetValue_NC (const t_size &dwRow, const t_size &dwCol) const { return *tb_DataCont::GetData_NC (t_this::GetIdx (dwRow, dwCol)) ; } const SCVec GetColRef (const t_size dwCol) const { ASSERT (dwCol < ncol ()) ; return SCVec (*this, GetIdx (0, dwCol), t_this::nrow ()) ; } /* const SCMat GetColsRef (t_size dwStart, t_size dwEnd) const { ASSERT (dwStart <= dwEnd) ; ASSERT (dwEnd < ncol ()) ; return SCMat (*this, GetIdx (0, dwStart), t_this::nrows () * (dwEnd - dwStart + 1)) ; } */ // Index Operations // T *IncCol_NC (T*& p) const { return p += t_this::nrows () ; } t_size &IncCol_NC (t_size & n) const { return n += t_this::nrows () ; } T *DecCol_NC (T*& p) const { return p -= t_this::nrows () ; } t_size &DecCol_NC (t_size & n) const { return n -= t_this::nrows () ; } // Dim Operations // inline const t_size GetIdx (const t_size &nRow, const t_size &nCol) const { return nRow + GetColInc () * nCol ; } inline const t_size size () const { return t_base::size () ; } inline const t_size nrow () const { return t_this::GetDim_NC (0) ; } inline const t_size ncol () const { return t_this::GetDim_NC (1) ; } inline const t_size *nrowPtr () const { return t_this::GetDimPtr_NC (0) ; } inline const t_size *ncolPtr () const { return t_this::GetDimPtr_NC (1) ; } inline const int *nrowPtrS () const { return (const int *) t_this::GetDimPtr_NC (0) ; } inline const int *ncolPtrS () const { return (const int *) t_this::GetDimPtr_NC (1) ; } const t_size GetColInc () const { return t_this::nrow () ; } const t_size GetMinDim () const { return (nrow () < ncol ()) ? nrow () : ncol () ; } const t_size GetMaxDim () const { return (nrow () > ncol ()) ? nrow () : ncol () ; } const t_size GetDimDiff () const { return nrow () - ncol () ; } protected: const t_this &operator = (const t_this &p ) const { THROW (FALSE) ;} // this MUST never be called, as you can't change a constant matrix! Thus it's protected! void SetDim (const tb_DimCont & m) { THROW (m.DimProd () <= t_base::GetSize ()) ; tb_DimCont::SetDim (m) ; } void SetDim_NC (const tb_DimCont & m) { ASSERT (m.DimProd () <= t_base::GetSize ()) ; tb_DimCont::SetDim (m) ; } void SetDim (const t_size dwRows, const t_size dwCols) { THROW (dwRows * dwCols <= t_base::GetSize ()) ; t_this::nrowRef () = dwRows ; t_this::ncolRef () = dwCols ; } void SetDim_NC (const t_size dwRows, const t_size dwCols) { ASSERT (dwRows * dwCols <= t_base::GetSize ()) ; t_this::nrowRef () = dwRows ; t_this::ncolRef () = dwCols ; } inline t_size &nrowRef () { return t_this::GetDimRef_NC (0) ; } inline t_size &ncolRef () { return t_this::GetDimRef_NC (1) ; } } ; //////////// // SMat // //////////// template class SVMat ; template class SMat : public SCMat //SMatRef//, public CDataOwner { typedef SMat t_this ; typedef SCMat tc_this ; typedef SCMat t_base ; typedef SVData tb_DataCont ; typedef CDimCont<2> tb_DimCont ; typedef SVMat tv_this ; public: typedef T t_data ; // Constructors // SMat () { } SMat (const t_this &p) : t_base (p) { } SMat (const t_size dwRows, const t_size dwCols) : t_base (dwRows, dwCols) { } SMat (T * const pData, const t_size dwRows, const t_size dwCols) : t_base (pData, dwRows, dwCols) { } SMat (SDataRef_Static &ref) : t_base (ref) { } SMat (SDataRef &ref, const t_size dwRows, const t_size dwCols) : t_base (ref, dwRows, dwCols) { } SMat (SDataRef_Static &ref, const t_size dwRows, const t_size dwCols) : t_base (ref, dwRows, dwCols) { } SMat (SDataRef &ref, const t_size dwOffset, const t_size dwRows, const t_size dwCols) : t_base (ref, dwOffset, dwRows, dwCols){ } SMat (SDataRef_Static &ref, const t_size dwOffset, const t_size dwRows, const t_size dwCols) : t_base (ref, dwOffset, dwRows, dwCols){ } SMat (SDataRef &ref, const tc_this &p) : t_base (ref, p) { } SMat (SDataRef_Static &ref, const tc_this &p) : t_base (ref, p) { } SMat (SDataRef &ref, const tb_DimCont &p) : t_base (ref, p) { } SMat (SDataRef_Static &ref, const tb_DimCont &p) : t_base (ref, p) { } SMat (const tb_DataCont &dat) : t_base (dat) { } SMat (const tb_DataCont &dat, const t_size dwRows, const t_size dwCols) : t_base (dat, dwRows, dwCols) { } SMat (const tb_DataCont &dat, const t_size dwOffset, const t_size dwRows, const t_size dwCols) : t_base (dat, dwOffset, dwRows, dwCols){ } t_this &operator = (const t_this &p ) { tb_DimCont::operator = (p) ; tb_DataCont::operator = (p) ; return *this ; } // Re-Creation / Re-structuring // void Reshape (const t_size dwRows, const t_size dwCols) { t_base::Reshape (dwRows * dwCols) ; t_this::SetDim_NC (dwRows, dwCols) ; } void Reshape_NC (const t_size dwRows, const t_size dwCols) { t_base::Reshape_NC (dwRows * dwCols) ; t_this::SetDim_NC (dwRows, dwCols) ; } void Reshape (const t_size dwOffset, const t_size dwRows, const t_size dwCols) { t_base::Reshape (dwOffset, dwRows * dwCols) ; t_this::SetDim_NC (dwRows, dwCols) ; } void Redim (const t_size dwRows, const t_size dwCols) { t_base::Redim (dwRows * dwCols) ; t_this::SetDim_NC (dwRows, dwCols) ; } void Redim_NC (const t_size dwRows, const t_size dwCols) { t_base::Redim_NC (dwRows * dwCols) ; t_this::SetDim_NC (dwRows, dwCols) ; } void Recreate (const t_size dwRows, const t_size dwCols) { t_base::Recreate (dwRows * dwCols) ; t_this::SetDim_NC (dwRows, dwCols) ; } void Require (const t_size dwRows, const t_size dwCols) { t_base::Require (dwRows * dwCols) ; t_this::SetDim_NC (dwRows, dwCols) ; } void Require (const tb_DimCont &mat) { t_base::Require (mat.DimProd ()) ; t_this::SetDim (mat) ; } // Data Access // inline T &operator () (const t_size &dwRow, const t_size &dwCol) const { return Item (dwRow, dwCol) ; } inline T &operator () (const t_size &dwIdx) const { return Item (dwIdx) ; } inline T &Item (const t_size &dwRow, const t_size &dwCol) const { return tb_DataCont::Item (t_this::GetIdx (dwRow, dwCol)) ; } inline T &Item_NC (const t_size &dwRow, const t_size &dwCol) const { return tb_DataCont::Item_NC (t_this::GetIdx (dwRow, dwCol)) ; } inline T *GetDataEnd () const { return tb_DataCont::GetDataEnd () ; } inline T *GetData () const { return tb_DataCont::GetData () ; } inline T *GetData (const t_size &dwRow, const t_size &dwCol) const { return tb_DataCont::GetData (t_this::GetIdx (dwRow, dwCol)) ; } inline T *GetData_NC (const t_size &dwRow, const t_size &dwCol) const { return tb_DataCont::GetData_NC (t_this::GetIdx (dwRow, dwCol)) ; } inline void Reset (const T &v) const { t_base::Reset (v) ; } const SVec GetColRef (t_size dwCol) const { ASSERT (dwCol < t_this::ncol ()) ; return SVec (**this, t_this::GetIdx (0, dwCol), t_this::nrow ()) ; } const t_this GetColRef (t_size dwStart, t_size dwEnd) const { ASSERT (dwStart <= dwEnd) ; ASSERT (dwEnd <= t_this::ncol ()) ; return t_this (**this, t_this::GetIdx (0, dwStart), t_this::nrow (), dwEnd - dwStart) ; } // Cast Operators // const tb_DataCont &operator *() const { return *(const tb_DataCont *) this ; } tb_DataCont &operator *() { return *( tb_DataCont *) this ; } const tv_this &operator !() const {return * (const tv_this*) this ; } tv_this &operator !() {return * ( tv_this*) this ; } operator T * () const { return GetData () ; } tc_this &Const () {return *( tc_this *) this ; } const tc_this &Const () const {return *(const tc_this *) this ; } // Copy Operations // void CopyCol (const t_size dwDest, const t_size dwSource, const tc_this &m) const { THROW (t_this::nrow () == t_this::m.nrow ()) ; THROW (dwSource < t_this::m.ncol ()) ; THROW (dwDest < t_this::ncol ()) ; CopyCol_NC (dwDest, dwSource, m) ; } void CopyCol_NC (const t_size dwDest, const t_size dwSource, const tc_this &m) const { ASSERT (t_this::nrow () == m.nrow ()) ; ASSERT (dwSource < m.ncol ()) ; ASSERT (dwDest < t_this::ncol ()) ; //::Copy (t_this::GetData (0, dwDest), m.GetData (0, dwSource), t_this::nrow ()) ; memcpy (t_this::GetData () + t_this::GetIdx (0, dwDest), m.GetData () + m.GetIdx (0, dwSource), t_this::nrow () * sizeof (T)) ; } void Copy_R (const tc_this &mat) { Require (mat) ; Copy_NC (mat) ; } void Copy (const tc_this &mat) const { THROW (this->EqualDims (mat)) ; Copy_NC (mat) ; } void Copy_NC (const tc_this &mat) const { ASSERT (this->EqualDims (mat)) ; memcpy (t_this::GetData (), mat.GetData (), t_this::GetSize () * sizeof (T)) ; } void CopyCol_Order_R (const tc_this &mat, const SSVecN &order) //2do: move to public scope { Require (mat.ncol (), order.GetSize ()) ; CopyCol_Order_NC (mat, order) ; } void CopyCol_Order (const tc_this &mat, const SSVecN &order) const { THROW (t_this::ncol () == order.GetSize ()) ; THROW (t_this::nrow () == mat.nrow ()) ; CopyCol_Order_NC (mat, order) ; } void CopyCol_Order_NC (const tc_this &mat, const SSVecN &order) const { ASSERT (t_this::ncol () == order.size ()) ; ASSERT (t_this::nrow () == mat.nrow ()) ; t_size i ; const int *pnData = order.GetData () ; for (i = order.size () - 1; i != NAI; i--) { ASSERT ((unsigned) pnData [i] < t_this::ncol ()) ; CopyCol_NC (i, pnData [i], mat) ; } } void Set (T *pData, t_size dwrow, t_size dwcol) { t_base::Set (pData, dwrow * dwcol) ; t_base::SetDim_NC (dwrow, dwcol) ; } protected: } ; template class SVMat : public SMat { typedef SMat t_base ; typedef SVMat t_this ; SVMat () {} // the constructor is private. this type cannot be created. public: t_this &operator = (const t_base &p ) { t_base::operator = (p) ; return *this ; } } ; // SCMatArray // template class SCMatArray { typedef SMat t_item ; typedef const SMat tc_item ; typedef SCMatArray t_this ; public: SCMatArray (const t_size dwRows, const t_size dwCols, const t_size dwSize) { SDataRef *pDataRef = new SDataRef (dwRows * dwCols * dwSize * sizeof (T)) ; FillMats_ND (pDataRef, dwRows, dwCols, dwSize) ; } SCMatArray (T *pData, const t_size dwRows, const t_size dwCols, const t_size dwSize) { SDataRef *pDataRef = new SDataRef (dwRows * dwCols * dwSize * sizeof (T), pData) ; FillMats_ND (pDataRef, dwRows, dwCols, dwSize) ; } SCMatArray (SDataRef_Static &ref , const t_size dwRows, const t_size dwCols, const t_size dwSize) { ref.Require (dwRows * dwCols * dwSize * sizeof (T)) ; FillMats_ND (&ref, dwRows, dwCols, dwSize) ; } SCMatArray (SDataRef &ref, const t_size dwRows, const t_size dwCols, const t_size dwSize) { THROW (ref.GetSize () <= dwRows * dwCols * dwSize * sizeof (T)) ; FillMats_ND (&ref, dwRows, dwCols, dwSize) ; } void Create (const t_size dwRows, const t_size dwCols, const t_size dwSize) { SDataRef *pDataRef = new SDataRef (dwRows * dwCols * dwSize * sizeof (T)) ; FillMats (pDataRef, dwRows, dwCols, dwSize) ; } void Create (T *pData, const t_size dwRows, const t_size dwCols, const t_size dwSize) { SDataRef *pDataRef = new SDataRef (dwRows * dwCols * dwSize * sizeof (T), pData) ; FillMats (pDataRef, dwRows, dwCols, dwSize) ; } SCMatArray () : m_apData (NULL), m_dwSize (0) { } ~SCMatArray () { t_this::Free () ; } inline tc_item &operator [] (const t_size idx) const { return Item (idx) ; } tc_item &Item (t_size idx) const { THROW (idx < t_this::GetSize ()) ; return *m_apData [idx] ; } tc_item &Item_NC (t_size idx) const { ASSERT (idx < t_this::GetSize ()) ; return *m_apData [idx] ; } const t_size &GetSize () const { return m_dwSize ; } protected: void Free () { int i ; for (i = GetSize () - 1; i != -1; i--) delete m_apData [i] ; delete [] m_apData ; m_apData = NULL ; m_dwSize = 0 ; } void FillMats (SDataRef *pDataRef, const t_size dwRows, const t_size dwCols, const t_size dwSize) { Free () ; FillMats_ND (pDataRef, dwRows, dwCols, dwSize) ; } void FillMats_ND (SDataRef *pDataRef, const t_size dwRows, const t_size dwCols, const t_size dwSize) { const t_size dwMatExt = dwRows * dwCols ; t_size dwOffset = 0 ; t_size i ; m_dwSize = dwSize ; m_apData = new t_item *[dwSize] ; for (i = 0; i < dwSize; i++) { m_apData[i] = new t_item (*pDataRef, dwOffset, dwRows, dwCols) ; dwOffset += dwMatExt ; } } t_item **m_apData ; t_size m_dwSize ; } ; typedef SCMatArray SCMatArrayD ; typedef SCMatArray SCMatArrayN ; ///////////////// // SMat Sort // basic sort routines.. ///////////////// template class CQSortComp { public: static int compare (const void * elem1, const void * elem2) { if (*(T *) elem1 < *(T *) elem2) return -1 ; if (*(T *) elem1 > *(T *) elem2) return 1 ; return 0 ; } static int compare_rev (const void * elem1, const void * elem2) { return -compare_rev (elem1, elem2) ; } static int compare_p (const void * elem1, const void * elem2) { return compare (* (T **)elem1, * (T **)elem2) ; } static int compare_p_rev (const void * elem1, const void * elem2) { return -compare (* (T **)elem1, * (T **)elem2) ; } } ; template void sme_qsort (T *p, t_size dwLen, BOOL bDecr = FALSE) { if (bDecr) qsort (p, dwLen, sizeof (T), CQSortComp::compare_rev) ; else qsort (p, dwLen, sizeof (T), CQSortComp::compare) ; } template void sme_qsortI (T *p, int *pnIdx, t_size dwLen, BOOL bDecr = FALSE) { ASSERT_TEMPRANGE (0, 0) ; SDataRef_Static &tr = tempRef (0) ; tr.Require (sm_max (sizeof (T*), sizeof (T)) * dwLen) ; T **pIdx = (T **) tr.GetData () ; t_size i = 0 ; for (i = dwLen - 1; i != NAI; i--) pIdx[i] = p + i ; if (bDecr) qsort (pIdx, dwLen, sizeof (T *), CQSortComp::compare_p_rev) ; else qsort (pIdx, dwLen, sizeof (T *), CQSortComp::compare_p) ; for (i = dwLen - 1; i != NAI; i--) pnIdx[i] = pIdx[i] - p ; //tr.Require (sizeof (T) * dwLen) , T *pBuf = (T *) tr.GetData () ; memcpy (pBuf, p, sizeof (T) * dwLen) ; for (i = dwLen - 1; i != NAI; i--) p[i] = pBuf[pnIdx[i]] ; } template t_size which_max1 (T const *p, t_size n) { T const * const pEnd = p + n ; T max = *p ; T const * pMax = p, *pCur = p + 1; for (; pCur < pEnd; ++pCur) if (sm_setmax_b (max, *pCur)) pMax = p ; return pMax - p ; } template t_size which_max1 (const SCData &a) { return which_max1 (a.GetData (), a.size ()) ; } #endif //#ifndef ES_SMAT_BASE_H pcaPP/src/ML_meal.cpp0000644000176200001440000001316113300577052014062 0ustar liggesusers/* SMat - Simple Matrix Classes v0.1beta Copyright (C) 2011 by Heinrich Fritz (heinrich_fritz@hotmail.com) This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . */ // ML_meal.cpp // MATLAB Mathematical Environment Abstraction Layer #ifdef MATLAB_MEX_FILE #include "ML_meal.h" #ifdef ES_DEV_ENV #include "../SMat/smat.h" #else #include "smat.h" #endif ///////////////////// // CRmealSettings // ///////////////////// CRmealSettings &GetRealSettings () { static CRmealSettings settings ; return settings ; } CRmealSettings::CRmealSettings () : m_szEmail ("") { } CRmealSettings::CRmealSettings (const char *szEmail) { if (szEmail) GetRealSettings ().m_szEmail = szEmail ; } void meal_geev (const char* jobvl, const char* jobvr, const int* n, double* a, const int* lda, double* wr, double* wi, double* vl, const int* ldvl, double* vr, const int* ldvr, double* work, const int* lwork, int* info) { FORTRAN_WRAPPER(dgeev)((char *) jobvl, (char *) jobvr, (int *) n, a, (int *) lda, wr, wi, vl, (int *) ldvl, vr, (int *) ldvr, work, (int *) lwork, info) ; } void meal_gemm (const char *transa, const char *transb, const int *m, const int *n, const int *k, const double *alpha, const double *a, const int *lda, const double *b, const int *ldb, const double *beta, double *c, const int *ldc) { #ifdef OLD_ML THROW (0) ; #else FORTRAN_WRAPPER(dgemm)((char *) transa, (char *)transb, (int *)m, (int *) n, (int *) k, (double *) alpha, (double *) a, (int *) lda, (double *) b, (int *) ldb, (double *) beta, (double *) c, (int *) ldc) ; #endif } void meal_dgesv (const int* n, const int* nrhs, double* a, const int* lda, int* ipiv, double* b, const int* ldb, int* info) { FORTRAN_WRAPPER(dgesv)((int *) n, (int *) nrhs, a, (int *) lda, ipiv, b, (int *) ldb, info) ; } void meal_dgesvd (const char* jobu, const char* jobvt, const int* m, const int* n, double* a, const int* lda, double* s, double* u, const int* ldu, double* vt, const int* ldvt, double* work, const int* lwork, int* info) { FORTRAN_WRAPPER(dgesvd)((char *) jobu, (char *) jobvt, (int *)m, (int *)n, a, (int *)lda, s, u, (int *)ldu, vt, (int *)ldvt, work, (int *)lwork, info) ; } void meal_sort (double *d, int l) { sme_qsort (d, l) ; } void meal_sort_order (double *d, int *o, int l) { sme_qsortI (d, o, l) ; } void meal_sort_order_rev (double *d, int *o, int l) { sme_qsortI (d, o, l, TRUE) ; } /* //////////////////////// // Random Generator // //////////////////////// void meal_PutRNGstate () { THROW(0) ; } void meal_GetRNGstate () { THROW(0) ; } double meal_unif_rand () { THROW(0) ; return 0 ; } double meal_norm_rand () { THROW(0) ; return 0 ; } double meal_exp_rand () { THROW(0) ; return 0 ; } */ //////////////////////////////////// // special values amd constants // //////////////////////////////////// double meal_NaN () { return mxGetNaN () ; } double meal_PosInf () { return mxGetInf () ; } double meal_NegInf () { return -mxGetInf (); } double meal_NaReal () { THROW (0); return 0 ; } int meal_NaInt () { THROW (0); return 0 ; } double meal_PI () { return 3.141592653589793238462643383279502884197169399375 ; } // { return utGetPI () ; } // where did utGetPI go? ////////////////////////// // printing functions // ////////////////////////// void meal_printf (const char *sz, ...) { // va_list va_l ; // further arguments not supported yet... // va_start (va_l, sz) ; mexPrintf (sz/*, va_l*/) ; } void meal_warning (const char *sz) { mexWarnMsgTxt (sz) ; } void meal_error (const char *sz) { mexErrMsgTxt (sz) ; } void *meal_alloc (size_t n, int s) { return new char [n * s] ; } void meal_free (void *p) { delete [] (char *) p ; } ////////////////// // Exceptions // ////////////////// void meal_OnException (const char * szDate, const char * szFile, int nLine) { mexPrintf ( "\n" " An exception occurred.\n" " Please contact the author (%s), providing\n" " the following details:\n" "\n" "\tR version number\n" "\tPackage version number\n" "\tBuild date:\t%s\n" "\tFile:\t\t%s\n" "\tLine:\t\t%d\n" "\n" " If possible please include the code which caused this error, including\n" " eventual source data and the state of the random generator (seed) before\n" " experiencing this issue.\n" "\n" "\tYour contribution is appreciated!\n\n", GetRealSettings ().GetEmail (), szDate, szFile, nLine) ; meal_error ("An exception has occurred.") ; } void meal_OnUException () { mexPrintf ( "\n" " An unknown exception occurred.\n" " Please contact the author (%s), providing\n" " the following details:\n" "\n" "\tR version number\n" "\tPackage version number\n" "\n" " If possible please include the code which caused this error, including\n" " eventual source data and the state of the random generator (seed) before\n" " experiencing this issue.\n\n" "\n" "\tYour contribution is appreciated!\n\n", GetRealSettings ().GetEmail ()) ; meal_error ("An unknown exception has occurred.") ; } #endif // #ifdef MATLAB_MEX_FILE pcaPP/src/PCAproj.cpp0000644000176200001440000001607413300577052014060 0ustar liggesusers#include "PCAproj.h" void vec_mult_mat_t_partial (double *pA, double const *pB, double const *pC, const int n, const int p, const int nDimN) { // calculates // // pA <- pB %*% t (pC[1:n, ]) // with pA: a result vector of length n // pB: a vector of length p // pC: a matrix of dimension nDimN x p // with n <= nDimN THROW (n <= nDimN) ; const t_size dwJump = nDimN - n ; double const *const pEndC = pC + nDimN * p ; double * const pStartA = pA, * const pEndA = pA + n ; for (; pA < pEndA; ++pA) *pA = 0 ; while (pC < pEndC) { pA = pStartA ; while (pA < pEndA) { *pA += *pB * *pC ; ++pA ; ++pC ; } pC += dwJump ; ++pB ; } } CPCAproj::CPCAproj (int *pnParIn, double *pdParIn, double *pdX, double *pdZ, double *pdL, double *pdSDev) : m_dwN (pnParIn[0]), m_dwP (pnParIn[1]), m_dwRealN (pnParIn[2]), m_dwK (pnParIn[3]) , m_nScal (pnParIn[4]), m_nScores (pnParIn[5]) , m_dZeroTol (pdParIn [0]), m_dCurLambda (0) , m_mX (pdX, m_dwN, m_dwP), m_mL (pdL, m_dwP, m_dwK), m_mA (m_dwN, m_dwP) , m_vSDev (pdSDev, m_dwK), m_vCurScore (m_dwN) , m_vHelpTF (m_dwN) { if (m_nScores) m_mZ.Set (pdZ, m_dwRealN, m_dwK) ; } void NULL1 (const SMatD &a) // takes a pxp loadings matrix, where the last column is not filled, and computes this last column { ASSERT_TEMPRANGE (0, 1) ; ASSERT (a.nrow () == a.ncol ()) ; t_size p = a.nrow () ; const SVecD &vLastCol = a.GetColRef (p-1) ; const SMatD mLpm1 (a.GetColRef (0, p - 1)) ; vLastCol.Reset (1) ; EO::VMc (*vLastCol, mLpm1) ; EO::V (*vLastCol) ; int n = which_max1 (vLastCol) ; SVecD vTemp1 (tempRef (0), p - 1), vTemp2 (tempRef (1), p) ; CopyRow (*vTemp1, mLpm1, n) ; // 2do: implement SnVec -> no copy.. vTemp2.Reset (0) ; EO::VMcVct_NC (*vTemp2, mLpm1, vTemp1) ; vTemp2(n) *= -1.0 ; // for not triggering element n in the next line, which is positive by default... EO::VVc (*vLastCol, vTemp2) ; // assigns the negative signs of vector vTemp2 to vector vCurEVec (assuming that vCurEVec has only positive elemts) } void CPCAproj::SetSingular (t_size dwK) { m_mZ.GetColRef (dwK, m_dwK).Reset (0) ; m_vSDev.GetDataRef (dwK, m_dwK).Reset (0) ; if (!dwK) SetDiag (!m_mL) ; else m_vSDev.GetDataRef (dwK, m_dwK).Reset (-1) ; // sets the sdev to -1, indicating, that the according columns of the Loadings Matrix are invalid! } void CPCAproj::Calc () { SVecD vPcol (m_dwN), vVH (m_dwP), vHlp (m_dwN), vHlpS (vHlp) ; SVecD vCurA (tempRef (0), m_dwP) ; SVecD vCurScoreS (*m_vCurScore, m_dwRealN) ; //double *pdCurLambda = m_vSDev ; t_size i, j ; for (i = 0; i < m_dwK; i++) { const SVecD &vCurEVec = m_mL.GetColRef (i) ; vHlp.Reset (0) ; EO::VMc (*vHlp, m_mX) ; //R vHlp <- rowSums (mY^2) m_dwShortN = 0 ; EO::SVScVc (m_dwShortN, *m_vHelpTF, m_dZeroTol, vHlp) ; //R m_vHelpTF <- (vHlp>dZeroTol); m_dwShortN <- sum () if (!m_dwShortN) // all observations seem to be concentrated in one point (in the center) when considering the current subspace { SetSingular (i) ; return ; } vHlpS.Reshape (m_dwShortN) ; m_mA.Reshape (m_dwShortN, m_dwP) ; EO::V (*vHlp) ; //R vHlp <- sqrt (vHlp) EO::MsMcVcVbc (!m_mA, m_mX, vHlp, m_vHelpTF) ; //R m_mA <- (m_mX / vHlp)[m_vHelpTF,] m_vCurScore.Reshape (m_dwRealN) ; if (i < m_dwP - 1) { t_size dwBestj = NAI; //for (j = 0; j < m_dwShortN; ++j) for (j = m_dwShortN - 1; j != NAI; --j) { CopyRow (*vCurA, m_mA, j) ; //R vCurA <- m_mA[j, ] vec_mult_mat_t_partial (m_vCurScore, vCurA, m_mX, m_dwRealN, m_dwP, m_dwN) ; //R m_vCurScore <- vCurA %*% m_mX[1:m_dwRealN,] //RR Y =A %*% t(y[1:n,]); double dScat = ApplyMethod (m_vCurScore, m_nScal) ; //R dScat = fscale (m_vCurScore) //RR pcol = apply (Y, 1, fs) if (dwBestj == NAI || m_dCurLambda < dScat) { dwBestj = j ; //RR istar <- which.max (pcol) m_dCurLambda = dScat ; //RR lambda[i] <- pcol[istar] } } CopyRow (*vCurEVec, m_mA, dwBestj) ; //R vCurEVec <- m_mA[dwBestj,] //RR vhelp <- A[istar,] m_vCurScore.Reshape (m_dwN) ; m_vCurScore.Reset (0) ; EO::VMcVct (*m_vCurScore, m_mX, vCurEVec) ; //R m_vCurScore <- m_mX %*% vCurEVec //RR scorevec <- y%*%(A[istar,]) Update (vCurEVec) ; if (m_nScores) Copy (*m_mZ.GetColRef (i), vCurScoreS) ; if (i < m_dwK - 1) EO::MVcVct (!m_mX, m_vCurScore, vCurEVec) ; //R m_mX <- m_mX - m_vCurScore %*% vCurEVec m_vSDev (i) = m_dCurLambda ; // *pdCurLambda = m_dCurLambda ; // ++pdCurLambda ; } else { NULL1 (m_mL) ; // computes the last eigenvector (loadings vector) in m_mL m_vCurScore.Reshape (m_dwN) ; m_vCurScore.Reset (0) ; EO::VMcVct (*m_vCurScore, m_mX, vCurEVec) ; //R m_vCurScore <- m_mX %*% vCurEVec //RR scorevec <- y%*%(A[istar,]) // 2do -> pass this to BLAS //*pdCurLambda = m_vSDev (i) = ApplyMethod (m_vCurScore, m_nScal) ; //R dCurLambda = fscale (m_vCurScore) if (m_nScores) Copy (*m_mZ.GetColRef (i), vCurScoreS) ; } } } CPCAprojU::CPCAprojU (int *pnParIn, double *pdParIn, double *pdX, double *pdZ, double *pdL, double *pdSDev) : CPCAproj (pnParIn, pdParIn, pdX, pdZ, pdL, pdSDev) , m_dwMaxIt (pnParIn[6]), m_dwMaxHalf (pnParIn[7]) {} void CPCAprojU::Update (const SVecD &vCurEVec) { ASSERT_TEMPRANGE (11, 12) ; t_size m, kk ; SVecN vScoreSign (tempRef (0), m_dwShortN) ; SVecD vVH (tempRef (11), m_dwP), vTScores (tempRef (12), m_dwN) ; for (m = m_dwMaxIt; m ; --m) { EO::VsVcVbc (*vScoreSign, m_vCurScore, m_vHelpTF) ; //R vScoreSign <- sign (vScoreSign [m_vHelpTF]) vVH.Reset (0) ; //R { EO::VtMcVc (*vVH, m_mA, vScoreSign) ; //R vVH <- t (m_mA) %*% vScoreSignS double dNewObj, dSqSum = 0 ; //R dSqSum <- sum (vVH^2) EO::SVc (dSqSum, vVH) ; //R } // ... // this part of the original R source has been merged with the following for loop // ... for (kk = 0; kk <= m_dwMaxHalf; ++kk) { if (kk) { dSqSum = 0 ; //R vVH <- (vVH + vCurEVec) / 2 EO::SVVc (dSqSum, *vVH, vCurEVec) ; //R dSqSum <- sum (vVH^2) } EO::VSc (*vVH, sqrt (dSqSum)) ; //R vVH <- vVH / sqrt (dSqSum) vTScores.Reset (0) ; //R EO::VMcVct (*vTScores, m_mX, vVH) ; //R VTScores <- mX %*% vVH dNewObj = ApplyMethod (vTScores, m_nScal) ; //R dNewObj <- fscale (vTScores) if (dNewObj >= m_dCurLambda) break ; } if (dNewObj < m_dCurLambda) break ; Copy (*m_vCurScore, vTScores) ; //R m_vCurScore <- vTScores Copy (*vCurEVec, vVH) ; //R vCurEVec <- vVH m_dCurLambda = dNewObj; } } pcaPP/src/smat.matop.h0000644000176200001440000001332713300577052014310 0ustar liggesusers/* SMat - Simple Matrix Classes v0.1beta Copyright (C) 2011 by Heinrich Fritz (heinrich_fritz@hotmail.com) This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . */ #ifndef SMAT_MATOP_H #define SMAT_MATOP_H void sme_matmult_R (const SCMatD &a, const SCMatD &b, SVMatD &c) ; void sme_matmult (const SCMatD &a, const SCMatD &b, const SVMatD &c) ; void sme_matmult_NC (const SCMatD &a, const SCMatD &b, const SVMatD &c) ; void sme_tmatmult_R (const SCMatD &a, const SCMatD &b, SVMatD &c, const BOOL bTransA, const BOOL bTransB) ; void sme_tmatmult (const SCMatD &a, const SCMatD &b, const SVMatD &c, const BOOL bTransA, const BOOL bTransB) ; void sme_tmatmult_NC (const SCMatD &a, const SCMatD &b, const SVMatD &c, const BOOL bTransA, const BOOL bTransB) ; void sme_matmult_a_at_R (const SCMatD &a, SVMatD &b, BOOL bTransA) ; void sme_matmult_a_at (const SCMatD &a, const SVMatD &b, BOOL bTransA) ; void sme_matmult_a_at_NC (const SCMatD &a, const SVMatD &b, BOOL bTransA) ; void sme_matmult_a_b_at_R (const SCMatD &a, const SCMatD &b, SVMatD &c, BOOL bTransA = FALSE, BOOL bTransB = FALSE) ; void sme_matmult_a_b_at (const SCMatD &a, const SCMatD &b, SVMatD &c, BOOL bTransA = FALSE, BOOL bTransB = FALSE) ; void sme_matmult_a_b_at_NC (const SCMatD &a, const SCMatD &b, SVMatD &c, BOOL bTransA = FALSE, BOOL bTransB = FALSE) ; void sme_matmult_a_diagb_at_R (const SCMatD &a, const SCVecD &b, SVMatD &c) ; void sme_matmult_a_diagb_at (const SCMatD &a, const SCVecD &b, const SVMatD &c) ; void sme_matmult_a_diagb_at_NC (const SCMatD &a, const SCVecD &b, const SVMatD &c) ; void sme_matmult_at_diagb_a_R (const SCMatD &a, const SCVecD &b, SVMatD &c) ; void sme_matmult_at_diagb_a (const SCMatD &a, const SCVecD &b, const SVMatD &c) ; void sme_matmult_at_diagb_a_NC (const SCMatD &a, const SCVecD &b, const SVMatD &c) ; void sme_matmult_diag_R (const SCMatD &a, const SCMatD &b, SVecD &c) ; // C <- diag (A %*% B) void sme_matmult_diag (const SCMatD &a, const SCMatD &b, const SVecD &c) ; // C <- diag (A %*% B) void sme_matmult_diag_NC (const SCMatD &a, const SCMatD &b, const SVecD &c) ; // C <- diag (A %*% B) # NC void sme_sum_matmult_diag (const SCMatD &a, const SCMatD &b, double &c) ; // C <- sum (C <- diag (A %*% B)) void sme_sum_matmult_diag_NC (const SCMatD &a, const SCMatD &b, double &c) ; // C <- sum (C <- diag (A %*% B)) # NC double sme_sum_matmult_diag (const SCMatD &a, const SCMatD &b) ; double sme_sum_matmult_diag_NC (const SCMatD &a, const SCMatD &b) ; double sme_sum_diag_At_matmult_B ( const SCMatD &a, const SCMatD &b) ; double sme_sum_diag_At_matmult_B_NC ( const SCMatD &a, const SCMatD &b) ; void sme_sum_diag_Bt_matmult_C (double &a, const SCMatD &b, const SCMatD &c) ; void sme_sum_diag_Bt_matmult_C_NC (double &a, const SCMatD &b, const SCMatD &c) ; void sme_diag_R (const SVMatD &a, SVecD &c) ; // 2do: make this a template function void sme_diag (const SVMatD &a, SVecD &c) ; void sme_diag_NC (const SVMatD &a, SVecD &c) ; ////////////////////////// // Matrix Diagonals // ////////////////////////// template void SetDiag_R (SVMat &a, const SCData &b) { a.Require (b.size (), b.size ()) ; SetDiag_NC (a, b) ; } template void SetDiag (const SVMat &a, const SCData &b) { THROW (a.ncol() == b.size ()) ; THROW (a.nrow() == b.size ()) ; SetDiag_NC (a, b) ; } template void SetDiag_NC (const SVMat &a, const SCData &b) { //2do: implement for non square matrices! ASSERT (a.ncol() == b.size ()) ; ASSERT (a.nrow() == b.size ()) ; t_size i, j ; double *pA = a.GetDataEnd () ; const double *pB = b.GetDataEnd () ; for (i = a.ncol () - 2; i != NAI; i--) { *--pA = *--pB ; for (j = a.ncol () - 1; j != NAI; j--) *--pA = 0 ; } *--pA = *--pB ; } template void SetDiag (const SVMat &a) { t_size dwR, dwC ; t_size const dwREnd = a.nrow () ; TA * pA = a ; TA const * const pAEnd = a.GetDataEnd () ; for (dwC = 0; pA < pAEnd; ++dwC) for (dwR = 0; dwR < dwREnd; ++dwR) { *pA = (dwC == dwR) ? 1.0 : 0.0 ; ++pA ; } } template void SetDiag_sq (const SVMat &a) { THROW (a.ncol () == a.nrow ()) ; SetDiag_sq_NC (a) ; } template void SetDiag_sq_NC (const SVMat &a) { ASSERT (a.ncol () == a.nrow ()) ; const t_size inc = a.GetColInc () ; TA *pA = a ; TA *pEndA = a.GetDataEnd () ; //pA + a.nrow () * a.ncol () ; *pA = 1 ; ++pA ; for (; pA < pEndA;) { pA = Reset (pA, pA + inc) ; *pA = 1 ; ++pA ; } // Reset (pA, a.GetDataEnd ()) ; } template void SetAntiDiag_sq (const SVMat &a) { THROW (a.ncol () == a.nrow ()) ; SetAntiDiag_sq_NC (a) ; } template void SetAntiDiag_sq_NC (const SVMat &a) { ASSERT (a.ncol () == a.nrow ()) ; const t_size inc = a.GetColInc () - 2 ; TA *pA = a ; TA *pEndA = pA + a.nrow () * (a.ncol () - 1) + 1 ; *pA = 0 ; ++pA ; for (; pA < pEndA; ++pA) { pA = Reset (pA, pA + inc) ; *pA = 1 ; } Reset (pA, a.GetDataEnd ()) ; } #endif // #ifndef SMAT_MATOP_H pcaPP/src/cov.kendall.cpp0000644000176200001440000002527513300577052014765 0ustar liggesusers/* This file contains code to calculate Kendall's Tau in O(N log N) time in * a manner similar to the following reference: * * A Computer Method for Calculating Kendall's Tau with Ungrouped Data * William R. Knight Journal of the American Statistical Association, Vol. 61, * No. 314, Part 1 (Jun., 1966), pp. 436-439 * * Copyright 2010 David Simcha * * License: * Boost Software License - Version 1.0 - August 17th, 2003 * * Permission is hereby granted, free of charge, to any person or organization * obtaining a copy of the software and accompanying documentation covered by * this license (the "Software") to use, reproduce, display, distribute, * execute, and transmit the Software, and to prepare derivative works of the * Software, and to permit third-parties to whom the Software is furnished to * do so, all subject to the following: * * The copyright notices in the Software and this entire statement, including * the above license grant, this restriction and the following disclaimer, * must be included in all copies of the Software, in whole or in part, and * all derivative works of the Software, unless such copies or derivative * works are solely in the form of machine-executable object code generated by * a source language processor. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE, TITLE AND NON-INFRINGEMENT. IN NO EVENT * SHALL THE COPYRIGHT HOLDERS OR ANYONE DISTRIBUTING THE SOFTWARE BE LIABLE * FOR ANY DAMAGES OR OTHER LIABILITY, WHETHER IN CONTRACT, TORT OR OTHERWISE, * ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER * DEALINGS IN THE SOFTWARE. * */ #include #include #include #include uint64_t insertionSort(double*, size_t); //#define kendallTest #ifdef kendallTest #include #include #include /* Kludge: In testing mode, just forward R_rsort to insertionSort to make this * module testable without having to include (and compile) a bunch of other * stuff. */ void R_rsort(double* arr, int len) { insertionSort(arr, len); } #else #include /* For R_rsort. */ #endif /* Sorts in place, returns the bubble sort distance between the input array * and the sorted array. */ uint64_t insertionSort(double* arr, size_t len) { size_t maxJ, i; uint64_t swapCount = 0; if(len < 2) { return 0; } maxJ = len - 1; for(i = len - 2; i < len; --i) { size_t j = i; double val = arr[i]; for(; j < maxJ && arr[j + 1] < val; ++j) { arr[j] = arr[j + 1]; } arr[j] = val; swapCount += (j - i); } return swapCount; } static uint64_t merge(double* from, double* to, size_t middle, size_t len) { size_t bufIndex, leftLen, rightLen; uint64_t swaps; double* left; double* right; bufIndex = 0; swaps = 0; left = from; right = from + middle; rightLen = len - middle; leftLen = middle; while(leftLen && rightLen) { if(right[0] < left[0]) { to[bufIndex] = right[0]; swaps += leftLen; rightLen--; right++; } else { to[bufIndex] = left[0]; leftLen--; left++; } bufIndex++; } if(leftLen) { memcpy(to + bufIndex, left, leftLen * sizeof(double)); } else if(rightLen) { memcpy(to + bufIndex, right, rightLen * sizeof(double)); } return swaps; } /* Sorts in place, returns the bubble sort distance between the input array * and the sorted array. */ uint64_t mergeSort(double* x, double* buf, size_t len) { uint64_t swaps; size_t half; if(len < 10) { return insertionSort(x, len); } swaps = 0; if(len < 2) { return 0; } half = len / 2; swaps += mergeSort(x, buf, half); swaps += mergeSort(x + half, buf + half, len - half); swaps += merge(x, buf, half, len); memcpy(x, buf, len * sizeof(double)); return swaps; } static uint64_t getMs(double* data, size_t len) { /* Assumes data is sorted.*/ uint64_t Ms = 0, tieCount = 0; size_t i; for(i = 1; i < len; i++) { if(data[i] == data[i-1]) { tieCount++; } else if(tieCount) { Ms += (tieCount * (tieCount + 1)) / 2; tieCount++; tieCount = 0; } } if(tieCount) { Ms += (tieCount * (tieCount + 1)) / 2; tieCount++; } return Ms; } /* This function calculates the Kendall covariance (if cor == 0) or * correlation (if cor != 0), but assumes arr1 has already been sorted and * arr2 has already been reordered in lockstep. This can be done within R * before calling this function by doing something like: * * perm <- order(arr1) * arr1 <- arr1[perm] * arr2 <- arr2[perm] */ double kendallNlogN(double* arr1, double* arr2, size_t len, int cor) { uint64_t m1 = 0, m2 = 0, tieCount, swapCount, nPair; int64_t s; size_t i; nPair = (uint64_t) len * ((uint64_t) len - 1) / 2; s = nPair; tieCount = 0; for(i = 1; i < len; i++) { if(arr1[i - 1] == arr1[i]) { tieCount++; } else if(tieCount > 0) { R_rsort(arr2 + i - tieCount - 1, tieCount + 1); m1 += tieCount * (tieCount + 1) / 2; s += getMs(arr2 + i - tieCount - 1, tieCount + 1); tieCount++; tieCount = 0; } } if(tieCount > 0) { R_rsort(arr2 + i - tieCount - 1, tieCount + 1); m1 += tieCount * (tieCount + 1) / 2; s += getMs(arr2 + i - tieCount - 1, tieCount + 1); tieCount++; } swapCount = mergeSort(arr2, arr1, len); m2 = getMs(arr2, len); s -= (m1 + m2) + 2 * swapCount; if(cor) { double denominator1 = nPair - m1; double denominator2 = nPair - m2; double cor = s / sqrt(denominator1) / sqrt(denominator2); return cor; } else { /* Return covariance. */ return 2 * s; } } /* This function uses a simple O(N^2) implementation. It probably has a smaller * constant and therefore is useful in the small N case, and is also useful * for testing the relatively complex O(N log N) implementation. */ double kendallSmallN(double* arr1, double* arr2, size_t len, int cor) { /* Not using 64-bit ints here because this function is meant only for small N and for testing. */ int m1 = 0, m2 = 0, s = 0, nPair; size_t i, j; double denominator1, denominator2; for(i = 0; i < len; i++) { for(j = i + 1; j < len; j++) { if(arr2[i] > arr2[j]) { if (arr1[i] > arr1[j]) { s++; } else if(arr1[i] < arr1[j]) { s--; } else { m1++; } } else if(arr2[i] < arr2[j]) { if (arr1[i] > arr1[j]) { s--; } else if(arr1[i] < arr1[j]) { s++; } else { m1++; } } else { m2++; if(arr1[i] == arr1[j]) { m1++; } } } } nPair = len * (len - 1) / 2; if(cor) { denominator1 = nPair - m1; denominator2 = nPair - m2; return s / sqrt(denominator1) / sqrt(denominator2); } else { /* Return covariance. */ return 2 * s; } } #ifdef kendallTest int main() { double a[100], b[100]; double smallNCor, smallNCov, largeNCor, largeNCov; int i; /* Test the small N version against a few values obtained from the old * version in R. Only exercising the small N version because the large * N version requires the first array to be sorted and the second to be * reordered in lockstep before it's called.*/ { double a1[] = {1,2,3,5,4}; double a2[] = {1,2,3,3,5}; assert(kendallSmallN(a1, a2, 5, 1) - 0.7378648 < 0.00001); assert(kendallSmallN(a1, a2, 5, 0) == 14); double b1[] = {8,6,7,5,3,0,9}; double b2[] = {3,1,4,1,5,9,2}; assert(kendallSmallN(b1, b2, 7, 1) + 0.39036 < 0.00001); assert(kendallSmallN(b1, b2, 7, 0) == -16); double c1[] = {1,1,1,2,3,3,4,4}; double c2[] = {1,2,1,3,3,5,5,5}; assert(kendallSmallN(c1, c2, 8, 1) - 0.8695652 < 0.00001); assert(kendallSmallN(c1, c2, 8, 0) == 40); } /* Now that we're confident that the simple, small N version works, * extensively test it against the much more complex and bug-prone * O(N log N) version. */ for(i = 0; i < 10000; i++) { int j, len; for(j = 0; j < 100; j++) { a[j] = rand() % 30; b[j] = rand() % 30; } len = rand() % 50 + 50; /* The large N version assumes that the first array is sorted. This * will usually be made true in R before passing the arrays to the * C functions. */ insertionSort(a, len); if(i & 1) { /* Test correlation on odd iterations, covariance on even ones. * Can't test both on every iteration because the large N * impl destroys the contents of the arrays passed in.*/ smallNCor = kendallSmallN(a, b, len, 1); largeNCor = kendallNlogN(a, b, len, 1); assert(largeNCor == smallNCor); } else { smallNCov = kendallSmallN(a, b, len, 0); largeNCov = kendallNlogN(a, b, len, 0); assert(largeNCov == smallNCov); } } printf("Passed all tests.\n"); /* Speed test. Compare the O(N^2) version, which is very similar to * R's current impl, to my O(N log N) version. */ { const int N = 30000; double *foo, *bar, *buf; size_t i; double startTime, stopTime; foo = (double*) malloc(N * sizeof(double)); bar = (double*) malloc(N * sizeof(double)); for(i = 0; i < N; i++) { foo[i] = rand(); bar[i] = rand(); } startTime = clock(); kendallSmallN(foo, bar, N, 1); stopTime = clock(); printf("O(N^2) version: %f milliseconds\n", stopTime - startTime); startTime = clock(); /* Only sorting first array. Normally the second one would be * reordered in lockstep. */ buf = (double*) malloc(N * sizeof(double)); mergeSort(foo, buf, N); kendallNlogN(foo, bar, N, 1); stopTime = clock(); printf("O(N log N) version: %f milliseconds\n", stopTime - startTime); } return 0; } #endif pcaPP/src/L1Median_HoCr.cpp0000644000176200001440000000541113300577052015060 0ustar liggesusers#include "L1Median.h" double calObj (const SCMatD &mXc, const SCVecD &vMed) { ASSERT_TEMPRANGE (0, 0) ; SVecD vTemp (tempRef (0), mXc.nrow ()) ; vTemp.Reset (0) ; EO::VMcVct_NC (*vTemp, mXc, vMed) ; double dSum = 0 ; EO::SVc (dSum, vTemp) ; return dSum ; } int l1median_HoCr (const SCMatD &mX, const SVecD &vdMedian, double dZeroTol, double dTol, int dwMaxit, int nTrace, int *pdwIterCount) { const double dLog2 = log ((double) 2.0) ; const int n = mX.nrow (), &p = mX.ncol () ; SVecD vdMedianOld (p), vdNorms (n), vdNormsOrdered, vdWeights (n), vdDelta (p) ; SMatD mXc (n, p) ; SVecN vinter (n) ; int nK, &k = pdwIterCount ? *pdwIterCount : nK, dwNStep, dwMaxHalf = 0 ; double * pdNorms, * const pdStartNorms = vdNorms, * const pdEndNorms = vdNorms.GetDataEnd (), * const pdNormsHalf = pdStartNorms + ((n + 1) >> 1) ; double * const pdWeights = vdWeights ; int *pnOrder, * const pnStartOrder = vinter ; double dND, dObj, dObjOld = 0 ; for (k = 0; k < dwMaxit; k++) { vdNorms.Reset (0) ; EO::MVMcVct (!mXc, *vdNorms, mX, vdMedian) ; if (!k) // in the first round we (cheaply) calculate the "old" (=initial) objective function's value, as half of it we've already calculated with vector "vdNorms" EO::SVc (dObjOld, vdNorms) ; sort_order (*vdNorms, *vinter) ; double dSumWeights = 0 ; pnOrder = pnStartOrder ; pdNorms = pdStartNorms ; while (pdNorms < pdEndNorms) { // if (*pdNorms <= dZeroTol) if (*pdNorms <= 0) { pdWeights[*pnOrder] = 0 ; if (pdNorms > pdNormsHalf) // there's more than half of the values concentrated at the current median estimation -> return this estimation return 3 ; } else dSumWeights += (pdWeights[*pnOrder] = pow (*pdNorms, -0.5)) ; ++pdNorms ; ++pnOrder ; } vdDelta.Reset (0) ; EO::VtMcVc (*vdDelta, mXc, vdWeights) ; dND = 0 ; EO::SVSc(dND, *vdDelta, dSumWeights) ; dND = sqrt (dND) ; if (nTrace >= 3) meal_printf ("nd at %g in iteration %d (tol at %g)\r\n", dND, k, dTol) ; vdMedianOld.Copy_NC (vdMedian) ; EO::VVc_NC (*vdMedian, vdDelta) ; dObj = calObj (mX, vdMedian) ; if (dND < dTol) // converged return 0 ; dwMaxHalf = (int) ceil (log (dND / dTol) / dLog2) ; for (dwNStep = dwMaxHalf; dObj >= dObjOld; --dwNStep) // do step-halving { EO::VSc (*vdDelta, 2) ; EO::VVcVc_NC (*vdMedian, vdMedianOld, vdDelta) ; dObj = calObj (mX, vdMedian) ; if (!dwNStep) { vdMedian.Copy (vdMedianOld) ; dObj = dObjOld ; return 2 ; // step-halving failed } } dObjOld = dObj ; } return 1 ; // did not converge } pcaPP/src/perftimer.h0000644000176200001440000000071413300577052014216 0ustar liggesusers#include "time.h" // 2do: move this file to a util directory! class CPerfTimer { public: CPerfTimer () : m_start (clock ()) {} void Restart () { m_start = clock () ; } int GetTimeMS () { return FormatTimeMS (clock ()) ; } int FormatTimeMS (clock_t end) { end -= m_start ; if (CLOCKS_PER_SEC != 1000) end = (clock_t) ((end * 1000.0 / CLOCKS_PER_SEC)) ; return int (end) ; } protected: clock_t m_start ; } ; pcaPP/src/smat.misc.h0000644000176200001440000001347413300577052014126 0ustar liggesusers/* SMat - Simple Matrix Classes v0.1beta Copyright (C) 2011 by Heinrich Fritz (heinrich_fritz@hotmail.com) This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . */ #ifndef SMAT_MISC_H #define SMAT_MISC_H #include "smat.base.h" #include "smat.elop.h" ///////////////////// // Min Max Limit // ///////////////////// template void limit (const SVData &a, const TA &l, const TA &u) { THROW (l <= u) ; limit_nc (a, l, u) ; } template void limit_NC (const SVData &a, const TB &l, const TC &u) { ASSERT (l <= u) ; EO::VScSc (a, l, u) ; } template void limit_l (const SVData &a, const TB &l) { EO::VSc (a, l) ; } template void limit_u (const SVData &a, const TB &u) { EO::VSc (a, u) ; } template const TA &max (const SCData &a) { return EO::Vc_transitive (a) ; } template const TA &min (const SCData &a) { return EO::Vc_transitive (a) ; } template void minmax (const SCData &a, TA &min, TA &max, BOOL bInit= TRUE) { if (!a.size ()) return ; if (bInit) { const double *pA = a ; min = max = *pA ; EO::SSVc_raw (min, max, pA + 1, a.GetDataEnd ()) ; } else EO::SSVc (min, max, a) ; } template t_size getMaxIdx (const SCData &a) { t_size idx = 0 ; EO::SVc (idx, a) ; return idx ; } template TA min (const TA *pA, t_size n) { return min (pA, pA + n) ; } template TA min (const TA *pA, TA const * const pEndA) { TA min = *pA ; for (++pA; pA < pEndA; ++pA) if (*pA < min) min = * pA ; return min ; } template const TA *minP (const TA *pA, t_size n) { return minP (pA, pA + n) ; } template const TA *minP (const TA *pA, TA const * const pEndA) { const TA *pMin = pA ; for (++pA; pA < pEndA; ++pA) if (*pA < *pMin) pMin = pA ; return pMin ; } template const TA max (const TA *pA, t_size n) { return max (pA, pA + n) ; } template const TA max (const TA *pA, TA const * const pEndA) { TA max = *pA ; for (++pA; pA < pEndA; ++pA) if (*pA > max) max = *pA ; return max ; } template const TA *maxP (const TA *pA, t_size n) { return maxP (pA, pA + n) ; } template const TA *maxP (const TA *pA, TA const * const pEndA) { const TA *pMax = pA ; for (++pA; pA < pEndA; ++pA) if (*pA > *pMax) pMax = pA ; return pMax ; } //////////// // Misc // //////////// template void set_neg (const SVData &a) { // EO::vd (a) ; EO::V (a) ; } template void set_inv (const SVData &a) { // EO::vd (a) ; EO::V (a) ; } template BOOL equal (const SCData &a, const SCData &b) { if (a.size () != b.size ()) return FALSE ; TA const *pA = a ; TA const * const pEndA = a.GetDataEnd () ; TB const *pB = b ; while (pA < pEndA) { if (*pA != *pB) return FALSE ; ++pA ; ++pB ; } return TRUE ; } template t_size CountMatches (const SCData &a, const TB &b) { t_size n = 0 ; EO::SScVc (n, b, a) ; return n ; } template t_size CountTrue (const SCData &a) { t_size n = 0 ; EO::SVc(n, a) ; return n ; } ////////////////////////// // Printing Functions // ////////////////////////// void Print (const double &v) ; void Print (const float &v) ; void Print (const int &v) ; void Print (const t_size &v) ; template void Print_NC (const t_size dwRe, const SCMat &a, const t_size dwCe) { Print_NC (0, dwRe, a, 0, dwCe) ; } template void Print_NC (const SCMat &a, const t_size dwCs, const t_size dwCe) { Print_NC (0, a.nrow (), a, dwCs, dwCe) ; } template void Print_NC (const t_size dwRs, const t_size dwRe, const SCMat &a) { Print_NC (dwRs, dwRe, a) ; } template void Print_NC (const SCMat &a, const t_size dwCe) { Print_NC (0, a.nrow (), a, 0, dwCe) ; } template void Print_NC (const t_size dwRe, const SCMat &a) { Print_NC (0, dwRe, a, 0, a.ncol ()) ; } template void Print_NC (const SCMat &a) { Print_NC (0, a.nrow (), a, 0, a.ncol ()) ; } template void Print_NC (const t_size dwRs, const t_size dwRe, const SCMat &a, const t_size dwCs, const t_size dwCe) { ASSERT (dwRs <= dwRe) ; ASSERT (dwCs <= dwCe) ; ASSERT (dwRe <= a.nrow ()) ; ASSERT (dwCe <= a.ncol ()) ; t_size r, c ; const TA *pA ; for (r = dwRs; r < dwRe; ++r) { pA = a.GetData (r, dwCs) ; for (c = dwCs; c < dwCe; ++c) { Print (*pA) ; meal_printf ("\t") ; pA += a.GetColInc () ; } meal_printf ("\n") ; } meal_printf ("\n") ; } template void Print_NC (const SCData &a) { const TA *pA = a, * const pEndA = a.GetDataEnd () ; while (pA < pEndA) { Print (*pA) ; meal_printf ("\t") ; ++pA ; } meal_printf ("\n") ; } #endif // #ifndef SMAT_MISC_H pcaPP/src/R_package.cpp0000644000176200001440000000617213300577052014434 0ustar liggesusers#ifdef R_PACKAGE_FILE #include "R_package.h" #include "cov.kendall.h" #include "PCAgrid.h" #include "PCAproj.h" #include "outSDo.h" #include "L1Median.h" #include "qnn.h" #ifdef ES_DEV_ENV #include "..\..\..\RDev\perftimer.h" #include "..\..\..\RDev\R_meal.h" #else #include "perftimer.h" #include "R_meal.h" #endif // #ifdef ES_DEV_ENV //R_MEAL_SETTINGS ("P.Filzmoser@tuwien.ac.at") ; // settings for the R meal - implementation R_MEAL_SETTINGS ("Heinrich_Fritz@hotmail.com") ; // settings for the R meal - implementation //////////////////////////////// // exporting functions to R // //////////////////////////////// #ifndef ES_DEV_ENV void C_kendallNlogN (double* arr1, double* arr2, int *pnPar, double *dRet) // 2do: wrap other fct (N^2) too; make choice depending on n (pnPar[0]) { TRY( *dRet = kendallNlogN (arr1, arr2, // arr1, arr2 (size_t) pnPar[0], // length pnPar[1]) ; // cor ) } #endif void C_PCAgrid (int *pnParamIn, int *pnParamOut, double *pdParamIn, double *pdData, double *pdLoadings, double *pdSDev, double *pdObj/*, double *pdMaxMaha*/) { TRY( CPCAGrid (pnParamIn, pnParamOut, pdParamIn, pdData, pdLoadings, pdSDev, pdObj/*, pdMaxMaha*/).Calc () ; ) } void C_sPCAgrid (int *pnParamIn, int *pnParamOut, double *pdParamIn, double *pdData, double *pdLoadings, double *pdSDev, double *pdObj/*, double *pdMaxMaha*/, double *pdLambda, double *pdBackTransHD) { TRY( CsPCAGrid (pnParamIn, pnParamOut, pdParamIn, pdData, pdLoadings, pdSDev, pdObj/*, pdMaxMaha*/, pdLambda, pdBackTransHD).Calc () ; ) } void C_pcaProj_up (int *pnParIn, double *pdParIn, double *pdX, double *pdZ, double *pdL, double *pdSDev) { TRY( CPCAprojU (pnParIn, pdParIn, pdX, pdZ, pdL, pdSDev).Calc () ; ) } void C_pcaProj (int *pnParIn, double *pdParIn, double *pdX, double *pdZ, double *pdL, double *pdSDev) { TRY( CPCAproj (pnParIn, pdParIn, pdX, pdZ, pdL, pdSDev).Calc () ; ) } void C_l1Median_VZ (int *pnParIn, int *pnParOut, double *pdParIn, double *pdX, double *pdMed/*, double *pdWeights*/) { TRY( CPerfTimer tim ; CL1Median_VZ (pnParIn, pnParOut, pdParIn, pdX, pdMed, NULL) ; //, pdWeights) ; pnParOut[2] = tim.GetTimeMS () ; ) } void C_l1median_HoCr (int *pnParIn, int *pnParOut, double *pdParIn, double *pdX, double *pdMed) { const int &n = pnParIn [0], &p = pnParIn [1], &dwMaxit = pnParIn[2], &dwTrace = pnParIn [3] ; int &nCode = pnParOut[0] = 0, &dwIterCount = pnParOut [1] ; const double &dTol = pdParIn[0], &dZeroTol = pdParIn[1] ; TRY( CPerfTimer tim ; nCode = l1median_HoCr (SMatD (pdX, n, p), SVecD (pdMed, p), dZeroTol, dTol, dwMaxit, dwTrace, &dwIterCount) ; pnParOut[2] = tim.GetTimeMS () ; ) return ; } void C_qn (int *pnParIn, double *pdParIn, double *pdParOut, double *pdX) { int &n = pnParIn[0] ; double &dCorrFact = pdParIn [0] ; double &dQn = pdParOut [0] ; TRY( dQn = qn_raw (pdX, n) ; dQn *= qn_corrN (n, dCorrFact) ; ) } void SDoOut (int *pnParIn, double *pdX, double *pdMaxMaha, int *pnNChanged) { TRY( CSDoOut (pnParIn, pdX, pdMaxMaha, pnNChanged).Calc () ; ) } #endif // #ifdef R_PACKAGE_FILE pcaPP/src/R_meal.h0000644000176200001440000000253313300577052013421 0ustar liggesusers/* SMat - Simple Matrix Classes v0.1beta Copyright (C) 2011 by Heinrich Fritz (heinrich_fritz@hotmail.com) This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . */ // R.meal.h // R Mathematical Environment Abstraction Layer // // VT:10.10.2016 // Problem compiling on Solaris (mail from Prof. Ripley from 18.09.2016) // - add 'using namespace std;' using namespace std; #ifdef R_PACKAGE_FILE #ifndef R_MEAL_H #define R_MEAL_H class CRmealSettings // 2do: move to meal.h { public: CRmealSettings () ; CRmealSettings (const char *szEmail) ; const char *GetEmail () { return m_szEmail ; } protected: const char *m_szEmail ; } ; #define R_MEAL_SETTINGS CRmealSettings g_R_meal_settings #endif // #ifndef R_MEAL_H #endif // #ifdef R_PACKAGE_FILE pcaPP/src/pcaPP.cpp0000644000176200001440000000160513300577052013557 0ustar liggesusers#include "pcaPP.h" #include "qnn.h" double mom2 (const SVecD &v) { double dRet = 0 ; EO::SVc (dRet, v) ; return dRet / v.size () ; } double ApplyMethod (const SCVecD &v, const int nMethod) { ASSERT_TEMPRANGE (10, 10) ; SVecD temp (tempRef (10), v.size ()) ; // 2do: should be copied by the constructor! temp.Copy_NC (v) ; return ApplyMethod_V (!temp, nMethod) ; } double ApplyMethod_V (const SVVecD &v, const int nMethod) { //VT:10.10.2016 - fix compilation warning - uninitialized variable. // double dRet = 0; int nSize = v.size () ; switch (nMethod) { case 0: sd (dRet, v) ; break ; case 1: dRet = mad_V (*v) ; break ; case 2: qn (dRet, v.GetData (), nSize) ; break ; case 3: dRet = medianabs_V (*v) * 1.482602218505602 ; break ; // case 4: sd_st (dRet, v) ; break ; case 5: dRet = mom2 (v) ; break ; } return dRet ; } pcaPP/src/defint64.h0000644000176200001440000000021313300577052013636 0ustar liggesusers //typedef int int64_t ; #ifdef _MSC_VER typedef __int64 int64_t ; #else #include //typedef long long int int64_t ; #endif pcaPP/src/R_meal.cpp0000644000176200001440000001227113300577052013754 0ustar liggesusers/* SMat - Simple Matrix Classes v0.1beta Copyright (C) 2011 by Heinrich Fritz (heinrich_fritz@hotmail.com) This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . */ // R.meal.cpp // R Mathematical Environment Abstraction Layer #ifdef R_PACKAGE_FILE #define R_USE_C99_IN_CXX #include "R_meal.h" ///////////////////// // CRmealSettings // ///////////////////// CRmealSettings &GetRealSettings () { static CRmealSettings settings ; return settings ; } CRmealSettings::CRmealSettings () : m_szEmail ("") { } CRmealSettings::CRmealSettings (const char *szEmail) { if (szEmail) GetRealSettings ().m_szEmail = szEmail ; } #include #include #include // LAPACK void meal_geev (const char* jobvl, const char* jobvr, const int* n, double* a, const int* lda, double* wr, double* wi, double* vl, const int* ldvl, double* vr, const int* ldvr, double* work, const int* lwork, int* info) { F77_CALL(dgeev)(jobvl, jobvr, n, a, lda, wr, wi, vl, ldvl, vr, ldvr, work, lwork, info) ; } void meal_gesv (const int* n, const int* nrhs, double* a, const int* lda, int* ipiv, double* b, const int* ldb, int* info) { F77_CALL(dgesv)(n, nrhs, a, lda, ipiv, b, ldb, info) ; } void meal_gesvd (const char* jobu, const char* jobvt, const int* m, const int* n, double* a, const int* lda, double* s, double* u, const int* ldu, double* vt, const int* ldvt, double* work, const int* lwork, int* info) { F77_CALL(dgesvd)(jobu, jobvt, m, n, a, lda, s, u, ldu, vt, ldvt, work, lwork, info) ; } // SORT void meal_sort (double *d, int l) { R_qsort (d, 1, l) ; } void meal_sort_order (double *d, int *o, int l) { int i ; for (i = l - 1; i != -1; i--) o[i] = i ; rsort_with_index(d, o, l); } void meal_sort_order_rev (double *d, int *o, int l) { int i ; for (i = l - 1; i != -1; i--) o[i] = i ; rsort_with_index(d, o, l); // 2do: use r_qsort_I instead! double dTemp ; int nTemp ; for (i = 0, --l; i < l; ++i, --l) // 2do: implement an reverse order - function. this should be as fast! (could be called twice) { // sm_swap (d[i], d[l], dTemp) ; // 2do: check if this works.. // sm_swap (o[i], o[l], nTemp) ; dTemp = d[i] ; d[i] = d[l] ; d[l] = dTemp ; nTemp = o[i]; ; o[i] = o[l]; ; o[l] = nTemp; ; } } //////////////////////// // Random Generator // //////////////////////// void meal_PutRNGstate () { PutRNGstate () ; } void meal_GetRNGstate () { GetRNGstate () ; } double meal_unif_rand () { return unif_rand () ; } double meal_norm_rand () { return norm_rand () ; } double meal_exp_rand () { return exp_rand () ; } //////////////////////////////////// // special values amd constants // //////////////////////////////////// double meal_NaN () { return R_NaN ; } double meal_PosInf () { return R_PosInf ; } double meal_NegInf () { return R_NegInf ; } double meal_NaReal () { return R_NaReal ; } int meal_NaInt () { return R_NaInt ; } double meal_PI () { return M_PI ; } ////////////////////////// // printing functions // ////////////////////////// void meal_printf (const char *sz, ...) { va_list va_l ; va_start (va_l, sz) ; Rvprintf (sz, va_l) ; } void meal_warning (const char *sz) { Rf_warning (sz) ; } void meal_error (const char *sz) { Rf_error (sz) ; } void *meal_alloc (size_t n, int s) { return calloc (n, s) ; } void meal_free (void *p) { Free (p) ; } ////////////////// // Exceptions // ////////////////// void meal_OnException (const char * szDate, const char * szFile, int nLine) { meal_printf ( "\n" " An exception occurred.\n" " Please contact the author (%s), providing\n" " the following information:\n" "\n" " - The R-code which caused the problem\n" " - Eventually used data sets and the state of the random generator (seed)\n" " - R version number\n" " - Package version number\n" " - File: %s\n" " - Line: %d\n" "\n" " Your contribution is appreciated!\n\n", GetRealSettings ().GetEmail (), szFile, nLine) ; meal_error ("An exception has occurred.") ; } void meal_OnUException () { meal_printf ( "\n" " An unknown exception occurred.\n" " Please contact the author (%s), providing\n" " the following details:\n" "\n" " - The R-code which caused the problem\n" " - Eventually used data sets and the state of the random generator (seed)\n" " - R version number\n" " - Package version number\n" "\n" " Your contribution is appreciated!\n\n", GetRealSettings ().GetEmail ()) ; meal_error ("An unknown exception has occurred.") ; } #endif // #ifdef R_PACKAGE_FILE pcaPP/src/R.Inc.h0000644000176200001440000000017513300577052013133 0ustar liggesusers #ifdef _MSC_VER #define EXPORT extern "C" __declspec(dllexport) #else #define EXPORT extern "C" #endif //#ifdef _MSC_VER pcaPP/src/Makevars0000644000176200001440000000012113300577052013534 0ustar liggesusersPKG_LIBS = $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS) PKG_CPPFLAGS = -DR_PACKAGE_FILE pcaPP/src/smat.def.h0000644000176200001440000000605013300577052013721 0ustar liggesusers/* SMat - Simple Matrix Classes v0.1beta Copyright (C) 2011 by Heinrich Fritz (heinrich_fritz@hotmail.com) This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . */ #ifndef ES_SMAT_DEF_H #define ES_SMAT_DEF_H typedef unsigned int UINT ; typedef UINT BOOL ; #define FALSE 0 #define TRUE 1 #ifndef NULL #define NULL 0 #endif typedef UINT t_size ; // 2do: use size_t instead typedef UINT t_count ; #define NAI ((t_size) -1) // not an index #ifdef _DEBUG #define ASSERT(a) THROW(a) #else #define ASSERT(a) #endif class SMat_EXC { public: SMat_EXC (char const * const szDate, char const * const szFile, const int nLine) : m_szDate (szDate), m_szFile (szFile), m_nLine (nLine) {} const char * const GetDate () const { return m_szDate ; } const char * const GetFile () const { return m_szFile ; } const int GetLine () const { return m_nLine ; } void OnException () ; static void OnUException () ; private: const char * const m_szDate, * const m_szFile ; const int m_nLine ; } ; #ifdef _DEBUG #define TRY(C) C #else #define TRY(C) try {C} catch (SMat_EXC exc) { exc.OnException () ; } catch (...) { SMat_EXC::OnUException () ; } #endif #define THROW(a) {if (!(a)){THROW_BASE}} #define THROW_BASE { { throw (SMat_EXC (__DATE__, __FILE__, __LINE__)) ; } } template inline const T sm_sqr (const T &a) { return a * a ; } template void sm_swap (T &a, T &b) // -> move to COP? { T c (a) ; a = b ; b = c ; } template void sm_swap (T &a, T &b, T&temp) { temp = a; a = b; b = temp ; } /////////////// // min max // // -> move to COP? /////////////// template const T &sm_min (const T &a, const T &b) { if (a < b) return a ; return b ; } template const T &sm_max (const T &a, const T &b) { if (a > b) return a ; return b ; } template TA &sm_setmax_t (TA &a, const TB &b) { if (a < b) a = b ; return a ; } template TA &sm_setmin_t (TA &a, const TB &b) { if (a > b) a = b ; return a ; } template BOOL sm_setmax_b (TA &a, const TB &b) { if (a >= b) return FALSE ; a = b ; return TRUE ; } template BOOL sm_setmin_b (TA &a, const TB &b) { if (a <= b) return FALSE; a = b ; return TRUE ; } template void sm_setmax (TA &a, const TB &b) { if (a < b) a = b ; } template void sm_setmin (TA &a, const TB &b) { if (a > b) a = b ; } #endif //#ifndef ES_SMAT_DEF_H pcaPP/src/ML_passrng.h0000644000176200001440000000042213300577052014262 0ustar liggesusers#ifdef MATLAB_MEX_FILE #ifdef ML_PASSRNG_H #include "ML.meal.h" ML_pass_runif (int nlhs, mxArray* plhs[], int nrhs, mxArray *prhs[]) ; ML_pass_rnorm (int nlhs, mxArray* plhs[], int nrhs, mxArray *prhs[]) ; #endif // #ifdef ML_PASSRNG_H #endif // #ifdef MATLAB_MEX_FILE pcaPP/src/smat.mem.h0000644000176200001440000001246113300577052013744 0ustar liggesusers/* SMat - Simple Matrix Classes v0.1beta Copyright (C) 2011 by Heinrich Fritz (heinrich_fritz@hotmail.com) This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . */ #ifndef SMAT_MEM_H #define SMAT_MEM_H template void CopyRow_R (SVData &a, const SCMat &b, const t_size &c) // 2do: rename to CopyRow_R { THROW (c < b.nrow ()) ; a.Require (b.ncol()) ; CopyRow_NC (a, b, c) ; } template void CopyRow (const SVData &a, const SCMat &b, const t_size &c) { THROW (c < b.nrow ()) ; THROW (a.size () == b.ncol()) ; CopyRow_NC (a, b, c) ; } template void CopyRow_NC (const SVData &a, const SCMat &b, const t_size &c) { ASSERT (c < b.nrow ()) ; ASSERT (a.size () == b.ncol()) ; TA *pA = a ;//, * const pEndA = a.GetDataEnd () ; TB const *pB = b.GetData (c, 0), * const pEndB = b.GetDataEnd () ; while (pB < pEndB) { *pA = *pB ; ++pA ; pB += b.GetColInc () ; } } template void CopyRow (const SVMat &a, const SCData &b, const t_size &c) { THROW (c < a.nrow ()) ; THROW (a.ncol () == b.size ()) ; CopyRow_NC (a, b, c) ; } template void CopyRow_NC (const SVMat &a, const SCData &b, const t_size &c) { ASSERT (c < a.nrow ()) ; ASSERT (a.ncol () == b.size ()) ; TA *pA = a.GetData (c, 0), * const pEndA = a.GetDataEnd () ; TB const * pB = b ; while (pA < pEndA) { *pA = *pB ; pA += a.GetColInc () ; ++pB ; } } template void ResetRow (const SVMat &a, const TB &b, const t_size &c) { THROW (c < a.nrow ()) ; ResetRow_NC (a, b, c) ; } template void ResetRow_NC (const SVMat &a, const TB &b, const t_size &c) { ASSERT (c < a.nrow ()) ; TA *pA = a.GetData (c, 0), * const pEndA = a.GetDataEnd () ; while (pA < pEndA) { *pA = b ; pA += a.GetColInc () ; } } template TA *Reset (TA *pA, const TA *pEndA, const TA &val) { for (; pA < pEndA; pA++) *pA = val ; return pA ; } template TA *Reset (TA *pA, const TA *pEndA) { for (; pA < pEndA; pA++) *pA = 0 ; return pA ; } template void Copy (TA * pA, TB const * pB, t_size n) // the "master" - copy function { //memcpy (pA, pB, sizeof (T) * n) ; // 2do: implement with a for - loop using "=". -> Copy constructor would be used! TA * const pEndA = pA + n ; while (pA < pEndA) { *pA = *pB ; ++pA ; ++pB ; } } template void Copy (const SVData &a, const TB * const pB) { Copy (a.GetData (), pB, a.size ()) ; } template void Copy (TA * const pA, const SCData &b) { Copy (pA, b.GetData (), b.size ()) ; } template void Copy_R (SVVec &a, const SCData &b) { a.Require (b) ; Copy_NC (a, b) ; } template void Copy (const SVData &a, const SCData &b) { THROW (a.size () == b.size ()) ; Copy_NC (a, b) ; } template void Copy_NC (const SVData &a, const SCData &b) { ASSERT (a.size () == b.size ()) ; Copy (a.GetData (), b.GetData (), b.size ()) ; } template void CopyDiag_R (SVec &v, const SCMat &m) { v.Require (m.GetMinDim ()) ; CopyDiag (v, m) ; } template void CopyDiag (const SVec &v, const SCMat &m) { THROW (v.nsize () == m.GetMinDim ()) ; CopyDiag_NC (v, m) ; } template void CopyDiag_NC (const SVec &v, const SCMat &m) { ASSERT (v.size () == m.GetMinDim ()) ; t_size i ; for (i = v.size () - 1; i != NAI; i--) v (i) = m (i, i) ; } template void CopyCol (const SVData &a, const SCMat &b, t_size dwCol) { THROW (dwCol < b.ncol ()) ; CopyCol_NC (a, b, dwCol) ; } template void CopyCol_NC (const SVData &a, const SCMat &b, t_size dwCol) { ASSERT (dwCol < b.ncol ()) ; Copy (a.GetData (), b.GetData_NC (0, dwCol), b.nrow ()) ; } template void CopyCol (const SVMat &a, const SCMat &b, t_size dwStart, t_size dwEnd) { THROW (dwStart <= dwEnd) ; THROW (dwEnd <= b.ncol ()) ; THROW (a.nrow () == b.nrow ()) ; THROW (a.ncol () == dwEnd - dwStart) ; CopyCol_NC (a, b, dwStart, dwEnd) ; } template void CopyCol_NC (const SVMat &a, const SCMat &b, t_size dwStart, t_size dwEnd) { ASSERT (dwStart <= dwEnd) ; ASSERT (dwEnd <= b.ncol ()) ; ASSERT (a.nrow () == b.nrow ()) ; ASSERT (a.ncol () == dwEnd - dwStart) ; Copy (a.GetData (), b.GetData_NC (0, dwStart), b.nrow () * (dwEnd - dwStart)) ; } #endif // #ifndef SMAT_MEM_H pcaPP/src/R_meal_BLAS.cpp0000644000176200001440000003313513300577052014557 0ustar liggesusers#ifdef R_PACKAGE_FILE #include #include #include "Rversion.h" #ifndef _MB_CONST #define _MB_CONST const #endif #ifndef _MB_TYPE_D #define _MB_TYPE_D double #endif #ifndef _MB_INT #define _MB_INT int #endif #ifndef _MB_CHAR #define _MB_CHAR char #endif // Level 1 BLAS _MB_TYPE_D meal_asum (const _MB_INT *n, const _MB_TYPE_D *dx, const _MB_INT *incx) { return F77_CALL (dasum) ( (_MB_CONST _MB_INT *) n, (_MB_CONST _MB_TYPE_D *) dx, (_MB_CONST _MB_INT *) incx ) ; } void meal_axpy(const _MB_INT *n, const _MB_TYPE_D *alpha, const _MB_TYPE_D *dx, const _MB_INT *incx, _MB_TYPE_D *dy, const _MB_INT *incy) { F77_CALL (daxpy) ( (_MB_CONST _MB_INT *) n, (_MB_CONST _MB_TYPE_D *) alpha, (_MB_CONST _MB_TYPE_D *) dx, (_MB_CONST _MB_INT *) incx, (_MB_TYPE_D *) dy, (_MB_CONST _MB_INT *) incy ) ; } void meal_copy (const _MB_INT *n, const _MB_TYPE_D *dx, const _MB_INT *incx, _MB_TYPE_D *dy, const _MB_INT *incy) { F77_CALL (dcopy) ( (_MB_CONST _MB_INT *) n, (_MB_CONST _MB_TYPE_D *) dx, (_MB_CONST _MB_INT *) incx, (_MB_TYPE_D *) dy, (_MB_CONST _MB_INT *) incy ) ; } _MB_TYPE_D meal_dot (const _MB_INT *n, const _MB_TYPE_D *dx, const _MB_INT *incx, const _MB_TYPE_D *dy, const _MB_INT *incy) { return F77_CALL (ddot) ( (_MB_CONST _MB_INT *) n, (_MB_CONST _MB_TYPE_D *) dx, (_MB_CONST _MB_INT *) incx, (_MB_CONST _MB_TYPE_D *) dy, (_MB_CONST _MB_INT *) incy ) ; } _MB_TYPE_D meal_nrm2 (const _MB_INT *n, const _MB_TYPE_D *dx, const _MB_INT *incx) { return F77_CALL (dnrm2) ( (_MB_CONST _MB_INT *) n, (_MB_CONST _MB_TYPE_D *) dx, (_MB_CONST _MB_INT *) incx ) ; } void meal_rot (const _MB_INT *n, _MB_TYPE_D *dx, const _MB_INT *incx, _MB_TYPE_D *dy, const _MB_INT *incy, const _MB_TYPE_D *c, const _MB_TYPE_D *s) { F77_CALL (drot) ( (_MB_CONST _MB_INT *) n, (_MB_TYPE_D *) dx, (_MB_CONST _MB_INT *) incx, (_MB_TYPE_D *) dy, (_MB_CONST _MB_INT *) incy, (_MB_CONST _MB_TYPE_D *) c, (_MB_CONST _MB_TYPE_D *) s ) ; } void meal_rotg (const _MB_TYPE_D *a, const _MB_TYPE_D *b, _MB_TYPE_D *c, _MB_TYPE_D *s) { F77_CALL (drotg) ( (_MB_CONST _MB_TYPE_D *) a, (_MB_CONST _MB_TYPE_D *) b, (_MB_TYPE_D *) c, (_MB_TYPE_D *) s ) ; } void meal_rotm (const _MB_INT *n, _MB_TYPE_D *dx, const _MB_INT *incx, _MB_TYPE_D *dy, const _MB_INT *incy, const _MB_TYPE_D *dparam) { F77_CALL (drotm) ( (_MB_CONST _MB_INT *) n, (_MB_TYPE_D *) dx, (_MB_CONST _MB_INT *) incx, (_MB_TYPE_D *) dy, (_MB_CONST _MB_INT *) incy, (_MB_CONST _MB_TYPE_D *) dparam ) ; } void meal_rotmg (const _MB_TYPE_D *dd1, const _MB_TYPE_D *dd2, const _MB_TYPE_D *dx1, const _MB_TYPE_D *dy1, _MB_TYPE_D *param) { F77_CALL (drotmg) ( (_MB_CONST _MB_TYPE_D *) dd1, (_MB_CONST _MB_TYPE_D *) dd2, (_MB_CONST _MB_TYPE_D *) dx1, (_MB_CONST _MB_TYPE_D *) dy1, (_MB_TYPE_D *) param ) ; } void meal_scal (const _MB_INT *n, const _MB_TYPE_D *alpha, _MB_TYPE_D *dx, const _MB_INT *incx) { F77_CALL(dscal) ( (_MB_CONST _MB_INT *) n, (_MB_CONST _MB_TYPE_D *) alpha, (_MB_TYPE_D *) dx, (_MB_CONST _MB_INT *) incx ) ; } void meal_swap (const _MB_INT *n, _MB_TYPE_D *dx, const _MB_INT *incx, _MB_TYPE_D *dy, const _MB_INT *incy) { F77_CALL (dswap) ( (_MB_CONST _MB_INT *) n, (_MB_TYPE_D *) dx, (_MB_CONST _MB_INT *) incx, (_MB_TYPE_D *) dy, (_MB_CONST _MB_INT *) incy ) ; } _MB_INT meal_iamax (const _MB_INT *n, const _MB_TYPE_D *dx, const _MB_INT *incx) { return F77_CALL (idamax) ( (_MB_CONST _MB_INT *) n, (_MB_CONST _MB_TYPE_D *) dx, (_MB_CONST _MB_INT *) incx ) ; } // Level 2 BLAS void meal_symv (const _MB_CHAR *uplo, const _MB_INT *n, const _MB_TYPE_D *alpha, const _MB_TYPE_D *a, const _MB_INT *lda, const _MB_TYPE_D *x, const _MB_INT *incx, const _MB_TYPE_D *beta, _MB_TYPE_D *y, const _MB_INT *incy) { F77_CALL (dsymv) ( (_MB_CONST _MB_CHAR *) uplo, (_MB_CONST _MB_INT *) n, (_MB_CONST _MB_TYPE_D *) alpha, (_MB_CONST _MB_TYPE_D *) a, (_MB_CONST _MB_INT *) lda, (_MB_CONST _MB_TYPE_D *) x, (_MB_CONST _MB_INT *) incx, (_MB_CONST _MB_TYPE_D *) beta, (_MB_TYPE_D *) y, (_MB_CONST _MB_INT *) incy ); } void meal_tbmv (const _MB_CHAR *uplo, const _MB_CHAR *trans, const _MB_CHAR *diag, const _MB_INT *n, const _MB_INT *k, const _MB_TYPE_D *a, const _MB_INT *lda, _MB_TYPE_D *x, const _MB_INT *incx) { F77_CALL (dtbmv) ( (_MB_CONST _MB_CHAR *) uplo, (_MB_CONST _MB_CHAR *) trans, (_MB_CONST _MB_CHAR *) diag, (_MB_CONST _MB_INT *) n, (_MB_CONST _MB_INT *) k, (_MB_CONST _MB_TYPE_D *) a, (_MB_CONST _MB_INT *) lda, (_MB_TYPE_D *) x, (_MB_CONST _MB_INT *) incx ); } void meal_tpmv (const _MB_CHAR *uplo, const _MB_CHAR *trans, const _MB_CHAR *diag, const _MB_INT *n, const _MB_TYPE_D *ap, _MB_TYPE_D *x, const _MB_INT *incx) { F77_CALL (dtpmv) ( (_MB_CONST _MB_CHAR *) uplo, (_MB_CONST _MB_CHAR *) trans, (_MB_CONST _MB_CHAR *) diag, (_MB_CONST _MB_INT *) n, (_MB_CONST _MB_TYPE_D *) ap, (_MB_TYPE_D *) x, (_MB_CONST _MB_INT *) incx ); } void meal_trmv (const _MB_CHAR *uplo, const _MB_CHAR *trans, const _MB_CHAR *diag, const _MB_INT *n, const _MB_TYPE_D *a, const _MB_INT *lda, _MB_TYPE_D *x, const _MB_INT *incx) { F77_CALL (dtrmv) ( (_MB_CONST _MB_CHAR *) uplo, (_MB_CONST _MB_CHAR *) trans, (_MB_CONST _MB_CHAR *) diag, (_MB_CONST _MB_INT *) n, (_MB_CONST _MB_TYPE_D *) a, (_MB_CONST _MB_INT *) lda, (_MB_TYPE_D *) x, (_MB_CONST _MB_INT *) incx ); } void meal_tbsv (const _MB_CHAR *uplo, const _MB_CHAR *trans, const _MB_CHAR *diag, const _MB_INT *n, const _MB_INT *k, const _MB_TYPE_D *a, const _MB_INT *lda, _MB_TYPE_D *x, const _MB_INT *incx) { F77_CALL (dtbsv) ( (_MB_CONST _MB_CHAR *) uplo, (_MB_CONST _MB_CHAR *) trans, (_MB_CONST _MB_CHAR *) diag, (_MB_CONST _MB_INT *) n, (_MB_CONST _MB_INT *) k, (_MB_CONST _MB_TYPE_D *) a, (_MB_CONST _MB_INT *) lda, (_MB_TYPE_D *) x, (_MB_CONST _MB_INT *) incx ); } void meal_tpsv (const _MB_CHAR *uplo, const _MB_CHAR *trans, const _MB_CHAR *diag, const _MB_INT *n, const _MB_TYPE_D *ap, _MB_TYPE_D *x, const _MB_INT *incx) { F77_CALL (dtpsv) ( (_MB_CONST _MB_CHAR *) uplo, (_MB_CONST _MB_CHAR *) trans, (_MB_CONST _MB_CHAR *) diag, (_MB_CONST _MB_INT *) n, (_MB_CONST _MB_TYPE_D * ) ap, (_MB_TYPE_D *) x, (_MB_CONST _MB_INT *) incx ); } void meal_trsv (const _MB_CHAR *uplo, const _MB_CHAR *trans, const _MB_CHAR *diag, const _MB_INT *n, const _MB_TYPE_D *a, const _MB_INT *lda, _MB_TYPE_D *x, const _MB_INT *incx) { F77_CALL (dtrsv) ( (_MB_CONST _MB_CHAR *) uplo, (_MB_CONST _MB_CHAR *) trans, (_MB_CONST _MB_CHAR *) diag, (_MB_CONST _MB_INT *) n, (_MB_CONST _MB_TYPE_D *) a, (_MB_CONST _MB_INT *) lda, (_MB_TYPE_D *) x, (_MB_CONST _MB_INT *) incx ); } #if defined(R_VERSION) && R_VERSION >= R_Version(2, 12, 0) void meal_ger (const _MB_INT *m, const _MB_INT *n, const _MB_TYPE_D *alpha, const _MB_TYPE_D *x, const _MB_INT *incx, const _MB_TYPE_D *y, const _MB_INT *incy, _MB_TYPE_D *a, const _MB_INT *lda) { F77_CALL (dger) ( (_MB_CONST _MB_INT *) m, (_MB_CONST _MB_INT *) n, (_MB_CONST _MB_TYPE_D *) alpha, (_MB_CONST _MB_TYPE_D *) x, (_MB_CONST _MB_INT *) incx, (_MB_CONST _MB_TYPE_D *) y, (_MB_CONST _MB_INT *) incy, (_MB_TYPE_D *) a, (_MB_CONST _MB_INT *) lda ); } #else void meal_ger (const _MB_INT *m, const _MB_INT *n, const _MB_TYPE_D *alpha, _MB_TYPE_D *x, const _MB_INT *incx, _MB_TYPE_D *y, const _MB_INT *incy, _MB_TYPE_D *a, const _MB_INT *lda) { F77_CALL (dger) ( (_MB_CONST _MB_INT *) m, (_MB_CONST _MB_INT *) n, (_MB_CONST _MB_TYPE_D *) alpha, (_MB_TYPE_D *) x, (_MB_CONST _MB_INT *) incx, (_MB_TYPE_D *) y, (_MB_CONST _MB_INT *) incy, (_MB_TYPE_D *) a, (_MB_CONST _MB_INT *) lda ); } #endif void meal_syr (const _MB_CHAR *uplo, const _MB_INT *n, const _MB_TYPE_D *alpha, const _MB_TYPE_D *x, const _MB_INT *incx, _MB_TYPE_D *a, const _MB_INT *lda) { F77_CALL (dsyr) ( (_MB_CONST _MB_CHAR *) uplo, (_MB_CONST _MB_INT *) n, (_MB_CONST _MB_TYPE_D *) alpha, (_MB_CONST _MB_TYPE_D *) x, (_MB_CONST _MB_INT *) incx, (_MB_TYPE_D *) a, (_MB_CONST _MB_INT *) lda ); } void meal_spr (const _MB_CHAR *uplo, const _MB_INT *n, const _MB_TYPE_D *alpha, const _MB_TYPE_D *x, const _MB_INT *incx, _MB_TYPE_D *ap) { F77_CALL (dspr) ( (_MB_CONST _MB_CHAR *) uplo, (_MB_CONST _MB_INT *) n, (_MB_CONST _MB_TYPE_D *) alpha, (_MB_CONST _MB_TYPE_D *) x, (_MB_CONST _MB_INT *) incx, (_MB_TYPE_D *) ap ); } void meal_syr2 (const _MB_CHAR *uplo, const _MB_INT *n, const _MB_TYPE_D *alpha, const _MB_TYPE_D *x, const _MB_INT *incx, const _MB_TYPE_D *y, const _MB_INT *incy, _MB_TYPE_D *a, const _MB_INT *lda) { F77_CALL (dsyr2) ( (_MB_CONST _MB_CHAR *) uplo, (_MB_CONST _MB_INT *) n, (_MB_CONST _MB_TYPE_D *) alpha, (_MB_CONST _MB_TYPE_D *) x, (_MB_CONST _MB_INT *) incx, (_MB_CONST _MB_TYPE_D *) y, (_MB_CONST _MB_INT *) incy, (_MB_TYPE_D *) a, (_MB_CONST _MB_INT *) lda ); } void meal_spr2 (const _MB_CHAR *uplo, const _MB_INT *n, const _MB_TYPE_D *alpha, const _MB_TYPE_D *x, const _MB_INT *incx, const _MB_TYPE_D *y, const _MB_INT *incy, _MB_TYPE_D *ap) { F77_CALL (dspr2) ( (_MB_CONST _MB_CHAR *) uplo, (_MB_CONST _MB_INT *) n, (_MB_CONST _MB_TYPE_D *) alpha, (_MB_CONST _MB_TYPE_D *) x, (_MB_CONST _MB_INT *) incx, (_MB_CONST _MB_TYPE_D *) y, (_MB_CONST _MB_INT *) incy, (_MB_TYPE_D *) ap ); } // Level 3 BLAS void meal_gemm (const _MB_CHAR *transa, const _MB_CHAR *transb, const _MB_INT *m, const _MB_INT *n, const _MB_INT *k, const _MB_TYPE_D *alpha, const _MB_TYPE_D *a, const _MB_INT *lda, const _MB_TYPE_D *b, const _MB_INT *ldb, const _MB_TYPE_D *beta, _MB_TYPE_D *c, const _MB_INT *ldc) { F77_CALL (dgemm) ( (_MB_CONST _MB_CHAR *) transa, (_MB_CONST _MB_CHAR *) transb, (_MB_CONST _MB_INT *) m, (_MB_CONST _MB_INT *) n, (_MB_CONST _MB_INT *) k, (_MB_CONST _MB_TYPE_D *) alpha, (_MB_CONST _MB_TYPE_D *) a, (_MB_CONST _MB_INT *) lda, (_MB_CONST _MB_TYPE_D *) b, (_MB_CONST _MB_INT *) ldb, (_MB_CONST _MB_TYPE_D *) beta, (_MB_TYPE_D *) c, (_MB_CONST _MB_INT *) ldc ) ; } void meal_trsm (const _MB_CHAR *side, const _MB_CHAR *uplo, const _MB_CHAR *transa, const _MB_CHAR *diag, const _MB_INT *m, const _MB_INT *n, const _MB_TYPE_D *alpha, const _MB_TYPE_D *a, const _MB_INT *lda, _MB_TYPE_D *b, const _MB_INT *ldb) { F77_CALL (dtrsm) ( (_MB_CONST _MB_CHAR *) side, (_MB_CONST _MB_CHAR *) uplo, (_MB_CONST _MB_CHAR *) transa, (_MB_CONST _MB_CHAR *) diag, (_MB_CONST _MB_INT *) m, (_MB_CONST _MB_INT *) n, (_MB_CONST _MB_TYPE_D *) alpha, (_MB_CONST _MB_TYPE_D *) a, (_MB_CONST _MB_INT *) lda, (_MB_TYPE_D *) b, (_MB_CONST _MB_INT *) ldb ); } void meal_trmm (const _MB_CHAR *side, const _MB_CHAR *uplo, const _MB_CHAR *transa, const _MB_CHAR *diag, const _MB_INT *m, const _MB_INT *n, const _MB_TYPE_D *alpha, const _MB_TYPE_D *a, const _MB_INT *lda, _MB_TYPE_D *b, const _MB_INT *ldb) { F77_CALL (dtrmm) ( (_MB_CONST _MB_CHAR *) side, (_MB_CONST _MB_CHAR *) uplo, (_MB_CONST _MB_CHAR *) transa, (_MB_CONST _MB_CHAR *) diag, (_MB_CONST _MB_INT *) m, (_MB_CONST _MB_INT *) n, (_MB_CONST _MB_TYPE_D *) alpha, (_MB_CONST _MB_TYPE_D *) a, (_MB_CONST _MB_INT *) lda, (_MB_TYPE_D *) b, (_MB_CONST _MB_INT *) ldb ); } void meal_symm (const _MB_CHAR *side, const _MB_CHAR *uplo, const _MB_INT *m, const _MB_INT *n, const _MB_TYPE_D *alpha, const _MB_TYPE_D *a, const _MB_INT *lda, const _MB_TYPE_D *b, const _MB_INT *ldb, const _MB_TYPE_D *beta, _MB_TYPE_D *c, const _MB_INT *ldc) { F77_CALL (dsymm) ( (_MB_CONST _MB_CHAR *) side, (_MB_CONST _MB_CHAR *) uplo, (_MB_CONST _MB_INT *) m, (_MB_CONST _MB_INT *) n, (_MB_CONST _MB_TYPE_D *) alpha, (_MB_CONST _MB_TYPE_D *) a, (_MB_CONST _MB_INT *) lda, (_MB_CONST _MB_TYPE_D *) b, (_MB_CONST _MB_INT *) ldb, (_MB_CONST _MB_TYPE_D *) beta, (_MB_TYPE_D *) c, (_MB_CONST _MB_INT *) ldc ); } void meal_syrk (const _MB_CHAR *uplo, const _MB_CHAR *trans, const _MB_INT *n, const _MB_INT *k, const _MB_TYPE_D *alpha, const _MB_TYPE_D *a, const _MB_INT *lda, const _MB_TYPE_D *beta, _MB_TYPE_D *c, const _MB_INT *ldc) { F77_CALL (dsyrk) ( (_MB_CONST _MB_CHAR *) uplo, (_MB_CONST _MB_CHAR *) trans, (_MB_CONST _MB_INT *) n, (_MB_CONST _MB_INT *) k, (_MB_CONST _MB_TYPE_D *) alpha, (_MB_CONST _MB_TYPE_D *) a, (_MB_CONST _MB_INT *) lda, (_MB_CONST _MB_TYPE_D *) beta, (_MB_TYPE_D *) c, (_MB_CONST _MB_INT *) ldc ); } void meal_syr2k (const _MB_CHAR *uplo, const _MB_CHAR *trans, const _MB_INT *n, const _MB_INT *k, const _MB_TYPE_D *alpha, const _MB_TYPE_D *a, const _MB_INT *lda, const _MB_TYPE_D *b, const _MB_INT *ldb, const _MB_TYPE_D *beta, _MB_TYPE_D *c, const _MB_INT *ldc) { F77_CALL (dsyr2k) ( (_MB_CONST _MB_CHAR *) uplo, (_MB_CONST _MB_CHAR *) trans, (_MB_CONST _MB_INT *) n, (_MB_CONST _MB_INT *) k, (_MB_CONST _MB_TYPE_D *) alpha, (_MB_CONST _MB_TYPE_D *) a, (_MB_CONST _MB_INT *) lda, (_MB_CONST _MB_TYPE_D *) b, (_MB_CONST _MB_INT *) ldb, (_MB_CONST _MB_TYPE_D *) beta, (_MB_TYPE_D *) c, (_MB_CONST _MB_INT *) ldc ); } #undef _MB_TYPE_D #undef _MB_SYM #undef _MB_INT #undef _MB_CHAR #endif // #ifdef R_PACKAGE_FILE pcaPP/src/ML_passrng.cpp0000644000176200001440000000144413300577052014622 0ustar liggesusers#ifdef MATLAB_MEX_FILE #include "ML_passrng.h" #ifdef ES_DEV_ENV #include "../SMat/smat.meal.h" #include "../SMat/smat_meal_passrng.h" #include "../SMat/smat_meal_passrng_hpp.h" #else #include "smat.meal.h" #include "smat_meal_passrng.h" #include "smat_meal_passrng_hpp.h" #endif // #ifdef ES_DEV_ENV #include "matrix.h" void ML_pass_runif (int nlhs, mxArray* plhs[], int nrhs, mxArray *prhs[]) { mxArray *aData = prhs [0] ; int n = mxGetM (aData) * mxGetN (aData) ; double *pData = mxGetPr (aData) ; pass_runif (pData, n) ; } void ML_pass_rnorm (int nlhs, mxArray* plhs[], int nrhs, mxArray *prhs[]) { mxArray *aData = prhs [0] ; int n = mxGetM (aData) * mxGetN (aData) ; double *pData = mxGetPr (aData) ; pass_rnorm (pData, n) ; } #endif // #ifdef MATLAB_MEX_FILE pcaPP/src/smat_meal_passrng.h0000644000176200001440000000072313300577052015720 0ustar liggesusers#ifndef SMAT_MEAL_PASSRNG_H #define SMAT_MEAL_PASSRNG_H #ifdef ES_DEV_ENV #include "../SMat/smat.h" #else #include "smat.h" #endif class CPassRng { public: CPassRng () ; double Get () ; void Set (double *pData, t_size n) ; protected: SVecD m_data ; double *m_pCurData, *m_pDataEnd ; } ; void pass_runif (double *pd, int n) ; void pass_rnorm (double *pd, int n) ; void pass_rexp (double *pd, int n) ; #endif // #ifndef SMAT_MEAL_PASSRNG_H pcaPP/src/outSDo.cpp0000644000176200001440000000510613300577052013771 0ustar liggesusers#include "outSDo.h" #include "L1Median.h" double ApplyCenterMethod (const SCVecD &v, t_size dwMethod) { switch (dwMethod) { case 0: return 0 ; case 1: return mean (v) ; case 2: return median (v) ; } ASSERT (0) ; return 0 ; } #define IM_OBS 0 #define IM_DIFFOBS 1 #define IM_RANDOM 2 #define IM_RANDDIFFOBS 3 CSDoOut::CSDoOut (int *pnParIn, double *pdX, double *pdMaxMaha, int *pnNChanged) : m_dwN (pnParIn[0]), m_dwP (pnParIn[1]), m_dwIterMethod (pnParIn[2]), m_dwIterParam (pnParIn[3]), m_dwCenterMethod (pnParIn[4]), m_dwScatterMethod (pnParIn[5]), m_dwReset (pnParIn[6]) , m_mX (pdX, m_dwN, m_dwP) , m_vMaxMaha (pdMaxMaha, m_dwN) , m_dwNDir ((m_dwIterMethod == IM_OBS) ? m_dwN : m_dwIterParam) // number of checked directions , m_vXProj (m_dwN), m_vCurDir (m_dwP) , m_pnNChanged (pnNChanged), m_pdDiff (pdX) , m_pdXProj (m_vXProj), m_pdEndXProj (m_vXProj.GetDataEnd ()), m_pdMaxMaha (m_vMaxMaha) { } void CSDoOut::Calc () { if (m_dwReset) m_vMaxMaha.Reset (0) ; switch (m_dwIterMethod) { case IM_OBS : IterObs () ; break ; case IM_DIFFOBS : IterDiffObs (m_dwNDir) ; break ; case IM_RANDOM : IterRand (m_dwNDir) ; break ; case IM_RANDDIFFOBS : IterRandDiffObs (m_dwNDir) ; break ; } } void CSDoOut::IterObs () { t_size i ; double dNorm ; int nChanged ; // for (i = m_dwN - 1; i != NAI; i) // can't be used because of m_vChanged for (i = 0; i < m_dwN; ++i) { CopyRow (*m_vCurDir, m_mX, i) ; EO::SVc (dNorm = 0, m_vCurDir) ; EO::VSc (*m_vCurDir, sqrt (dNorm)) ; nChanged = DoDir (m_vCurDir) ; if (m_pnNChanged) m_pnNChanged[i] = nChanged ; // if (m_bSaveChanged) // m_vChanged(i) = nChanged ; } } void CSDoOut::IterDiffObs (int n) { } void CSDoOut::IterRandDiffObs (int n) { } void CSDoOut::IterRand (int n) { } int CSDoOut::DoDir (const SCVecD &vLoad) { m_vXProj.Reset (0) ; EO::VMcVct (*m_vXProj, m_mX, vLoad) ; const double dCenter = ApplyCenterMethod (m_vXProj, m_dwCenterMethod) ; const double dScatter = ApplyMethod (m_vXProj, m_dwScatterMethod) ; double *pProj = m_pdXProj, *pdMaxMaha = m_pdMaxMaha ; int nChanged = 0 ; double dDiff = 0, dCurMaha ; while (pProj < m_pdEndXProj) { //nChanged += sm_setmax_b (*pdMaxMaha, (*pProj - dCenter) / dScatter) ; dCurMaha = fabs(*pProj - dCenter) / dScatter ; if (dCurMaha > *pdMaxMaha) { *pdMaxMaha = dCurMaha ; ++nChanged ; dDiff += dCurMaha - *pdMaxMaha ; } ++ pProj ; ++ pdMaxMaha ; } return nChanged ; } pcaPP/src/L1Median_VardiZhang.cpp0000644000176200001440000001037713300577052016271 0ustar liggesusers#include "L1Median.h" t_size CL1Median_VZ::CheckRowSums (const double &dThreshold) { // counts the elements in array m_vRowSums which are greater than dThreshold t_size dwRet = 0 ; ASSERT (m_mIsZero.size () == m_vRowSums.size ()) ; const double *pRS = m_vRowSums, * const pEndRS = m_vRowSums.GetDataEnd () ; int *pZero = m_mIsZero ; while (pRS < pEndRS) { *pZero = *pRS > dThreshold ; if (*pZero) dwRet ++ ; ++pRS ; ++pZero ; } return m_dwN - dwRet ; } BOOL CL1Median_VZ::Iter () { m_vRowSums.Reset (0) ; EO::MVMcVct (!m_mXc, *m_vRowSums, m_mX, m_vMed) ; EO::V (*m_vRowSums) ; double dMin = min (m_vRowSums) ; t_size dwGreater = 0 ; EO::SScVc (dwGreater, dMin / m_dZeroTol, m_vRowSums) ; if (dwGreater * 2 > m_dwN) { // some of the elements of m_vRowSums are zero m_nEqs++ ; t_size dwZero = CheckRowSums (median (m_vRowSums) * m_dZeroTol) ; if (dwZero > m_dwNHalf) // there's more than half of the observations concentrated in one single point { if (m_nTrace >= 1) meal_printf ("%d >= n / 2 = %d observations concentrated in one point found.\r\n", dwZero) ; return FALSE ; } if (m_nTrace >= 1) meal_printf ("%d observations are exatly at the median.\r\n", dwZero) ; if (m_nTrace >= 0 && dwZero > 1) meal_warning ("The current L1median estimate is ident with more than one observation. The resulting l1median estimation might be incorrect. [CL1Median_VZ::Iter]") ; m_vTt.Reset (0) ; EO::VtMcVcVc_NC (*m_vTt, m_mX, m_mIsZero, m_vRowSums) ; m_vRt.Reset (0) ; EO::VtMcVcVc_NC (*m_vRt, m_mXc, m_mIsZero, m_vRowSums) ; double dTemp = 0 ; EO::SVcVc (dTemp, m_vRowSums, m_mIsZero) ; EO::VSc (*m_vTt, dTemp) ; dTemp = 0 ; EO::SVc (dTemp, m_vRt) ; double edivr = dwZero / sqrt (dTemp) ; if (edivr > 1) EO::VSc (*m_vMed, edivr) ; if (edivr < 1) EO::VScVc (*m_vMed, 1 - edivr, m_vTt) ; } else { m_vMed.Reset (0) ; EO::VtMcVc_NC (*m_vMed,m_mX, m_vRowSums) ; double dSum = 0 ; EO::SVc (dSum, m_vRowSums) ; EO::VSc (*m_vMed, dSum) ; } return TRUE ; } CL1Median_VZ::CL1Median_VZ (int *pnParIn, int *pnParOut, double *pdParIn, double *pdX, double *pdMed, double *pdWeights) : m_dwN (pnParIn[0]), m_dwP (pnParIn[1]), m_dwMaxIt (pnParIn[2]), m_dwUseWeights (pnParIn[3]) , m_nTrace (pnParIn[4]) , m_nRetCode (pnParOut[0]), m_nIter (pnParOut[1]) , m_dTol (pdParIn[0]), m_dZeroTol (pdParIn [1]) , m_dwNHalf (m_dwN >> 1) , m_nEqs (0) , m_mX (pdX, m_dwN, m_dwP), m_mXc (m_dwN, m_dwP) , m_vMed (pdMed, m_dwP), m_vRt (m_dwP), m_vTt (m_dwP), m_vOldMed (m_dwP) //, m_vWeights (pdWeights, m_dwN) , m_vRowSums (m_dwN), m_vTemp (m_dwN) , m_mIsZero (m_dwN) { Calc (pdWeights) ; } CL1Median_VZ::CL1Median_VZ (int n, int p, int &nCode, int &nIter, double *pdParIn, double *pdX, double *pdMed, double *pdWeights) : m_dwN (n), m_dwP (p), m_dwMaxIt ((int) pdParIn[0]), m_dwUseWeights (0) , m_nTrace ((int) pdParIn[1]) , m_nRetCode (nCode), m_nIter (nIter) , m_dTol (pdParIn[2]), m_dZeroTol (pdParIn [3]) , m_dwNHalf (m_dwN >> 1) , m_nEqs (0) , m_mX (pdX, m_dwN, m_dwP), m_mXc (m_dwN, m_dwP) , m_vMed (pdMed, m_dwP), m_vRt (m_dwP), m_vTt (m_dwP), m_vOldMed (m_dwP) //, m_vWeights (pdWeights, m_dwN) , m_vRowSums (m_dwN), m_vTemp (m_dwN) , m_mIsZero (m_dwN) { Calc (pdWeights) ; } void CL1Median_VZ::Calc (double *pdWeights) { if (pdWeights) m_vWeights.Set (pdWeights, m_dwN) ; t_size i ; for (i = m_dwMaxIt - 1; i != NAI; i--) { m_vOldMed.Copy (m_vMed) ; if (!Iter ()) break ; double dAbsDiff = 0, dAbsSum = 0 ; EO::SSVcVc_NC (dAbsSum, dAbsDiff, m_vMed, m_vOldMed) ; if (m_nTrace >= 2) { if (m_nTrace >= 3) { meal_printf ("k=%3d rel.chg=%12.15g, m=(",m_dwMaxIt - i, dAbsDiff/dAbsSum), meal_printf (")\n") ; } else meal_printf (".") ; } if (dAbsDiff < m_dTol * dAbsSum) break ; } if(m_nTrace) meal_printf (" needed %d iterations (%d of which had y==x_k)\r\n", m_dwMaxIt - i, m_nEqs) ; m_nIter = m_dwMaxIt - i ; } pcaPP/src/qnn.h0000644000176200001440000000071513300577052013016 0ustar liggesusers #ifdef ES_DEV_ENV #include "../../../SMat/smat.h" #else #include "smat.h" #endif #include "defint64.h" void qn (double &dQn, const double *pX, const int n) ; void qn_V (double &dQn, double *pX, const int n) ; void qn_nc (double &dQn, const double *pX, const int n) ; double qn_raw (double *pY, const int n) ; double qn (const SVDataD &a) ; double qn (const SCDataD &a) ; double qn_corrN (const int n, const double dQnCNorm = 2.21914446598508) ; pcaPP/src/R_package.h0000644000176200001440000000475013300577052014101 0ustar liggesusers#ifdef R_PACKAGE_FILE #ifdef ES_DEV_ENV #include "../../../RDev/R.Inc.h" #include "../../../SMat/smat.def.h" #else #include "R.Inc.h" #include "smat.def.h" #endif ///////////// // pcaPP // ///////////// EXPORT void C_pcaProj_up (int *pnParIn, double *pdParIn, double *pdX, double *pdZ, double *pdL, double *pdSDev) ; EXPORT void C_pcaProj (int *pnParIn, double *pdParIn, double *pdX, double *pdZ, double *pdL, double *pdSDev) ; EXPORT void C_sPCAgrid (int *pnParamIn, int *pnParamOut, double *pdParamIn, double *pdData, double *pdLoadings, double *pdSDev, double *pdObj/*, double *pdMaxMaha*/, double *pdLambda, double *pdBackTransHD) ; EXPORT void C_PCAgrid (int *pnParamIn, int *pnParamOut, double *pdParamIn, double *pdData, double *pdLoadings, double *pdSDev, double *pdObj/*, double *pdMaxMaha*/) ; ///////////////// // L1 Median // ///////////////// EXPORT void Hess_Sub_R (int *pnPar, double *pdX_i, double *pdMu, double *pdHess) ; EXPORT void Hess_R (int *pnPar, double *pdX, double *pdMu, double *pdHess) ; EXPORT void C_l1Median_VZ (int *pnParIn, int *pnParOut, double *pdParIn, double *pdX, double *pdMed/*, double *pdWeights*/) ; EXPORT void C_l1median_HoCr (int *pnParIn, int *pnParOut, double *pdParIn, double *pdX, double *pdMed) ; EXPORT void C_l1median_NM(int *pnParam, double *pdParam, double *pdData, /*double *pdParScale, */double *pdMRet) ; EXPORT void C_l1median_CG(int *pnParam, int *pnParam_Out, double *pdParam, double *pdParam_Out, double *pdData, /*double *pdParScale, */double *pdMRet) ; EXPORT void C_l1median_BFGS (int *pnParam_In, int *pnParam_Out, double *pdParam_In, double *pdParam_Out, double *pdData, /*double *pdParScale, */double *pdMRet) ; EXPORT void l1median_SA (int *pnParam_In, int *pnParam_Out, double *pdParam_In, double *pdParam_Out, double *pdData, /*double *pdParScale, */double *pdMRet) ; EXPORT void C_l1median_NLM (int *pnParam, double *pdParam, double *pdData, double *pdMRet/*, double *pdTypSize*/) ; EXPORT void C_l1median_NLM_Hess (int *pnParam, double *pdParam, double *pdData, double *pdMRet/*, double *pdTypSize*/) ; ////////// // Qn // ////////// EXPORT void C_qn (int *pnParIn, double *pdParIn, double *pdParOut, double *pdX) ; /////////////////// // Cov Kendall // /////////////////// EXPORT void C_kendallNlogN (double* arr1, double* arr2, int *pnPar, double *dRet) ; ////////////// // SDoOut // ////////////// EXPORT void SDoOut (int *pnParIn, double *pdX, double *pdMaxMaha, int *pnNChanged) ; #endif // #ifdef R_PACKAGE_FILE pcaPP/src/pcaPP.h0000644000176200001440000000275013300577052013226 0ustar liggesusers#ifndef ES_PCAPP_H #define ES_PCAPP_H #ifdef ES_DEV_ENV #include "../../../SMat/smat.h" #else #include "smat.h" #endif class UOP // User Operators { public: class Aa_AsDmB_dC { CALC_4_1(void) { a = (a-d*b)/c ; } } ; // adding and removing loadings for pcaPP::sPCAGrid... class Aa_AmC_p_DmB { CALC_4_1(void) { a = a * c + d * b ; } } ; class Apa_abs_BmDpCmE_ { CALC_5_1(void) { a += fabs (b * d + c * e) ; } } ; class Apa_pow_abs_B0mCpb1mD_B2 { CALC_4_1(void) { a += pow (fabs (b[0] * c + b[1] * d), b[2]) ; } } ; class Apa_abs_B { CALC_2_1(void) { a += fabs (b) ; } } ; class Apa_pow_abs_C_B { CALC_3_1(void) { a += pow (fabs (c), b) ; } } ; class aB_cA_C_le_D { CALC_4_2(void) { if (c < d) {b = 1 ; a += 1 ;} else b = 0 ; } } ; // b = c < d; a += c < d class Ba_BpC_d2_Apa_sq_B { CALC_3_2(void) { b = (b + c) / 2.0; a += sm_sqr (b) ; } } ; class ApaBm_signC { CALC_3_1(void) { if (c < 0) a-= b ; else a += b ; } } ; class Aa_As_sqrB { CALC_2_1(void) { a -= sm_sqr (b) ; } } ; class if_B_gr_0_AamA { CALC_2_1(void) { if (b > 0) a = -a ; } } ; // class Apa_sq_B_B_setsign_C { CALC_3_2(void) { a += sm_sqr (b) ; if (c < 0) b = -b ; } } ; // 2do: delete // class Aa_AmB_pC { CALC_3_1(void) { a = (a * b) + c ; } } ; // class Aa_AsC_dB { CALC_3_1(void) { a = (a - c) / b ; } } ; } ; double ApplyMethod (const SCVecD &v, const int nMethod) ; double ApplyMethod_V (const SVVecD &v, const int nMethod) ; #endif // #ifndef ES_PCAPP_H pcaPP/src/PCAgrid.cpp0000644000176200001440000004427413300577052014036 0ustar liggesusers#include "PCAgrid.h" #define CHECK_ORTH #define GLOBAL_POWER 2 // use 2 for maximizing (robust) variances, 1 for maximizing (robust) standard deviations. #if GLOBAL_POWER == 1 double ngpf (const double &d) {return d ; } #else #if GLOBAL_POWER == 2 double ngpf (const double &d) {return d * d ; } // #else: error, because gpf not defined. #endif #endif ///////////////// // CsPCAGrid // ///////////////// CsPCAGrid::CsPCAGrid (int *pnParamIn, int *pnParamOut, double *pdParamIn, double *pdData, double *pdLoadings, double *pdSDev, double *pdObj/*, double *pdMaxMaha*/, double *pdLambda, double *pdBackTransHD) : CPCAGrid (pnParamIn, pnParamOut, pdParamIn, pdData, pdLoadings, pdSDev, pdObj/*, pdMaxMaha*/) , m_nGloScatter (pnParamIn[9]), m_nSpeedUp (pnParamIn[11]), m_dwPHD (pnParamIn[10]) , m_dQ (pdParamIn[1]), m_dS (pdParamIn[2]) , m_bUseQ (m_dQ != 1.0), m_bUseS (m_dS != 1.0) // , m_bUseQ (TRUE), m_bUseS (TRUE) , m_vLambda (pdLambda, m_dwK), m_vTempP (m_dwP), m_vTempPSub (m_dwP) , m_dGloScatter (1) { if (m_dwPHD) // always false for sPCAgrid { m_mBackTransHD.Set (pdBackTransHD, m_dwPHD, m_dwP) ; m_mBackProj.Require (m_dwP, m_dwPHD) ; m_vLoadHD.Require (m_dwPHD) ; m_vSumLoadOthers.Require (m_dwPHD) ; } else { m_mBackProj.Require (m_dwP, m_dwP) ; m_vSumLoadOthers.Require (m_dwP) ; } if (!m_dwCheckOrth && m_nGloScatter == 0) m_dGloScatter = ngpf (ApplyMethodMean (m_mX)) ; // else if (m_nGloScatter == -1) // m_dGloScatter = 1 ; } void CsPCAGrid::OnCalcPC () { if (!m_dwCheckOrth && m_nGloScatter == 1) m_dGloScatter = ngpf (ApplyMethodMean (TempY ())) ; //meal_printf ("gloscat %f\r\n", m_dGloScatter) ; m_vTempPSub.Reshape (m_dwPSub) ; m_dCurLambda = m_vLambda (m_dwCurK - m_dwkIni) ; //meal_printf ("Glo scat for dim %d = %f\r\n", m_dwCurK, sqrt (m_dGloScatter)) ; // calc new backtransformation matrix. if (m_dwPHD) // always false sPCAgrid sme_matmult_R (m_mBackTransHD, m_mL.GetColRef (m_dwCurK, m_dwP), !m_mBackProj) ; else m_mBackProj.Copy_R (m_mL.GetColRef (m_dwCurK, m_dwP)) ; // 2do: use a reference! } void CsPCAGrid::InitPenalty () { m_vSumLoadOthers.Reset (0) ; EO::VMcVct (*m_vSumLoadOthers, m_mBackProj, m_vAfin) ; m_vSumLoadThis.Copy_R (m_mBackProj.GetColRef (m_dwCurP)) ; // 2do: try simple assignment or use this column directly where m_vSumLoadThis is needed! } // computes the objective function of a direction double CsPCAGrid::CalcObj ( const double dCos, const double dSin // the direction to be examined , double &dScat // (output) the scatter of a matrix cbind (m_vSumLoadThis, m_vSumLoadOthers) projected onto a direction (dCos, dSin) , double &dScatOrth) // (output) the scatter of a matrix cbind (m_vSumLoadThis, m_vSumLoadOthers) projected onto a direction (dSin, dCos) // (-> maybe dSin and dCos are mixed up in this comment) { dScat = CalcProjScat (dCos, dSin) ; if (m_dwCheckOrth) // don't care about the experimental "m_dwCheckOrth" - option so far { // it's always off for sPCAgrid // CalcMaha (dScat) ; dScatOrth = CalcProjScat (-dSin, dCos) ; // CalcMaha (dScatOrth) ; return ngpf (dScat / dScatOrth) + GetPenalty (dCos, dSin); ; //// dCurObj /= ngpf (dScatOrth + dCurScat * 0.001) ; //// dCurObj /= (m_dGloScatter + ngpf (dScatOrth)) ; } return // the objective function's value: ngpf (dScat) // the scatter (or variance) of the data projected onto the current direction // ngpf(x) returns either x, or x^2, depending on the definition of GLOBAL_POWER // NOTE: GLOBAL_POWER is now deprecated, as a "q" and an "s" parameter are available in "GetPenalty", which do provide the same functionality + GetPenalty (dCos, dSin) // + the penalty function for the current direction * m_dGloScatter; // * some normalization factor for the overall variance of the data in the currently considered subspace } // computes the sparseness - penalty term for a direction double CsPCAGrid::GetPenalty (const double& dCos, const double& dSin) // dCos & dSin specify the direction to be checked { /* // computing the Sparseness penalty: r = c (dSin, dCos) ; z = cbind (m_vSumLoadOthers, m_vSumLoadThis) return sum ((abs (z %*% r))^q)^p ; // the sparseness - criterion */ ASSERT (!m_nSpeedUp) ; // the old penalty stuff has not been implemented here... if (m_dCurLambda == 0) return 0 ; double dRet = 0 ; if (m_bUseQ) // the q-parameter for the norm is != 1 { const double adParams [] = {dCos, dSin, m_dQ} ; if (fabs (dCos) <= m_dZeroTol) // the value of dCos is zero EO::SScVc (dRet, m_dQ, m_vSumLoadThis) ; // specific (faster) compuation for dCos == 0 // computes dRet = sum (abs (m_vSumLoadOthers) ^ m_dQ) /* DESCRIPTION of matrix computation: A B C EO::SScVc (dRet, m_dQ, m_vSumLoadThis) Apa_pow_abs_C_B <==> A += pow (abs (C), B) (for each value of C) pa == plus assign (+=) p = plus m = multiply d = divid s = subtract */ else if (fabs (dSin) <= m_dZeroTol) // the value of dSin is zero EO::SScVc (dRet, m_dQ, m_vSumLoadOthers) ;// specific (faster) computation for dSim == 0 // computes dRet = sum (abs (m_vSumLoadOthers) ^ m_dQ) else // dCos != 0 && dSin != 0 -> no simple computation possible //EO::SScScVcVc_NC (dRet, dCos, dSin, m_vSumLoadOthers, m_vSumLoadThis) ; EO::SSVcVc_NC (dRet, adParams, m_vSumLoadOthers, m_vSumLoadThis) ; // computes dRet = sum (abs (dCos * m_vSumLoadOthers + dSin * m_vSumLoadThis) ^ m_dQ) } else { if (fabs (dCos) <= m_dZeroTol) EO::SVc (dRet, m_vSumLoadThis) ; // computes dRet = sum (abs (m_vSumLoadThis)) else if (fabs (dSin) <= m_dZeroTol) EO::SVc (dRet, m_vSumLoadOthers) ; else // computes dRet = sum (abs (m_vSumLoadOthers)) EO::SScScVcVc_NC (dRet, dCos, dSin, m_vSumLoadOthers, m_vSumLoadThis) ; // computes dRet = sum (abs (dCos * m_vSumLoadOthers + dSin * m_vSumLoadThis)) } if (m_bUseS) // the s - parameter (for the norm) is != 1 dRet = pow (dRet, m_dS) ; return - dRet * m_dCurLambda ; // dRet *= - m_dCurLambda ; // if (!m_dwCheckOrth) // dRet *= m_dGloScatter ; // // return dRet ; } //////////////// // CPCAGrid // //////////////// CPCAGrid::CPCAGrid (int *pnParamIn, int *pnParamOut, double *pdParamIn, double *pdData, double *pdLoadings, double *pdSDev, double *pdObj/*, double *pdMaxMaha*/) : m_dwN (pnParamIn[0]), m_dwP (pnParamIn[1]), m_dwK (pnParamIn[2]), m_dwSplitCircle (pnParamIn[3]), m_dwMaxIter (pnParamIn[4]), m_dwMethod (pnParamIn[5]), m_dwTrace (pnParamIn[6]), m_dwkIni (pnParamIn[7]), m_dwCheckOrth (pnParamIn[8]) , m_nReturn (pnParamOut [0]) , m_dZeroTol (pdParamIn[0]) , m_mX (pdData, m_dwN, m_dwP), m_mL (pdLoadings, m_dwP, m_dwP)//, m_mTempPP(m_dwP, m_dwP), m_mTempPN(m_dwN, m_dwP) , m_vAfin(m_dwP), m_vAfinBest (m_dwP), m_vScl(m_dwP), m_vYOpt (m_dwN), m_vSDev(pdSDev, m_dwP), m_vObj (pdObj, m_dwK) , m_vProj (m_dwN)//, m_vMaxMaha (pdMaxMaha, m_dwN) , m_vOrd (m_dwP) , m_dwCurK (0), m_dwCurP (0), m_dwPSub (0), m_dwTempYIdx (0) , m_pdProj (m_vProj)//, m_pdEndProj (m_vProj.GetDataEnd ()) , m_pdCurLC (m_vYOpt), m_pdCurLCEnd (m_vYOpt.GetDataEnd ()) { m_mY[0].Require (m_dwN, m_dwP) ; m_mY[1].Require (m_dwN, m_dwP) ; // m_vMaxMaha.Reset (0) ; } int CPCAGrid::Calc () { if (m_dwK > m_dwP) return 1 ; // k > p /* if ((m_nSplitCircle & 1) == 0) // //if (m_dwSplitCircle & 1) // only allow even values for splitcircle ++ m_nSplitCircle ;*/ if (m_dwkIni) sme_matmult_R (m_mX, m_mL.GetColRef (m_dwkIni, m_dwP), !TempY ()) ; else { TempY ().Copy (m_mX) ; SetDiag_sq (!m_mL) ; //m_mL.setdiag () ; // this MUST now happen in the calling R routine! // this has been changed when introducing the m_dwkIni argument // why not here? } for (m_dwCurK = m_dwkIni; m_dwCurK < m_dwK; m_dwCurK++) // for each PC which to be computed { m_dwPSub = m_dwP - m_dwCurK ; // dimensionality of the subspace OnCalcPC () ; if (m_dwPSub == 1) // only 1 dimension left -> return this direction { m_vSDev (m_dwCurK) = ApplyMethod (TempY ().GetColRef (0)) ; continue ; // break ; } m_vScl.Reshape (m_dwPSub) ; m_vOrd.Reshape (m_dwPSub) ; ApplyMethod (TempY (), m_vScl) ; // 2do: m_vScl can be a temporary vector meal_sort_order_rev (m_vScl, m_vOrd, m_vScl.size ()) ; // gets the order (m_vOrd) of the dimensions regarding to their variance (m_vScl) in decreasing order m_dwCurP = m_vOrd(0) ; // index of the coloumn of x with biggest scatter m_vAfinBest.Reshape (m_dwPSub) ; m_vAfin.Reshape (m_dwPSub) ; m_vAfin.Reset (0) ; m_vAfin (m_dwCurP) = 1 ; CopyCol (*m_vYOpt, TempY (), m_dwCurP) ; // loads the loading with max scatter as the initial solution t_size i, j ; double dCurSplit ; double dScatBest = 0 ; double dObjBest = 0 ; for (i = 0; i <= m_dwMaxIter; i++) // the outer iteration, which subsequently decreases the gridsize ( = dCurSplit) { //double dScat, dObj, dSumAbsDelta = 0 ; // 2do: check if it's better to use * 0.5 each time? dCurSplit = pow (0.5, (double) i) ; // the current gridSize for (j = 0; j < m_dwPSub; j++) // for each loading in the current solution { m_dwCurP = m_vOrd (j) ; // m_dwCurP = the j-th largest coponent // the m_dwCurP-st loading in tje current solution is now altered in order to increase the objective function m_vCurY = TempY ().GetColRef (m_dwCurP) ; // 2do: move this 2 rows down. m_pdCurY = m_vCurY ; const double dL = m_vAfin (m_dwCurP) ; // current loading if (fabs (dL) == 1) continue ; RemoveLoading (/*i*/) ; m_dNL = dL ; GridPlane (dCurSplit) ; // increasing the objective function by trying several directions on a grid AddLoading (m_dNL, m_dNCL) ; // add the found loading tho the current solution //double dNL = dL, dNCL ; //GridPlane (dNL, dNCL, dScat, dObj, dCurSplit) ; //AddLoading (dNL, dNCL) ; //dSumAbsDelta += fabs (dL - dNL) ; } EO::VSc (*m_vAfin, norm2 (m_vAfin)) ; // 2do: check norm of m_vAfin. should be 1 anyway!, if not it's sufficient to perform this normalization after this for loop, only with the m_vAfinBest - vector! if (!i || dObjBest <= m_dBestObj) // checking whether we've found a better solution -> if true store it. { dObjBest = m_dBestObj ; m_vAfinBest.Copy_NC (m_vAfin) ; dScatBest = m_dCurScat ; } //meal_printf ("delta: %.22f ->", dSumAbsDelta) ; /* if (dSumAbsDelta <= m_dZeroTol) // no changes of any loading -> quit // doesn't make sense as we're operating on a raster //if (dCurSplit<= m_dZeroTol) // no changes of any loading -> quit { //meal_printf ("stop iteration\n") ; if (m_dwTrace >= 3) meal_printf ("Calculation of PC %d stopped after %d loops\r\n", m_dwCurK + 1, i + 1) ; break ; } //meal_printf ("continue iteration\n") ; */ } m_vSDev (m_dwCurK) = dScatBest ; // 2do: use ptrs instead of vector access! m_vObj(m_dwCurK) = dObjBest ; BackTransform () ; } return 0 ; } void CPCAGrid::BackTransform () { ASSERT_TEMPRANGE (0, 2) ; SMatD m_mTempPP (tempRef (0), m_dwPSub, m_dwPSub) ; SetDiag_sq (!m_mTempPP) ; int dwIdxRef = m_vOrd (0) ; set_neg (*m_vAfinBest) ; m_vAfinBest (dwIdxRef) += 1 ; double dNorm = norm2 (m_vAfinBest) ; if (dNorm > m_dZeroTol) { static const double dSqrt2 = sqrt ((double) 2.0) ; EO::VSc (*m_vAfinBest, dNorm / dSqrt2) ; EO::MVcVct (!m_mTempPP, m_vAfinBest, m_vAfinBest) ; } SMatD mProjSorted (tempRef (1), m_dwPSub, m_dwPSub) ; mProjSorted.CopyCol_Order_NC (m_mTempPP, *m_vOrd) ; // undo sorting SMatD mOldLoadings (tempRef (2), m_dwP, m_dwPSub) ; // 2do: copying cols should be done in constructor (using GetColRef () CopyCol (!mOldLoadings, m_mL, m_dwCurK, m_dwP) ; sme_matmult (mOldLoadings, mProjSorted, !m_mL.GetColRef (m_dwCurK, m_dwP)) ; sme_matmult_R (TempY (), mProjSorted.GetColRef (1, m_dwPSub), !TempYC ()) ; SwapTempY () ; } void CPCAGrid::RemoveLoading (/*int i*/) { const double &dL = m_vAfin (m_dwCurP) ; if (dL == 0) return ; const double dCL = sqrt (1.0 - sm_sqr (dL)) ; // current loading and complementary loading, such that dL^2 + dCL^2 == 1 EO::VScScVc (*m_vYOpt, dL, dCL, m_vCurY) ; // m_vYOpt = m_vYOpt EO::VSc (*m_vAfin, dCL) ; m_vAfin(m_dwCurP) = 0 ; } void CPCAGrid::AddLoading (const double &dNL, const double &dNCL) { // dNL ... New Loading // dNCL ... New Complement Loading EO::VScScVc (*m_vYOpt, dNL, dNCL, m_vCurY) ; // m_vYOpt = m_vYOpt * dNCL + dNL * m_vCurY // Aa_AmC_p_DmB = A = A*C + D*B //(*m_vYOpt, dNL, dNCL, m_vCurY) == (A, B, C, D) EO::VSc (*m_vAfin, dNCL) ; // m_vAfin = m_vAfin * dNCL m_vAfin (m_dwCurP) = dNL ; // m_vAfin[m_dwCurP] = dNL } double CPCAGrid::ApplyMethodMean (const SCMatD &m) { double dSd = 0 ; int i ; for (i = m.ncol () - 1; i != (int) -1; i--) dSd += sm_sqr(ApplyMethod (m.GetColRef (i))) ; return sqrt (dSd / m.ncol ()) ; } void CPCAGrid::ApplyMethod (const SCMatD &m, SVecD &v) { v.Reshape (m.ncol ()) ; int i ; for (i = m.ncol () - 1; i != (int) -1; i--) v(i) = ApplyMethod (m.GetColRef (i)) ; } double CPCAGrid::ApplyMethod (const SCVecD &v) // 2do: remove.. { return ::ApplyMethod (v, m_dwMethod) ; } // projects the (2d) scores cbind (m_pdCurLC, m_pdCurY) onto the direction c(dCos, dSin) and computes a scale estimate of the projected data double CPCAGrid::CalcProjScat (const double dCos, const double dSin) { const double *pYOpt = m_pdCurLC, *pCurY = m_pdCurY ; double *pProj = m_pdProj ; while (pYOpt < m_pdCurLCEnd) // projecting the data { *pProj = *pYOpt * dCos + *pCurY * dSin ; ++pProj ; ++pYOpt ; ++pCurY ; } return ApplyMethod (m_vProj) ; // computing the scale estimate } /* void CPCAGrid::CalcMaha (const double dScat) { double *pProj = m_pdProj ; double *pdProjEnd = m_pdProj + m_dwN ; double *pdMaha = m_vMaxMaha ; while (pProj < pdProjEnd) { sm_setmax (*pdMaha, *pProj / dScat) ; ++pdMaha ; ++pProj ; } } */ double CPCAGrid::CalcObj (const double dCos, const double dSin, double &dScat, double &dScatOrth) { dScat = CalcProjScat (dCos, dSin) ; if (m_dwCheckOrth) // always false for PCAgrid { // CalcMaha (dScat) ; dScatOrth = CalcProjScat (dCos, -dSin) ; // CalcMaha (dScatOrth) ; return ngpf (dScat / dScatOrth) ; //// dCurObj /= ngpf (dScatOrth + dCurScat * 0.001) ; //// dCurObj /= (m_dGloScatter + ngpf (dScatOrth)) ; } return ngpf (dScat) ; // the PCAgrid objective function is equal to the scatter of the projected data } void CPCAGrid::EvalDirection (const double dCos, const double dSin) { double dScat, dScatOrth ; double dCurObj = CalcObj (dCos, dSin, dScat, dScatOrth) ; if (dCurObj > m_dBestObj) { m_dBestObj = dCurObj ; m_dCurScat = dScat ; m_dCurScatOrth = dScatOrth ; m_dNL = dSin ; m_dNCL = dCos ; } } double CPCAGrid::CalcVarTrimmed (double dCos, double dSin, double dScat, double dScatOrth) { if (dScatOrth <= m_dZeroTol || dScat <= m_dZeroTol) return dScat ; const double *pYOpt = m_pdCurLC, *pCurY = m_pdCurY ; double dCurProj, dCurProjOrth ; dScat = 1 / dScat ; dScatOrth = 1 / dScatOrth ; double dS = 0, dSS = 0 ; int n = 0 ; while (pYOpt < m_pdCurLCEnd) { dCurProj = *pYOpt * dCos + *pCurY * dSin ; dCurProjOrth = *pYOpt * dSin - *pCurY * dCos ; if (sm_sqr (dCurProj) * dScat + sm_sqr (dCurProjOrth) * dScatOrth < 6) { dS += dCurProj ; dSS += sm_sqr (dCurProj) ; ++n ; } ++pYOpt ; ++pCurY ; } return (dSS / n - (sm_sqr (dS / n))) * n / (n - 1.0) * 1.3178; // correction factor 1.3178 for 95% quantile in sqr maha distance (6) } double CPCAGrid::CalcScatTrimmed (double dCos, double dSin, double dScat, double dScatOrth) { if (dScatOrth <= m_dZeroTol || dScat <= m_dZeroTol) return dScat ; const double *pYOpt = m_pdCurLC, *pCurY = m_pdCurY ; double dCurProjOrth ; double *pProj = m_pdProj ; while (pYOpt < m_pdCurLCEnd) { dCurProjOrth = *pYOpt * dSin - *pCurY * dCos ; if (sm_sqr (dCurProjOrth) / dScatOrth <= 3.841459) { *pProj = *pYOpt * dCos + *pCurY * dSin ; ++pProj ; } ++pYOpt ; ++pCurY ; } // return (dSS / n - (sm_sqr (dS / n))) * n / (n - 1.0) * 1.3178; // correction factor 1.3178 for 95% quantile in sqr maha distance (6) return ApplyMethod (SVecD (m_pdProj, pProj - m_pdProj)) ; } void CPCAGrid::GridPlane (double dCurSplit) { const double dASinNL = asin (m_dNL) ; const double dSm1 = (m_dwSplitCircle > 1) ? m_dwSplitCircle - 1 : 1 ; double dSplitFact = meal_PI () * dCurSplit ; InitPenalty () ; t_size i ; ASSERT_TEMPRANGE (11, 11) ; SVecD vProj (tempRef (11), m_dwN) ; m_dBestObj = meal_NegInf () ; if (m_dNL && fabs (m_dNL) < 1e-6) EvalDirection (1, 0) ; const t_size dwEnd = (dCurSplit == 1.0) ? m_dwSplitCircle - 1 : m_dwSplitCircle ; // dCurSplit means, that we're checking an angle of 180 ( = PI). thus the first and last checked point would be the same. for (i = 0; i < dwEnd; i++) { double dAngle = (i / dSm1 - 0.5) * dSplitFact + dASinNL; EvalDirection (cos (dAngle), sin (dAngle)) ; } if (m_dwCheckOrth) // always false for PCAgrid and sPCAgrid m_dCurScat = sqrt (CalcVarTrimmed (m_dNCL, m_dNL, m_dCurScat, m_dCurScatOrth)) ; // m_dCurScat = CalcScatTrimmed (m_dNCL, m_dNL, m_dCurScat, m_dCurScatOrth) ; // else // m_dCurScat = m_dCurScat ; } pcaPP/src/smat.sort.h0000644000176200001440000000326713300577052014161 0ustar liggesusers/* SMat - Simple Matrix Classes v0.1beta Copyright (C) 2011 by Heinrich Fritz (heinrich_fritz@hotmail.com) This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . */ #ifndef SMAT_SORT_H #define SMAT_SORT_H #include "smat.base.h" void sort_R (const SCData &a, SVecD &b) ; void sort (const SCData &a, const SVecD &b) ; void sort_NC (const SCData &a, const SVecD &b) ; void sort (const SVData &a) ; void sort_order (const SVData &a, const SVData &b) ; void sort_order_NC (const SVData &a, const SVData &b) ; template T psort_V (const SVData &a, t_size k) { T *pA = a ; double pivot, swapBuf ; t_size l = 0, lr = a.size () - 1, jnc, j ; while (l < lr) { pivot = pA[k] ; jnc = l ; j = lr ; while (jnc <= j) { while (pA[jnc] < pivot) ++jnc ; while (pA[j] > pivot) --j ; if(jnc <= j) { sm_swap (pA [jnc], pA[j], swapBuf) ; ++jnc ; --j ; } } if (j < k) l = jnc ; if (k < jnc) lr = j ; } return pA [k] ; } #endif // #ifndef SMAT_SORT_H pcaPP/src/PCAproj.h0000644000176200001440000000140413300577052013514 0ustar liggesusers#include "pcaPP.h" class CPCAproj { public: CPCAproj (int *pnParIn, double *pdParIn, double *pdX, double *pdZ, double *pdL, double *pdSDev) ; void Calc () ; protected: void SetSingular (t_size dwK) ; virtual void Update (const SVecD &vCurEVec) {} const t_size m_dwN, m_dwP, m_dwRealN, m_dwK ; t_size m_dwShortN ; const int m_nScal, m_nScores ; const double m_dZeroTol ; double m_dCurLambda ; SMatD m_mX, m_mL, m_mZ, m_mA ; SVecD m_vSDev, m_vCurScore ; SVecN m_vHelpTF ; } ; class CPCAprojU : public CPCAproj { public: CPCAprojU (int *pnParIn, double *pdParIn, double *pdX, double *pdZ, double *pdL, double *pdSDev) ; protected: const t_size m_dwMaxIt, m_dwMaxHalf ; virtual void Update (const SVecD &vCurEVec) ; } ; pcaPP/src/smat.cpp0000644000176200001440000006116513300577052013527 0ustar liggesusers/* SMat - Simple Matrix Classes v0.1beta Copyright (C) 2011 by Heinrich Fritz (heinrich_fritz@hotmail.com) This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . */ #define SMAT_FLAG_NO_INI #include "smat.h" #undef SMAT_FLAG_NO_INI //#include #include "smat.meal.h" void *smat_malloc (t_size dwSize) // 2do: move to meal (use e.g. R_malloc) { return new char [dwSize] ; } void smat_free (void *pPtr) { delete [] (char *) pPtr ; } /* void *smat_realloc (void *pOld, t_size dwOld, t_size dwNew) // 2do: remove { void *pNew = smat_malloc (dwNew) ; if (dwOld && pOld) memcpy (pNew, pOld, sm_min (dwOld, dwNew)) ; delete [] (char *) pOld ; return pNew ; } */ //////////////// // SMat_EXC // //////////////// void SMat_EXC::OnException () { meal_OnException (GetDate (), GetFile (), GetLine ()) ; } void SMat_EXC::OnUException () { meal_OnUException () ; } //////////////// // SDataRef // //////////////// SDataRef::SDataRef () // 2do: rename to SDataRef or CDataRef : m_pData (NULL), m_pDataEnd (NULL), m_dwRef (0), m_dwCount (0), m_bOwner (TRUE), m_bStatic (FALSE) { } SDataRef::SDataRef (const t_size dwCount) : m_dwRef (0), m_bOwner (TRUE), m_bStatic (FALSE) { Alloc_NF (dwCount) ; } SDataRef::SDataRef (const t_size dwCount, void * const pData) : m_pData (pData), m_pDataEnd ((char *) pData + dwCount), m_dwRef (0), m_dwCount (dwCount), m_bOwner (FALSE), m_bStatic (FALSE) { ASSERT (pData) ; } SDataRef::~SDataRef () { Free () ; } void SDataRef::Free () { if (IsOwner ()) //free (m_pData) ; smat_free (m_pData) ; //delete [] (char *) m_pData ; m_pData = NULL ; m_pDataEnd = NULL ; m_dwCount = 0 ; } void SDataRef::FreeIfIdle () { if ((m_bStatic && m_dwRef <= 1) || !m_dwRef) Free () ; } void Deref (SDataRef *&pRef) { SDataRef::sDeref (pRef) ; } void SDataRef::sDeref (SDataRef *&pRef) { if (pRef->Deref ()) delete pRef ; pRef = NULL ; } SDataRef *SDataRef::Ref (SDataRef *&pRef) { if (pRef == this) return this ; if (pRef) pRef->Deref () ; return Ref_NDR (pRef) ; } SDataRef *SDataRef::Ref_NDR (SDataRef *&pRef) // No DeRereference { IncRef () ; return pRef = this ; } BOOL SDataRef::Deref () { --m_dwRef ; return !m_dwRef/* && !m_bStatic*/ ; } SDataRef *SDataRef::Recreate (t_size dwSize, SDataRef *&pRef) { THROW (IsOwner ()) ; if (GetRef () <= 1 || IsStatic ()) Alloc (dwSize) ; else (new SDataRef (dwSize))->Ref (pRef) ; return pRef ; } void SDataRef::Alloc (t_size dwSize) { Free () ; Alloc_NF (dwSize) ; } void SDataRef::Alloc_NF (t_size dwSize) { if (dwSize) { GetDataRef () = smat_malloc (dwSize) ; // GetDataRef () = new char [dwSize] ; GetSizeRef () = dwSize ; GetDataEndRef () = (char *) GetData () + GetSize () ; } else { GetDataRef () = NULL ; GetSizeRef () = 0 ; GetDataEndRef () = NULL ; } } BOOL SDataRef::Require (t_size dwSize, SDataRef *&pRef) { if (dwSize <= GetSize ()) return FALSE ; Recreate (dwSize, pRef) ; return TRUE ; } SDataRef &SDataRef::Empty () { static SDataRef_Static emptyDR (0, FALSE) ; return emptyDR ; } /////////////////////// // SDataRef_Static // /////////////////////// SDataRef_Static::SDataRef_Static (const t_size dwCount, const BOOL bStatic) : t_base (dwCount) { IncRef () ; if (bStatic) SetStatic () ; } SDataRef_Static::~SDataRef_Static () { DecRef () ; ASSERT (!m_dwRef) ; } SDataRef_Static &SDataRef_Static::Require (t_size dwSize) { SDataRef *pFoo ; t_base::Require (dwSize, pFoo) ; return *this ; } //////////////////// // SDataRefCont // //////////////////// SDataRefCont::SDataRefCont () :m_ppData (NULL), m_dwSize (0) { } SDataRefCont::~SDataRefCont () { Free () ; } void SDataRefCont::Require (t_size dwCount) { if (dwCount <= GetSize ()) return ; t_pitem *pNew = new t_pitem [dwCount] ; // do a realloc for dataRef () with size dwCount if (GetSize ()) memcpy (pNew, GetData (), GetMemSize ()) ; delete [] GetData () ; dataRef () = pNew ; //m_ppData = (t_pitem *) realloc (m_ppData, dwCount * sizeof (t_pitem)) ; //m_ppData = (t_pitem *) smat_realloc (m_ppData, m_dwSize * sizeof (t_pitem), dwCount * sizeof (t_pitem)) ; t_size i ; for (i = GetSize (); i < dwCount; ++i) GetData () [i] = new t_item ; sizeRef () = dwCount ; } SDataRef_Static &SDataRefCont::Item (t_size dwIdx) { Require (dwIdx + 1) ; return *GetData ()[dwIdx] ; } void SDataRefCont::Free () { t_size i ; for (i = GetSize () - 1; i != NAI; i--) delete GetData () [i] ; //free (GetData ()) ; //smat_free (GetData ()) ; delete [] GetData () ; dataRef () = NULL ; sizeRef () = 0 ; } void SDataRefCont::FreeIfIdle () { t_size i ; for (i = GetSize () - 1; i != NAI; i--) Item (i).FreeIfIdle () ; } //////////////////// // CDataCont_NT // //////////////////// t_size &CDataCont_NT::GetInstanceCount () { static t_size dwInstanceCount = 0 ; return dwInstanceCount ; } //////////////////////// // Temp - Functions // //////////////////////// SDataRefCont &GetTempCont () { static SDataRefCont cont; return cont ; } void RequireTemp (t_size dwCount) { GetTempCont().Require (dwCount) ; } SDataRef_Static &tempRef (t_size dwIdx) { return GetTempCont().Item (dwIdx) ; } SDataRefCont::CRefRange &GetPermTempRefRange () { static SDataRefCont::CRefRange obj ; return obj ; } void FreeTempCont () { GetTempCont ().FreeIfIdle () ; } //////// //////// //////// // smateasymath.h //////// // 2do: sort this file! //////// void sme_matmult_R (const SCMatD &a, const SCMatD &b, SVMatD &c) { THROW (a.ncol () == b.nrow ()) ; c.Require (a.nrow (), b.ncol ()) ; sme_matmult_NC (a, b, c) ; } void sme_matmult (const SCMatD &a, const SCMatD &b, const SVMatD &c) { THROW (a.ncol () == b.nrow ()) ; THROW (a.nrow () == c.nrow () && c.ncol () == b.ncol ()) ; sme_matmult_NC (a, b, c) ; } void sme_matmult_NC (const SCMatD &a, const SCMatD &b, const SVMatD &c) { ASSERT (a.ncol () == b.nrow ()) ; ASSERT (a.nrow () == c.nrow () && c.ncol () == b.ncol ()) ; double one = 1.0, zero = 0.0; if (a.nrow () > 0 && a.ncol () > 0 && b.nrow () > 0 && b.ncol () > 0) { meal_gemm( "N", "N", a.nrowPtrS (), b.ncolPtrS (), b.nrowPtrS (), &one, a.GetData (), a.nrowPtrS (), b.GetData (), b.nrowPtrS (), &zero, c.GetData (), a.nrowPtrS () ); } else c.Reset (0) ; } void sme_tmatmult_R (const SCMatD &a, const SCMatD &b, SVMatD &c, const BOOL bTransA, const BOOL bTransB) { c.Require (a.GetDim (bTransA), b.GetDim (!bTransB)) ; sme_tmatmult_NC (a, b, c, bTransA, bTransB) ; } void sme_tmatmult (const SCMatD &a, const SCMatD &b, const SVMatD &c, const BOOL bTransA, const BOOL bTransB) { THROW (a.GetDim (!bTransA) == b.GetDim (bTransB)) ; THROW (a.GetDim (bTransA) == c.nrow () && c.ncol () == b.GetDim (!bTransB)) ; sme_tmatmult_NC (a, b, c, bTransA, bTransB) ; } void sme_tmatmult_NC (const SCMatD &a, const SCMatD &b, const SVMatD &c, const BOOL bTransA, const BOOL bTransB) { //ASSERT (a.ncol () == b.nrow ()) ; ASSERT (a.GetDim (!bTransA) == b.GetDim (bTransB)) ; ASSERT (a.GetDim (bTransA) == c.nrow () && c.ncol () == b.GetDim (!bTransB)) ; //ASSERT (a.nrow () == c.nrow () && c.ncol () == b.ncol ()) ; double one = 1.0, zero = 0.0; if (a.nrow () > 0 && a.ncol () > 0 && b.nrow () > 0 && b.ncol () > 0) { meal_gemm( bTransA ? "T" : "N", bTransB ? "T" : "N", a.GetDimPtrS_NC (bTransA), b.GetDimPtrS_NC (!bTransB), b.GetDimPtrS_NC (bTransB), &one, a.GetData (), a.nrowPtrS (), b.GetData (), b.nrowPtrS (), &zero, c.GetData (), a.GetDimPtrS_NC (bTransA) ); } else c.Reset (0) ; } void sme_diag_R (const SVMatD &a, SVecD &c) { c.Require (sm_min (a.nrow (), a.ncol ())) ; sme_diag_NC (a, c) ; } void sme_diag (const SVMatD &a, SVecD &c) { THROW (c.size () == ::sm_min (a.nrow (), a.ncol ())) ; sme_diag_NC (a, c) ; } void sme_diag_NC (const SVMatD &a, SVecD &c) { const t_size inc = a.GetColInc () + 1 ; double *pCur = a.GetData () ; t_size i ; for (i = 0; i < c.size (); i++) { c(i) = *pCur ; pCur += inc ; } } ///////////////////// // smat.random.h // ///////////////////// double runif () { return meal_unif_rand () ; } double rnorm () { return meal_norm_rand () ; } double rexp () { return meal_exp_rand () ; } void runif (const SVData &a) { runif_raw (a, a.GetDataEnd ()) ; } void runif_raw (double *p, double *pEnd) { for (; p < pEnd; ++p) *p = runif () ; } void runif_r (const SVData &a) { runif_r_raw (a, a.GetDataEnd ()) ; } void runif_r_raw (double *p, double *pEnd) { for (--pEnd; p <= pEnd; --pEnd) *pEnd = runif () ; } void rnorm (const SVData &a) { rnorm_raw (a, a.GetDataEnd ()) ; } void rnorm_raw (double *p, double *pEnd) { for (; p < pEnd; ++p) *p = rnorm () ; } void runif_raw (double *d, int l, double dL, double dU) { runif_raw (d, d + l, dL, dU) ; } void runif_raw (double *d, double * const pEnd, double dL, double dU) { dU -= dL ; for ( ;d < pEnd; ++d) *d = runif () * dU + dL ; } void SampleNoReplace(int k, int n, int *y, int *x) { int i, j; for (i = n - 1; i != -1; i--) x[i] = i ; for (i = 0; i < k; i++) { j = int (n * runif()) ; y[i] = x[j] ; x[j] = x[--n]; } } /////////////////// // Eigenvalues // /////////////////// void sme_eigen_sqr_R (const SCMatD &A, SVecD &vVal, SVMatD &mVec, BOOL bOrder) { ASSERT_TEMPRANGE (4, 4) ; sme_eigen_sqr_RV (!SMatD (tempRef (4), A), vVal, mVec, bOrder) ; } void sme_eigen_sqr (const SCMatD &A, const SVecD &vVal, const SVMatD &mVec, BOOL bOrder) { ASSERT_TEMPRANGE (4, 4) ; sme_eigen_sqr_V (!SMatD (tempRef (4), A), vVal, mVec, bOrder) ; } void sme_eigen_sqr_NC (const SCMatD &A, const SVecD &vVal, const SVMatD &mVec, BOOL bOrder) { ASSERT_TEMPRANGE (4, 4) ; sme_eigen_sqr_NCV (!SMatD (tempRef (4), A), vVal, mVec, bOrder) ; } void sme_eigen_sqr_RV (const SVMatD &A, SVecD &vVal, SVMatD &mVec, BOOL bOrder) { t_size p = A.nrow () ; THROW (p == A.ncol ()) ; vVal.Redim (p) ; mVec.Redim (p, p) ; sme_eigen_sqr_NC (A, vVal, mVec, bOrder) ; } void sme_eigen_sqr_V (const SVMatD &A, const SVecD &vVal, const SVMatD &mVec, BOOL bOrder) // no redim { t_size p = A.nrow () ; THROW (p == A.ncol ()) ; THROW (vVal.size () == p) ; THROW (mVec.nrow () == p && mVec.ncol () == p) ; sme_eigen_sqr_NC (A, vVal, mVec, bOrder) ; } void sme_eigen_sqr_NCV (const SVMatD &A, const SVecD &vVal, const SVMatD &mVec, BOOL bOrder) // no check { { ASSERT (A.nrow () == A.ncol ()) ; ASSERT (vVal.size () == A.ncol ()) ; ASSERT (mVec.nrow () == A.ncol () && mVec.ncol () == A.ncol ()) ; } int p = A.ncol () ; // SVecD &vWi = SVecD::TempFree_NC (1, p) ; SVecD vWi (tempRef (0), p) ; int nInfo ; int nWork = -1 ; double dWork ; meal_geev ("V", "N", &p, NULL, &p, NULL, NULL, NULL, &p, NULL, &p, &dWork, &nWork, &nInfo) ; nWork = int(dWork) ; // SVecD &vTemp = SVecD::TempFree_NC (2, nWork) ; SVecD vTemp (tempRef (1), nWork) ; if (bOrder) { ASSERT_TEMPRANGE (0, 3) ; // SMatD &mTempVec = SMatD::TempFree_NC (3, p, p) ; SMatD mTempVec (tempRef (2), p, p) ; meal_geev ("V", "N", &p, A, &p, vVal, vWi, mTempVec, &p, NULL, &p, vTemp, &nWork, &nInfo) ; // re-order // SVecN &vOrder = SVecN::TempFree_NC (0, p) ; SVecN vOrder (tempRef (3), p) ; meal_sort_order_rev (vVal, vOrder, p) ; mVec.CopyCol_Order_NC (mTempVec, *vOrder) ; } else { ASSERT_TEMPRANGE (0, 1) ; meal_geev ("V", "N", &p, A, &p, vVal, vWi, mVec, &p, NULL, &p, vTemp, &nWork, &nInfo) ; } THROW (!nInfo) ; } void sme_eigen_sym_2x2_norm_raw (double * const pdEval, double *const pdEVec, const double *const pd, const double &dZeroTol) { THROW (pd[2] == pd[1]) ; sme_eigen_sym_2x2_norm_raw_NC (pdEval, pdEVec, pd, dZeroTol) ; } void sme_eigen_sym_2x2_norm_raw_NC (double * const pdEval, double *const pdEVec, const double *const pd, const double &dZeroTol) { const double &a = pd[0], &b = pd[2], &d = pd[3] ; // ASSERT (b == pd[1]) ; const double &dDet = pdEVec[0] = a * d - b * b, // "abusing" pdEVec as temporary memory &dTrace = pdEVec[1] = a + d ; double &dTemp = pdEVec[2] ; double &dL1 = pdEval[0], &dL2 = pdEval[1] ; dTemp = sqrt (sm_sqr (dTrace) / 4.0 - dDet) ; // calculating eigenvalues dL2 = dTrace / 2 ; dL1 = dL2 + dTemp ; dL2 -= dTemp ; if (fabs (b) / (fabs (a) + fabs (d)) > dZeroTol) // calculate some kind of condition number, which is checked against a zero tolerance { pdEVec[0] = dL1 - d ; // calculating and norming the eigenvalues pdEVec[1] = sqrt (sm_sqr (pdEVec[0]) + sm_sqr (b)) ; pdEVec[0] /= pdEVec[1] ; pdEVec[1] = b / pdEVec[1] ; pdEVec[2] = dL2 - d ; pdEVec[3] = sqrt (sm_sqr (pdEVec[2]) + sm_sqr (b)) ; pdEVec[2] /= pdEVec[3] ; pdEVec[3] = b / pdEVec[3] ; } else { pdEVec[0] = pdEVec[3] = 1 ; pdEVec[1] = pdEVec[2] = 0 ; } } /////////////// // MatMult // /////////////// void sme_matmult_a_diagb_at_R (const SCMatD &a, const SCVecD &b, SVMatD &c) { THROW (a.ncol () == b.size ()) ; c.Require (a.nrow (), a.nrow ()) ; sme_matmult_a_diagb_at_NC (a, b, c) ; } void sme_matmult_a_diagb_at (const SCMatD &a, const SCVecD &b, const SVMatD &c) { THROW (a.ncol () == b.size ()) ; THROW (c.nrow () == a.nrow () && c.ncol () == a.nrow ()) ; sme_matmult_a_diagb_at_NC (a, b, c) ; } void sme_matmult_a_diagb_at_NC (const SCMatD &a, const SCVecD &b, const SVMatD &c) { ASSERT (a.ncol () == b.size ()) ; ASSERT (c.nrow () == a.nrow () && c.ncol () == a.nrow ()) ; // SMatD &temp = SMatD::TempFree (0, a.nrow (), a.ncol ()) ; SMatD temp (tempRef (0), a.nrow (), a.ncol ()) ; // EO::McVcMd_byrow_NC (a, b, temp) ; EO::MMcVct_NC (!temp, a, b) ; sme_tmatmult_NC (temp, a, c, FALSE, TRUE) ; } void sme_matmult_at_diagb_a_R (const SCMatD &a, const SCVecD &b, SVMatD &c) { THROW (a.nrow () == b.size ()) ; c.Require (a.ncol (), a.ncol ()) ; sme_matmult_at_diagb_a_NC (a, b, c) ; } void sme_matmult_at_diagb_a (const SCMatD &a, const SCVecD &b, const SVMatD &c) { THROW (a.nrow () == b.size ()) ; THROW (c.nrow () == a.ncol () && c.ncol () == a.ncol ()) ; sme_matmult_at_diagb_a_NC (a, b, c) ; } void sme_matmult_at_diagb_a_NC (const SCMatD &a, const SCVecD &b, const SVMatD &c) { ASSERT (a.nrow () == b.size ()) ; ASSERT (c.nrow () == a.ncol () && c.ncol () == a.ncol ()) ; // SMatD &temp = SMatD::TempFree (0, a.nrow (), a.ncol ()) ; SMatD temp (tempRef (0), a.nrow (), a.ncol ()) ; //EO::McVcMd_byrow_NC (a, b, temp) ; EO::MMcVc (!temp, a, b) ; sme_tmatmult_NC (temp, a, c, TRUE, FALSE) ; } //////////////////// // matmult_a_at // //////////////////// void sme_matmult_a_at_R (const SCMatD &a, SVMatD &b, BOOL bTransA) { b.Require (a.GetDim (bTransA), a.GetDim (bTransA)) ; sme_matmult_a_at_NC (a, b, bTransA) ; } void sme_matmult_a_at (const SCMatD &a, const SVMatD &b, BOOL bTransA) { THROW (b.nrow () == b.GetDim (bTransA) && b.ncol () == a.GetDim (bTransA)) ; sme_matmult_a_at_NC (a, b, bTransA) ; } void sme_matmult_a_at_NC (const SCMatD &a, const SVMatD &b, BOOL bTransA) { ASSERT (b.nrow () == a.GetDim (bTransA) && b.ncol () == a.GetDim (bTransA)) ; sme_tmatmult_NC (a, a, !b, bTransA, !bTransA) ; } ////////////////////// // matmult_a_b_at // ////////////////////// void sme_matmult_a_b_at_R (const SCMatD &a, const SCMatD &b, SVMatD &c, BOOL bTransA, BOOL bTransB) { THROW (b.nrow () == b.ncol ()) ; THROW (a.GetDim (!bTransA) == b.nrow ()) ; c.Require (a.GetDim (bTransA), a.GetDim (bTransA)) ; sme_matmult_a_b_at_NC (a, b, c, bTransA, bTransB) ; } void sme_matmult_a_b_at (const SCMatD &a, const SCMatD &b, SVMatD &c, BOOL bTransA, BOOL bTransB) { THROW (b.nrow () == b.ncol ()) ; THROW (a.GetDim (!bTransA) == b.nrow ()) ; THROW (c.nrow () == a.GetDim (bTransA) && c.ncol () == a.GetDim (bTransA)) ; sme_matmult_a_b_at_NC (a, b, c, bTransA, bTransB) ; } void sme_matmult_a_b_at_NC (const SCMatD &a, const SCMatD &b, SVMatD &c, BOOL bTransA, BOOL bTransB) { ASSERT (b.nrow () == b.ncol ()) ; ASSERT (a.GetDim (!bTransA) == b.nrow ()) ; ASSERT (c.nrow () == a.GetDim (bTransA) && c.ncol () == a.GetDim (bTransA)) ; // SMatD &mTemp = SMatD::TempFree_NC (0, a.GetDim (bTransA), b.GetDim (!bTransB)) ; SMatD mTemp (tempRef (0), a.GetDim (bTransA), b.GetDim (!bTransB)) ; sme_tmatmult_NC (a, b, !mTemp, bTransA, bTransB) ; sme_tmatmult_NC (mTemp, a, c, FALSE, !bTransA) ; } //////////////////// // matmult_diag // //////////////////// void sme_matmult_diag_R (const SCMatD &a, const SCMatD &b, SVecD &c) { THROW (a.ncol () == b.nrow ()) ; c.Require (sm_min (a.nrow (), b.ncol ())) ; sme_matmult_diag_NC (a, b, c) ; } void sme_matmult_diag (const SCMatD &a, const SCMatD &b, const SVecD &c) { THROW (a.ncol () == b.nrow ()) ; THROW (sm_min (a.nrow (), b.ncol ()) == c.size ()) ; sme_matmult_diag_NC (a, b, c) ; } void sme_matmult_diag_NC (const SCMatD &a, const SCMatD &b, const SVecD &c) { ASSERT (a.ncol () == b.nrow ()) ; const t_size dwMin = sm_min (a.nrow (), b.ncol ()) ; ASSERT (dwMin == c.size ()) ; c.Reset (0) ; const double *pdB = b.GetDataEnd () ; t_size i, j ; double *pdC = c.GetDataEnd () ; for (j = dwMin - 1; j != NAI; j--) { pdC-- ; for (i = a.ncol () - 1; i != NAI; i--) *pdC += a (j, i) * *--pdB ; } /* const double *pdB = b ; t_size i, j ; double *pdC = c ; for (j = 0; j < dwMin; j++) { for (i = 0; i < a.ncol (); i++) { *pdC += a (j, i) * *pdB ; pdB++ ; } pdC++ ; } */ } double sme_sum_matmult_diag (const SCMatD &a, const SCMatD &b) { double c = 0 ; sme_sum_matmult_diag (a, b, c) ; return c ; } double sme_sum_matmult_diag_NC (const SCMatD &a, const SCMatD &b) { double c = 0 ; sme_sum_matmult_diag_NC (a, b, c) ; return c ; } void sme_sum_matmult_diag (const SCMatD &a, const SCMatD &b, double &c) { THROW (a.ncol () == b.nrow ()) ; sme_sum_matmult_diag_NC (a, b, c) ; } void sme_sum_matmult_diag_NC (const SCMatD &a, const SCMatD &b, double &c) { ASSERT (a.ncol () == b.nrow ()) ; const t_size dwMin = sm_min (a.nrow (), b.ncol ()) ; // if (c < 0) { c = 0 ; const double *pdB = b ; t_size i, j ; double dTemp ; for (j = 0; j < dwMin; j++) { dTemp = 0 ; for (i = 0; i < a.ncol (); i++) dTemp += a (j, i) * *pdB++ ; c += dTemp ; } } /* else { c = 0 ; const double *pdB = b.GetDataEnd () ; t_size i, j ; double dTemp ; for (j = dwMin - 1; j != NAI; j--) { dTemp = 0 ; for (i = a.ncol () - 1; i != NAI; i--) dTemp += a (j, i) * *--pdB ; c += dTemp ; } } */ } double sme_sum_diag_At_matmult_B (const SCMatD &a, const SCMatD &b) { double dSum ; sme_sum_diag_Bt_matmult_C (dSum, a, b) ; return dSum ; } double sme_sum_diag_At_matmult_B_NC (const SCMatD &a, const SCMatD &b) { double dSum ; sme_sum_diag_Bt_matmult_C_NC (dSum, a, b) ; return dSum ; } void sme_sum_diag_Bt_matmult_C (double &a, const SCMatD &b, const SCMatD &c) { // calculates sum (diag (t (A) %*% B)) THROW (b.nrow () == c.nrow ()) ; sme_sum_diag_Bt_matmult_C_NC (a, b, c) ; } void sme_sum_diag_Bt_matmult_C_NC (double &a, const SCMatD &b, const SCMatD &c) { // calculates sum (diag (t (A) %*% B)) ASSERT (b.nrow () == c.nrow ()) ; const t_size dwDim = sm_min (b.ncol (), b.ncol ()) ; double const * pdB = b, * const pdEndB = pdB + dwDim * b.nrow (); a = 0 ; EO::SVcVc_raw (a, pdB, pdEndB, c.GetData ()) ; } //////////////////////// // Calc Covariances // //////////////////////// void cov_centered_R (SVMatD &a, const SCMatD &b, const double &dFact) { a.Require (b.ncol (), b.ncol ()) ; cov_centered_NC (a, b) ; } void cov_centered (const SVMatD &a, const SCMatD &b, const double &dFact) { THROW (a.nrow () == a.ncol ()) ; THROW (a.nrow () == b.ncol ()) ; cov_centered_NC (a, b) ; } void cov_centered_NC (const SVMatD &a, const SCMatD &b, const double &dFact) { // 2do: think about only calculating half of it! ASSERT (a.nrow () == a.ncol ()) ; ASSERT (a.nrow () == b.ncol ()) ; sme_tmatmult_NC (b, b, a, TRUE, FALSE) ; EO::VSc (*a, dFact / (b.nrow () - 1.0)) ; } //////////// // misc // //////////// double median (const SCData &a) { ASSERT_TEMPRANGE (0, 0) ; SVecD temp (tempRef (0), a.size ()) ; // 2do: should be copied by constructor! temp.Copy_NC (a) ; return median_V (*temp) ; } double median_V (const SVData &a) // 2do: make this a template function! { int n = a.size () ; double *pA = a ; if (n < 3) { if (!n) return meal_NaN () ; if (n == 1) return pA[0] ; return (pA[0] + pA[1]) / 2 ; } int nHalf = (n + 1) >> 1 ; // odd length if (n & 1) return psort_V(a, nHalf-1); // even length const double dTemp = psort_V(a, nHalf - 1) ; return (dTemp + min (pA + nHalf, pA + n)) / 2 ; } double mad0 (const SVData &a) { const double dCenter = median_V (a) ; EO::VSc (a, dCenter) ; return median_V (a) ; } double medianabs_V (const SVData &a) { EO::V (a) ; return median_V (a) ; } double mad_V (const SVData &a) { return mad0 (a) * 1.482602218505602 ; } double mad (const SCData &a) { ASSERT_TEMPRANGE (0, 0) ; SVecD temp (tempRef (0), a.size ()) ; // 2do: should be copied by the constructor! temp.Copy_NC (a) ; return mad_V (*temp) ; } void sort_R (const SCData &a, SVecD &b) { b.Require (a.size ()) ; sort_NC (a, b) ; } void sort (const SCData &a, const SVecD &b) { THROW (a.size () == b.size ()) ; sort_NC (a, b) ; } void sort_NC (const SCData &a, const SVecD &b) { b.Copy_NC (a) ; meal_sort (b, b.size ()) ; } void sort (const SVData &a) { meal_sort (a, a.size ()) ; } void sort_order (const SVData &a, const SVData &b) { THROW (a.size () == b.size ()) ; sort_order_NC (a, b) ; } void sort_order_NC (const SVData &a, const SVData &b) { ASSERT (a.size () == b.size ()) ; meal_sort_order (a, b, b.size ()) ; } void norm2 (double &dNorm, const SCData &a) { dNorm = 0 ; EO::SVc (dNorm, a) ; dNorm = sqrt (dNorm) ; } double norm2 (const SCData &a) { double dNorm ; norm2 (dNorm, a) ; return dNorm ; } ////////////////////////// // Printing Functions // ////////////////////////// void Print (const double &v) { meal_printf ("%f", v) ; } void Print (const float &v) { meal_printf ("%f", v) ; } void Print (const int &v) { meal_printf ("%d", v) ; } void Print (const t_size &v) { meal_printf ("%d", v) ; } /* // 2do: move to smat.test.cpp - file EXPORT void ex_mad (int *pnParIn, double *pdParOut, double *pdData) { *pdParOut = mad_V (*SVecD (pdData, *pnParIn)) ; } */ /* // 2do: move to smat.test.cpp - file EXPORT void sme_tmatmult (int *pnParIn, double *pdA, double *pdB, double *pdC) // 2do: put in different file! { const t_size na = pnParIn [0], pa = pnParIn [1], nb = pnParIn [2], pb = pnParIn [3], nc = pnParIn [4], pc = pnParIn [5] ; BOOL bTransA = pnParIn[6], bTransB = pnParIn[7] ; SCMatD a (pdA, na, pa) ; SCMatD b (pdB, nb, pb) ; SMatD c (pdC, nc, pc) ; sme_tmatmult_NC (a, b, !c, bTransA, bTransB) ; } */ /* // 2do: move to smat.test.cpp - file EXPORT void ex_median (int *pnParIn, double *pdParOut, double *pdData) { *pdParOut = median_V (*SVecD (pdData, *pnParIn)) ; } */ /* // 2do: move to smat.test.cpp - file EXPORT void sme_matmult_a_diagb_at (int *pnParIn, double *pdA, double *pdB, double *pdC) { int n = pnParIn [0], p = pnParIn [1] ; SCMatD a (pdA, n, p) ; SCVecD b (pdB, p) ; SMatD c (pdC, n, p) ; sme_matmult_a_diagb_at_NC (a, b, !c) ; } */ /* // 2do: move to smat.test.cpp - file EXPORT void sme_eigen_sqr (int *pnParIn, double *pdA, double *pdVal, double *pdVec) // 2do: put into different File { int p = pnParIn[0] ; BOOL bOrder = pnParIn[1] ; sme_eigen_sqr (!SMatD (pdA, p, p), SVecD (pdVal, p), !SMatD (pdVec, p, p), bOrder) ; } */ pcaPP/src/smat.stat.h0000644000176200001440000001147413300577052014144 0ustar liggesusers/* SMat - Simple Matrix Classes v0.1beta Copyright (C) 2011 by Heinrich Fritz (heinrich_fritz@hotmail.com) This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . */ #ifndef SMAT_STAT_H #define SMAT_STAT_H #include "smat.base.h" void cov_centered_R ( SVMatD &a, const SCMatD &b, const double &dFact = 1) ; // 2do: make this a template function void cov_centered (const SVMatD &a, const SCMatD &b, const double &dFact = 1) ; void cov_centered_NC (const SVMatD &a, const SCMatD &b, const double &dFact = 1) ; double median (const SCData &a) ; double median_V (const SVData &a) ; double mad0 (const SVData &a) ; double mad (const SCData &a) ; double mad_V (const SVData &a) ; double medianabs_V (const SVData &a) ; void norm2 (double &dNorm, const SCData &a) ; double norm2 (const SCData &a) ; template inline void mean (TA & a, const SCData &b) { TA s = 0 ; EO::SVc (s, b) ; a = s / b.size () ; } template inline TA mean (const SCData &a) { TA ret ; mean (ret, a) ; return ret ; } template inline void sd (TA & a, const SCData &b) { var (a, b) ; a = (TA) sqrt ((double) a) ; } template inline void sd_st (TA & a, const SCData &b) { var_st (a, b) ; a = (TA) sqrt ((double) a) ; } template inline void var (TA & a, const SCData &b) { var_raw (a, b) ; a /= (b.size () - 1) ; } template inline void var_raw (TA & a, const SCData &b) { TA m, d = 0; mean (m, b) ; EO::SScVc (d, m, b) ; a = d ; } template inline void var_st (TA & a, const SCData &b) { var_st_raw (a, b) ; a /= (b.size () - 1) ; } template inline void var_st_raw (TA & a, const SCData &b) { TA ss = 0, s = 0 ; EO::SSVc (s, ss, b) ; a = ss - b.size () * sm_sqr (s / b.size ()) ; } template TA sumprod (const SCData &a, const SCData &b) { TA ret = 0 ; // EO::vcdvcds (a, b, ret) ; EO::SVcVc (ret, a, b) ; return ret ; } template void sumprod (const SCData &a, const SCData &b, TC &c) { //EO::vcdvcds (a, b, c) ; EO::SVcVc (c, a, b) ; } template TA sum (const SCData &a) { TA ret = 0 ; sum (a, ret) ; return ret ; } template void sum (const SCData &a, TB &sum) { sum = 0 ; EO::SVc (sum, a) ; } template void sum (TA *pA, t_size n, TB &sum) { sum = 0 ; EO::SVc_raw (sum, pA, pA + n) ; } template TA sum (TA *pA, t_size n) { TA ret = 0 ; sum (pA, n, ret) ; return ret ; } template void cumsum (const SVData &a) { EO::V_pairs (a) ; } template void cumsum_r (const SVData &a) { EO::V_pairs_r (a) ; } template void colSums_R (SVec &a, const SCMat &b) { a.Requires (b.ncol ()) ; colSums_NC (a, b) ; } template void colSums (const SVData &a, const SCMat &b) { THROW (a.size () == b.ncol ()) ; colSums_NC (a, b) ; } template void colSums_NC (const SVData &a, const SCMat &b) { a.Reset (0) ; EO::VetMcd_NC (a, b) ; } //////////////// // Products // //////////////// template TA prod (const SCData &a) { TA ret = 1 ; prod (a, ret) ; return ret ; } template void prod (const SCData &a, TA &prod) { prod = 1 ; EO::SVc (prod, a) ; } template void colProds_R (SVec &a, const SCMat &b) { a.Requires (b.ncol ()) ; colProds_NC (a, b) ; } template void colProds (const SVData &a, const SCMat &b) { THROW (a.size () == b.ncol ()) ; colProds_NC (a, b) ; } template void colProds_NC (const SVData &a, const SCMat &b) { a.Reset (1) ; EO::VetMcd_NC (a, b) ; } #endif // #ifndef SMAT_STAT_H pcaPP/src/smat.random.h0000644000176200001440000000251413300577052014444 0ustar liggesusers/* SMat - Simple Matrix Classes v0.1beta Copyright (C) 2011 by Heinrich Fritz (heinrich_fritz@hotmail.com) This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . */ #ifndef SMAT_RANDOM_H #define SMAT_RANDOM_H double runif () ; double rnorm () ; double rexp () ; void runif_raw (double *p, double *pEnd) ; void runif (const SVData &a) ; void runif_r_raw (double *p, double *pEnd) ; void runif_r (const SVData &a) ; void rnorm (const SVData &a) ; void rnorm_raw (double *p, double *pEnd) ; void runif_raw (double *d, int l, double dL, double dU) ; void runif_raw (double *d, double * const pEnd, double dL, double dU) ; void SampleNoReplace(int k, int n, int *y, int *x) ; #endif // #ifndef SMAT_RANDOM_H pcaPP/src/l1median.cpp0000644000176200001440000002507313300577052014253 0ustar liggesusers#ifdef R_PACKAGE_FILE // this is an R specific source file, using built-in optimizers.. #include "R_package.h" #include "R.h" #include "R_ext/Applic.h" #ifdef ES_DEV_ENV #include "../../../RDev/perftimer.h" #else #include "perftimer.h" #endif void Hess (int p, int n, double *pdX, double *pdMu, double *pdHess, double *pdTempP1, double *pdTempP2) ; void ResetVect (double *p, int n, double v) // 2do: replace this function by SVec - operation { double * const pEnd = p + n ; for (; p < pEnd; ++p ) *p = v ; } void VectorMultVector (double *pA, double const * pB, int n) // 2do: replace this function by SVec - operation { double * const pEndA = pA + n ; while (pA < pEndA) { *pA *= *pB ; ++pA ; ++pB ; } } inline double AddSqr (double &d, double pAdd) { return d += pAdd * pAdd ; } class L1MinStruct //2do: move to header file! { public: L1MinStruct (int n, int p, double *pdX, double *pdParScale = 0) ; ~L1MinStruct () ; int m_n, m_p, m_pn ; double *m_pdX, *m_pdX_, *m_pdDi, *m_pdM, *m_pdParScale ; //, *m_pdM ; double calcall (double *pdM, double *pdMRet) ; double calObj (double *pdM) ; //void sqrtrowsumssq () ; int m_nCFn, m_nCGr ; } ; class L1MinStruct_Hess : public L1MinStruct //2do: move to header file! { public: L1MinStruct_Hess (int n, int p, double *pdX, double *pdParScale = 0) : L1MinStruct (n, p, pdX, pdParScale), m_pdTemp1 (new double [p]), m_pdTemp2 (new double [p]) { } void calcHess (double *pdM, double *pdHess) ; ~L1MinStruct_Hess () { delete [] m_pdTemp1 ; delete [] m_pdTemp2 ; } double *m_pdTemp1, *m_pdTemp2 ; } ; L1MinStruct::L1MinStruct (int n, int p, double *pdX, double *pdParScale) : m_n (n), m_p (p), m_pn (p * n), m_pdX (pdX), m_pdParScale (pdParScale) { m_pdX_ = new double [n * p] ; m_pdDi = new double [n] ; m_pdM = new double [p] ; // set m_pdM to some strange value!! m_nCFn = m_nCGr = 0 ; } L1MinStruct::~L1MinStruct () { delete [] m_pdX_ ; delete [] m_pdDi ; delete [] m_pdM ; } /* void Rtprintf (double *pd, int n) { for (; n; n--) Rprintf ("%0.10f\t", *pd++) ; Rprintf ("\r\n") ; } */ void L1MinStruct_Hess ::calcHess (double *pdM, double *pdHess) { Hess (m_p, m_n, m_pdX, pdM, pdHess, m_pdTemp1, m_pdTemp2) ; } double L1MinStruct::calcall (double *pdM, double *pdMRet) { m_nCGr++ ; //Rprintf ("grad:\t") ; //Rtprintf (pdM, m_p) ; int r, c ; double *pdX = m_pdX + m_pn, *pdX_ = m_pdX_ + m_pn ; for (r = m_n - 1; r != -1; r--) m_pdDi[r] = 0 ; // X. <- centr(X,m) // d.i <- rowSums(X.^2) for (c = m_p - 1; c != -1; c--) { double dXm = m_pdParScale ? pdM[c] * m_pdParScale[c] : pdM[c] ; //for (r = 0; r < m_n; r++) for (r = m_n - 1; r != -1; r--) { *--pdX_ = *--pdX - dXm ; //*pdX_++ = *pdX++ - dXm ; m_pdDi[r] += *pdX_ * *pdX_ ; } } pdX_ = m_pdX_ + m_pn ; for (r = m_n - 1; r != -1; --r) { m_pdDi[r] = ::sqrt ((double) m_pdDi[r]) ; } // MED <- colSums(X. / sqrt (d.i)) for (c = m_p - 1; c != -1; c--) { double &dXm = pdMRet[c] = 0 ; for (r = m_n - 1; r != -1; r--) dXm -= *--pdX_ / m_pdDi[r] ; } return 0 ; } double L1MinStruct::calObj (double *pdM) { m_nCFn++ ; //Rprintf ("obj: \t") ; //Rtprintf (pdM, m_p) ; memcpy (m_pdM, pdM, m_p * sizeof (double)) ; if (m_pdParScale) VectorMultVector (m_pdM, m_pdParScale, m_p) ; //double *pdCur = m_pdX + m_n * m_p ; double dSum = 0, dRowSum ; int r, c ; for (r = m_n - 1; r != -1; r--) { dRowSum = 0 ; for (c = m_p - 1; c != -1; c--) AddSqr (dRowSum, m_pdX [r + c * m_n] - m_pdM [c]) ; dSum += ::sqrt (dRowSum) ; } //Rprintf ("Obj. val: %f\r\n", dSum) ; return dSum ; } void l1obj_hess (int n, int p, double *pdMu, double *pdHess, void *pDat) { ((L1MinStruct_Hess *)pDat)->calcHess (pdMu, pdHess) ; } void l1objg(int n, double *pdCurCenter, double *pdRetCenter, void *pDat) { ((L1MinStruct *) pDat)->calcall (pdCurCenter, pdRetCenter) ; } void l1obj_(int n, double *pdCurCenter, double *ddObj, void *pDat) { *ddObj = ((L1MinStruct *) pDat)->calObj (pdCurCenter) ; } double l1obj (int n, double *pdCurCenter, void *pDat) { return ((L1MinStruct *) pDat)->calObj (pdCurCenter) ; } void C_l1median_NM(int *pnParam, double *pdParam, double *pdData/*, double *pdParScale*/, double *pdMRet) { int &n = pnParam [0], &p = pnParam [1], &nMaxStep = pnParam[2], &nFail = pnParam [3], &nTrace = pnParam [4], &nFnCount = pnParam [5], &nTime = pnParam[6] ; double &dAbsTol = pdParam[0], &dRelTol = pdParam[1], &dRet = pdParam[2], &dAlpha = pdParam[3], &dBeta = pdParam[4], &dGamma = pdParam[5] ; double *pdStart = new double [p] ; memcpy (pdStart, pdMRet, sizeof (double) * p) ; // VectorDivVector (pdStart, &p, pdParScale) ; L1MinStruct minstruc (n, p, pdData/*, pdParScale*/) ; CPerfTimer tim ; nmmin (p, pdStart, pdMRet, &dRet, l1obj, &nFail, dAbsTol, dRelTol, (void *) &minstruc, dAlpha, dBeta, dGamma, nTrace, &nFnCount, nMaxStep) ; nTime = tim.GetTimeMS () ; // VectorMultVector (pdMRet, &p, pdParScale) ; delete [] pdStart ; } void C_l1median_CG(int *pnParam, int *pnParam_Out, double *pdParam, double *pdParam_Out, double *pdData/*, double *pdParScale*/, double *pdMRet) { int &n = pnParam [0], &p = pnParam [1], &nMaxStep = pnParam[2], &nTrace = pnParam [3], nType = pnParam [4] ; int &nFail = pnParam_Out [0], &nFnCount = pnParam_Out [1], &nGrCount = pnParam_Out [2], &nTime = pnParam_Out[3] ; double &dAbsTol = pdParam[0], &dRelTol = pdParam[1] ; double &dRet = pdParam_Out [0] ; double *pdStart = new double [p] ; memcpy (pdStart, pdMRet, sizeof (double) * p) ; // VectorDivVector (pdStart, &p, pdParScale) ; L1MinStruct minstruc (n, p, pdData/*, pdParScale*/) ; CPerfTimer tim ; cgmin (p, pdStart, pdMRet, &dRet, l1obj, l1objg, &nFail, dAbsTol, dRelTol, (void *) &minstruc, nType, nTrace, &nFnCount, &nGrCount, nMaxStep) ; nTime = tim.GetTimeMS () ; // VectorMultVector (pdMRet, &p, pdParScale) ; delete [] pdStart ; } void C_l1median_BFGS (int *pnParam_In, int *pnParam_Out, double *pdParam_In, double *pdParam_Out, double *pdData/*, double *pdParScale*/, double *pdMRet) { int &n = pnParam_In [0], &p = pnParam_In [1], &nMaxStep = pnParam_In[2], &nTrace = pnParam_In [3], nReport = pnParam_In [4] ; int &nFail = pnParam_Out [0], &nFnCount = pnParam_Out [1], &nGrCount = pnParam_Out [2], &nTime = pnParam_Out[3] ; double &dAbsTol = pdParam_In[0], &dRelTol = pdParam_In[1] ; double &dRet = pdParam_Out [0] ; dAbsTol = dRelTol ; // VectorDivVector (pdMRet, &p, pdParScale) ; L1MinStruct minstruc (n, p, pdData/*, pdParScale*/) ; int *pnMask = new int [p] ; for (int i = p - 1; i != -1; i--) pnMask[i] = 1 ; CPerfTimer tim ; vmmin (p, pdMRet, &dRet, l1obj, l1objg, nMaxStep, nTrace, pnMask, dAbsTol, dRelTol, nReport, (void *) &minstruc, &nFnCount, &nGrCount, &nFail) ; nTime = tim.GetTimeMS () ; // VectorMultVector (pdMRet, &p, pdParScale) ; delete [] pnMask ; } void l1median_SA (int *pnParam_In, int *pnParam_Out, double *pdParam_In, double *pdParam_Out, double *pdData/*, double *pdParScale*/, double *pdMRet) { int &n = pnParam_In [0], &p = pnParam_In [1], &nMaxStep = pnParam_In[2], &nTrace = pnParam_In [3], nTMax = pnParam_In [4] ; int &nFnCount = pnParam_Out [0], &nTime = pnParam_Out[1] ; double &dTempInit = pdParam_In [0] ; double &dRet = pdParam_Out [0] ; // VectorDivVector (pdMRet, &p, pdParScale) ; L1MinStruct minstruc (n, p, pdData/*, pdParScale*/) ; CPerfTimer tim ; samin (p, pdMRet, &dRet, l1obj, nMaxStep, nTMax, dTempInit, nTrace, (void *) &minstruc) ; nTime = tim.GetTimeMS () ; nFnCount = minstruc.m_nCFn ; // VectorMultVector (pdMRet, &p, pdParScale) ; } void C_l1median_NLM (int *pnParam, double *pdParam, double *pdData, double *pdMRet/*, double *pdTypSize*/) { int &n = pnParam [0], &p = pnParam [1], &nMaxStep = pnParam[2], &nFail = pnParam [3], &nTime = pnParam[5], &nMsg = pnParam[6]/*, &nTrace = pnParam[7]*/ ; double &dTol = pdParam[0], &dRet = pdParam[1] ; double *pdStart = new double [p] ; memcpy (pdStart, pdMRet, sizeof (double) * p) ; L1MinStruct minstruc (n, p, pdData) ; // nMsg = 8 ; double *pdRetGrad = new double [p], *pdWrk = new double [p * 8], *pdA = new double [p * p], *pdTypSize = new double [p] ; ResetVect (pdTypSize, p, 1) ; CPerfTimer tim ; optif9 ( p, p, pdStart, l1obj_, l1objg, NULL, (void *) &minstruc, pdTypSize, 1, /* fscale */ 1, /* method */ 1, /* iexp */ &nMsg, -1, /* ndigit */ // // C: -1 / R: 12 nMaxStep, 1, /* iagflag */ 0, /* iahflag */ 1e-6, /* dlt */ // 1, //1e-6, dTol, /* gradtl */ //pow(DBL_EPSILON, 0.25), //0.1, 1000, /* stepmx */ // C:1e-6 / R: 1000 dTol, /* steptl */ //sqrt(DBL_EPSILON), //1e-6, pdMRet, &dRet, pdRetGrad, &nFail, pdA, pdWrk, &nMaxStep) ; nTime = tim.GetTimeMS () ; delete [] pdStart ; delete [] pdRetGrad ; delete [] pdWrk ; delete [] pdA ; delete [] pdTypSize ; } void C_l1median_NLM_Hess (int *pnParam, double *pdParam, double *pdData, double *pdMRet/*, double *pdTypSize*/) { int &n = pnParam [0], &p = pnParam [1], &nMaxStep = pnParam[2], &nFail = pnParam [3], nMethod = pnParam[4], &nTime = pnParam[5], &nMsg = pnParam[6]/*, &nTrace = pnParam[7]*/, &nGFlag = pnParam[8], &nHFlag = pnParam[9], &nExp = pnParam[10], &nDigits = pnParam[11] ; double &dTol = pdParam[0], &dRet = pdParam[1] ; double *pdStart = new double [p] ; memcpy (pdStart, pdMRet, sizeof (double) * p) ; L1MinStruct_Hess minstruc (n, p, pdData) ; // nMsg = 8 ; double *pdRetGrad = new double [p], *pdWrk = new double [p * 8], *pdA = new double [p * p], *pdTypSize = new double [p] ; ResetVect (pdTypSize, p, 1) ; CPerfTimer tim ; optif9 ( p, p, pdStart, l1obj_, l1objg, l1obj_hess, (void *) &minstruc, pdTypSize, 1, /* fscale */ nMethod, /* method */ nExp, /* iexp */ &nMsg, nDigits, /* ndigit */ // C: -1 / R: 12 nMaxStep, nGFlag, /* iagflag */ nHFlag, /* iahflag */ -1, /* dlt */ // 1, //1e-6, dTol, /* gradtl */ // pow(DBL_EPSILON, 0.25), //0.1, 1000, /* stepmx */ // C:1e-6 / R: 1000 dTol, /* steptl */ // sqrt(DBL_EPSILON), //1e-6, pdMRet, &dRet, pdRetGrad, &nFail, pdA, pdWrk, &nMaxStep) ; nTime = tim.GetTimeMS () ; delete [] pdStart ; delete [] pdRetGrad ; delete [] pdWrk ; delete [] pdA ; delete [] pdTypSize ; } #endif // #ifdef R_PACKAGE_FILE pcaPP/src/ML_meal.h0000644000176200001440000000273613300577052013535 0ustar liggesusers/* SMat - Simple Matrix Classes v0.1beta Copyright (C) 2011 by Heinrich Fritz (heinrich_fritz@hotmail.com) This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . */ // ML_meal.h // MATLAB Mathematical Environment Abstraction Layer #ifndef ML_MEAL_H #define ML_MEAL_H #ifdef MATLAB_MEX_FILE #include "matrix.h" #include "mex.h" #include "lapack.h" #include "blas.h" //#include "mwutil.h" #ifdef SMAT_H void Int2Double (double *pd, const int *pn, int n) { EO::VVc_raw (pd, pd + n, pn) ; } void Double2Int (int *pn, const double *pd, int n) { EO::VVc_raw (pn, pn + n, pd) ; } #endif // #ifdef SMAT_H class CRmealSettings { public: CRmealSettings () ; CRmealSettings (const char *szEmail) ; const char *GetEmail () { return m_szEmail ; } protected: const char *m_szEmail ; } ; #endif // #ifdef MATLAB_MEX_FILE #endif // #ifndef ML_MEAL_H pcaPP/src/outSDo.h0000644000176200001440000000123513300577052013435 0ustar liggesusers#include "pcaPP.h" class CSDoOut { public: CSDoOut (int *pnParIn, double *pdX, double *pdMaxMaha, int *pnNChanged) ; void Calc () ; protected: void CalcCenter () ; void IterObs () ; void IterDiffObs (int n) ; void IterRand (int n) ; void IterRandDiffObs (int n) ; int DoDir (const SCVecD &vLoad) ; const t_size m_dwN, m_dwP, m_dwIterMethod, m_dwIterParam, m_dwCenterMethod, m_dwScatterMethod, m_dwReset ; SMatD m_mX ; SVecD m_vMaxMaha ; const t_size m_dwNDir ; SVecD m_vXProj, m_vCurDir ; // SVecN m_vChanged ; int * const m_pnNChanged ; double * const m_pdDiff ; double *m_pdXProj, * const m_pdEndXProj, *m_pdMaxMaha ; } ; pcaPP/src/cov.kendall.h0000644000176200001440000000027713300577052014425 0ustar liggesusers//#include #include double kendallNlogN (double* arr1, double* arr2, size_t len, int cor) ; double kendallSmallN (double* arr1, double* arr2, size_t len, int cor) ; pcaPP/vignettes/0000755000176200001440000000000013300576522013270 5ustar liggesuserspcaPP/vignettes/matlab.example.txt0000644000176200001440000000405312777012547016736 0ustar liggesusers>> rand('seed', 0) ; >> X = rand (100, 5) ; >> mHC = l1median_HoCr (X) mHC = 0.5261 0.5123 0.5171 0.4963 0.4635 >> mVZ = l1median_VaZh (X) mVZ = 0.5261 0.5123 0.5171 0.4963 0.4635 >> pc = PCAgrid (X) pc = sdev: [0.4251 0.3939] loadings: [5x2 double] k: 2 obj: [0.1807 0.1552] n_obs: 100 scale: [1 1 1 1 1] center: [0.5261 0.5123 0.5171 0.4963 0.4635] pc_order: [1 2] scores: [100x2 double] >> sp = PCAproj (X, 2) sp = loadings: [5x2 double] sdev: [0.4027 0.3835] center: [0.5261 0.5123 0.5171 0.4963 0.4635] scale: [1 1 1 1 1] n_obs: 100 >> rand('seed', 0) ; >> X = rand (100, 5) ; >> mHC = l1median_HoCr (X) mHC = 0.5261 0.5123 0.5171 0.4963 0.4635 >> mVZ = l1median_VaZh (X) mVZ = 0.5261 0.5123 0.5171 0.4963 0.4635 >> pc = PCAgrid (X) pc = sdev: [0.4251 0.3939] loadings: [5x2 double] k: 2 obj: [0.1807 0.1552] n_obs: 100 scale: [1 1 1 1 1] center: [0.5261 0.5123 0.5171 0.4963 0.4635] pc_order: [1 2] scores: [100x2 double] >> sp = PCAproj (X, 2) sp = loadings: [5x2 double] sdev: [0.4027 0.3835] center: [0.5261 0.5123 0.5171 0.4963 0.4635] scale: [1 1 1 1 1] n_obs: 100 scores: [100x2 double] >> sp = PCAproj (X, 5, 'mad', 'lincomb') sp = loadings: [5x5 double] sdev: [2.0793 0.4027 0.3835 0.3474 0.3110] center: [0.5261 0.5123 0.5171 0.4963 0.4635] scale: [1 1 1 1 1] n_obs: 100 scores: [100x5 double] >> sc = qn (X) sc = 0.2958 scores: [100x2 double] >> sp = PCAproj (X, 5, 'mad', 'lincomb') sp = loadings: [5x5 double] sdev: [2.0793 0.4027 0.3835 0.3474 0.3110] center: [0.5261 0.5123 0.5171 0.4963 0.4635] scale: [1 1 1 1 1] n_obs: 100 scores: [100x5 double] >> sc = qn (X) sc = 0.2958 pcaPP/vignettes/matlab.rnw0000644000176200001440000001240412777012547015272 0ustar liggesusers\documentclass[12pt]{article} \usepackage{Sweave} %\VignetteIndexEntry{Compiling pcaPP for Matlab} %\VignetteDepends{pcaPP} %\VignetteKeywords{Matlab} %\VignettePackage{pcaPP} <>= source ("load.package.name.R") library (package.name, character.only = TRUE) vt <- eval (parse (text = paste (package.name, ":::", ".getVtext", sep = ""))) cat (sep = "", # "%\\VignetteIndexEntry{Compiling ", vt (1), " for Matlab}\n", ## these lines cannot be created automatically - unfortunately.. # "%\\VignetteDepends{", vt (1), "}\n", # "%\\VignetteKeywords{Matlab}\n", # "%\\VignettePackage{", vt (1), "}\n", # "\n", "\n", "\\newcommand{\\dapck}{", vt (1), "}\n", "\\newcommand{\\daver}{", vt (2), "}\n", "\n", "\n" ) @ \newcommand{\sourcefile}{{\dapck}\_{\daver}.tar.gz} \newcommand{\proglang}[1]{\textbf{#1}} \newcommand{\code}[1]{\texttt{#1}} \newcommand{\link}[1]{\texttt{#1}} \newcommand{\path}[1]{{\it #1}} \title{Compiling {\dapck} for Matlab} \author{Heinrich Fritz} \begin{document} \maketitle \section{Introduction} The main functions of the \proglang{R}-package {\dapck} are implemented in an environ-mentindependent manner, which allows the user to use this package beyond the scope of \proglang{R}. The package has also been prepared to be compiled and used with \proglang{Matlab}, which is summarized and demonstrated in this document. The following items are required for using {\dapck} together with \proglang{Matlab}: \begin{itemize} \item The {\dapck} package sources \code{\sourcefile} \\(available at \link{http://CRAN.R-project.org/package=\dapck}). \item \proglang{Matlab} (version $\geq$ 2010a). \item A compatible \proglang{C++} compiler (for currently supported compilers see \link{http://www.mathworks.com/support/compilers/current\_release/}). \end{itemize} Section \ref{sec:instcomp} helps to set up a suitable compiler together with \proglang{Matlab}, whereas Section \ref{sec:comp} gives instructions on how to actually compile the package. Section \ref{sec:ex} demonstrates some examples on the usage of the package and Section \ref{sec:concl} concludes. \section{Setting up the Compiler} \label{sec:instcomp} Assuming that \proglang{Matlab} has already been set up properly on the target system, the first step is to set up a suitable \proglang{C++} compiler, such that \proglang{Matlab} recognizes it. A list of compatible compilers can be obtained by typing \begin{Scode} >> mex -setup n \end{Scode} into the \proglang{Matlab} console. Once a compiler from this list has been installed on the system, select it (by using the previous command) and make sure that \proglang{Matlab} locates it correctly. Note that after installing a compiler \proglang{Matlab} might have to be restarted for correctly recognizing it. Finally assure that the compiler has been set up properly by typing \begin{Scode} >> mex.getCompilerConfigurations ('C++') \end{Scode} \proglang{Matlab} should now correctly display the chosen compiler's details. A more extensive introduction to the mex-interface and its configuration can be found at \code{http://www.mathworks.de/support/tech-notes/1600/1605.html}. \section{Compiling {\dapck}} \label{sec:comp} Extract the downloaded package sources (\code{\sourcefile}) to a working directory, (e.g. \path{C:/work}), and set \proglang{Matlab}'s current directory to the \path{{\dapck}/matlab} subfolder: \begin{Scode} <>= cat (sep = "", ">> cd ('C:/work/", vt(1), "/matlab')") @ \end{Scode} Now the package is ready to be compiled by calling {\dapck}'s \code{setup} routine: \begin{Scode} >> setup Changing the current directory to '../src' ... ok <>= cat (sep = "", "Compiling the ", vt(1), " package ... ok\n", "Copying the '", vt(1), ".mex*' file(s) to '../matlab' ... ok\n", "Changing the current directory back to '../matlab' ... ok\n\n", " Successfully compiled the ", vt(1), " package for Matlab!") @ \end{Scode} Note that this \proglang{Matlab}-setup routine has been tested with Microsoft's Visual C++ 6.0 compiler. Other compilers supported by \proglang{Matlab} are very likely to work as well, but have not been tested in this context yet. \section{Using {\dapck}} \label{sec:ex} Once the preceding code has been executed successfully, the {\dapck} package can be used almost the same way as in \proglang{R}. The following functions are available in \proglang{Matlab}: <>= cat (paste ("\\code{", vt(3), "}", sep = "", collapse = ", ")) @ and work as described in the \proglang{R} man pages: \begin{Scode} <>= cat (vt (4)) @ \end{Scode} \section{Conclusions} \label{sec:concl} The configuration of a \proglang{C++} compiler in the context of \proglang{Matlab} has been discussed briefly, as well as how to compile the \proglang{R} package {\dapck} in this environment. Further some examples on how to use the package in \proglang{Matlab} were given. Due to the package's architecture the same \proglang{C++} sources can be used in both environments, which increases the availability of this software beyond the scope of the \proglang{R} community. \end{document} pcaPP/vignettes/load.package.name.R0000644000176200001440000000003112777012547016646 0ustar liggesuserspackage.name <- "pcaPP" pcaPP/R/0000755000176200001440000000000013300576522011461 5ustar liggesuserspcaPP/R/ScaleAdv.R0000644000176200001440000000244112777012547013300 0ustar liggesusersScaleAdv <- function (x, center = mean, scale = sd) { if (!is.matrix (x)) { if (is.data.frame (x)) x = as.matrix(x) else x = matrix (x, ncol = 1) } n = nrow (x) p = ncol (x) m = array (0, p) if (missing (scale)) ## 2be removed as soon as the matrix-warning message in "sd" disappears. scale <- .colSds if (is.character (center)) center = eval (parse (text = center)) if (is.function (center)) { m = center (x) if (is.list (m)) m <- m$par else if (length (m) != p) m = apply (x, 2, center) x = x - matrix(1, nrow = n) %*% m } else if (length (center) == p & is.numeric (center)) { m = center x = x - matrix(1, nrow = n) %*% m } else if (!is.null (center)) warning ("Unknown center specification! Centering will be omitted.\n") s = array (1, p) if (is.character (scale)) scale = eval (parse (text = scale)) if (is.function (scale)) { s = scale (x) if (length (s) != p) s = apply (x, 2, scale) x = x / matrix(1, nrow = n) %*% s } else if (length (scale) == p & is.numeric (scale)) { s = scale x = x / matrix(1, nrow = n) %*% s } else if (!is.null (scale)) warning ("Unknown scale specification! Scaling will be omitted.\n") return (list (x = x, center = m, scale = s)) } pcaPP/R/PCAgrid.R0000644000176200001440000002576713124464421013074 0ustar liggesusers sPCAgrid <- function(x, k = 2, method = c ("mad", "sd", "qn"), lambda = 1#, norm.q = 1, norm.s = 1 , maxiter = 10, splitcircle = 25, scores = TRUE, zero.tol = 1e-16, center = l1median, scale, trace = 0, store.call = TRUE, control, ...) { norm.q <- .get_par (list (...), "norm.q", 1) norm.s <- .get_par (list (...), "norm.s", 1) glo.scatter <- .get_par (list (...), "glo.scatter", 0) check.orth <- FALSE dat <- list (x = x, substitute_x = substitute (x), k = k, method = method, maxiter = maxiter, splitcircle = splitcircle, check.orth = check.orth, scores = scores, lambda = lambda, zero.tol = zero.tol, center = center, store.call = store.call, trace = trace, ...) if (!missing (scale)) dat$scale <- scale if (!missing (control)) dat <- .ParseControlStructureC (dat, control) # dat$check.orth <- FALSE ## 2do: remove this value! dat$HDred <- FALSE dat$cut.pc <- TRUE dat$glo.scatter <- glo.scatter dat$SpeedUp <- 0 dat <- .sPCAgrid..DataPreProc (dat) dat$call <- match.call () n <- nrow (dat$x) ret.C <- .C (C_sPCAgrid, NAOK = TRUE, nParIn = as.integer (c(dim (dat$x), dat$k, dat$splitcircle, dat$maxiter, dat$method, dat$trace, dat$k.ini, dat$check.orth, dat$glo.scatter, dat$pHD, dat$SpeedUp)), nParOut = integer (1), dParIn = as.double (c (dat$zero.tol, norm.q, norm.s)), as.double (dat$x), l = as.double (dat$l), sdev = as.double (dat$sdev), obj = double (dat$k), as.double (dat$lambda), ## length = k - k.ini + 1 as.double (dat$HDProj)) return (.sPCAgrid..PostProc (dat, ret.C)) } PCAgrid <- function (x, k = 2, method = c ("mad", "sd", "qn"), maxiter = 10, splitcircle = 25, scores = TRUE, zero.tol = 1e-16, center = l1median, scale, trace = 0, store.call = TRUE, control, ...) { check.orth <- FALSE dat <- list (x = x, substitute_x = substitute (x), k = k, method = method, maxiter = maxiter, splitcircle = splitcircle, check.orth = check.orth, scores = scores, zero.tol = zero.tol, center = center, store.call = store.call, trace = trace, ...) if (!missing (scale)) dat$scale <- scale if (!missing (control)) dat <- .ParseControlStructureC (dat, control) # dat$check.orth <- FALSE ## 2do: remove this value! dat$HDred <- TRUE dat$cut.pc <- TRUE dat$glo.scatter <- 0 dat$SpeedUp <- 0 dat <- .PCAgrid..DataPreProc (dat) dat$call <- match.call () n <- nrow (dat$x) ret.C <- .C (C_PCAgrid, NAOK = TRUE, nParIn = as.integer (c(dim (dat$x), dat$k, dat$splitcircle, dat$maxiter, dat$method, dat$trace, dat$k.ini, dat$check.orth)), nParOut = integer (1), dParIn = as.double (dat$zero.tol), as.double (dat$x), l = as.double (dat$l), sdev = as.double (dat$sdev), obj = double (dat$k)) return (.PCAgrid..PostProc (dat, ret.C)) } .sPCAgrid.ini <- function (x, k = 2, method = c ("mad", "sd", "qn"), norm.q = 1, norm.s = 1, maxiter = 10, splitcircle = 25, scores = TRUE, zero.tol = 1e-16, center = l1median, scale, store.call = TRUE, trace = 0, cut.pc = TRUE, pc.ini, k.ini, ord.all = FALSE, HDred = FALSE, lambda = 1, glo.scatter = 0, SpeedUp = 0, check.orth = FALSE, control, ...) { dat <- list (x = x, substitute_x = substitute (x), k = k, method = method, maxiter = maxiter, splitcircle = splitcircle, scores = scores, lambda = lambda, zero.tol = zero.tol, center = center, store.call = store.call, trace = trace, cut.pc = cut.pc, glo.scatter = glo.scatter, ord.all = ord.all, HDred = HDred, SpeedUp = SpeedUp, check.orth = check.orth, ...) if (!missing (scale)) dat$scale <- scale if (!missing (pc.ini)) dat$pc.ini <- pc.ini if (!missing (k.ini)) dat$k.ini <- k.ini if (!missing (control)) dat <- .ParseControlStructureC (dat, control) dat <- .sPCAgrid..DataPreProc (dat) dat$call <- match.call () n <- nrow (dat$x) ret.C <- .C (C_sPCAgrid, NAOK = TRUE, nParIn = as.integer (c(dim (dat$x), dat$k, dat$splitcircle, dat$maxiter, dat$method, dat$trace, dat$k.ini, dat$check.orth, dat$glo.scatter, dat$pHD, dat$SpeedUp)), nParOut = integer (1), dParIn = as.double (c (dat$zero.tol, norm.q, norm.s)), as.double (dat$x), l = as.double (dat$l), sdev = as.double (dat$sdev), obj = double (dat$k), # max.maha = double (n), as.double (dat$lambda), ## length = k - k.ini + 1 as.double (dat$HDProj)) return (.sPCAgrid..PostProc (dat, ret.C)) } .ParseControlStructureC <- function (x, control) { if (is.null (control) || !length (control)) return (x) nc <- names (control) if (is.null (nc) || any (nc == "")) stop ("Each item of list \x22control\x22 must have a name.") for (i in 1:length (control)) x[[nc[i]]] <- control[[i]] return (x) } .sPCAgrid..DataPreProc <- function (x) { len.lambda = length (x$lambda) if (len.lambda != 1 && len.lambda != x$k) warning ("length (lambda) should either be equal to 1 or k") x$lambda <- rep (x$lambda, len = x$k) x <- .PCAgrid..DataPreProc (x) return (x) } .validScaleMethods <- function () c ("sd", "mad", "qn") .getScaleMethod <- function (x) { .validMethods <- c ("sd", "mad", "qn") x <- x[1] if (is.character (x)) { method <- match.arg (x, .validScaleMethods ()) return (match (method, .validScaleMethods()) - 1) } if (x >= 3 && x != 5 ## hack for the sPCAgrid-paper -> remove this line again... ) stop ("the method is supposed to be a value < 3") return (x) } .getScaleName <- function (x) { if (is.function (x)) return (.GetFunctionName (x)) return (.validScaleMethods () [.getScaleMethod (x) + 1]) } .getScaleFunction <- function (x) ## was .EvalScaleFunction before { if (is.function (x)) return (x) f.idx <- .getScaleMethod (x) + 1 F <- c (sd, mad, qn) return (F [[f.idx]]) # return (eval (parse (text = method))) } .Check_DimRed <- function (x) { ## dimension reduction x$pHD <- 0 ## stores the original p, if we have to reduce the data matrix' dimensionality (n < p) x$x.orig <- x$x if(x$p > x$n && x$HDred) ## Dimension reduction for high dimensional datatsets { svdx <- svd(t(x$x)) x$svdx <- svdx x$x <- svdx$v %*% diag (svdx$d) x$HDProj <- svdx$u x$pHD <- x$p x$p <- ncol (x$x) x$n <- nrow (x$x) if (x$trace >= 2) cat ("reduced dimensions -> n x p =", x$n, "x", x$p, "\n") } return (x) } .scale <- function(x) { x$scl <- ScaleAdv (x$x, x$center, x$scale) x$x <- x$scl$x if (x$pHD) # center and scale must have original data dimension: { x$scl$center <- as.vector(x$svdx$u%*%x$scl$center) x$scl$scale <- ScaleAdv(x$x%*%t(x$svdx$u), center = NULL, scale = x$scale)$scale } return (x) } .Check_pc.ini <-function (x) { if (!is.null (x$pc.ini)) { if (is.null (x$k.ini)) x$k.ini <- x$pc.ini$k } else x$k.ini <- 0 if (x$k.ini) { stopifnot (all (dim (x$pc.ini$load) == ncol (x$x))) stopifnot (x$k.ini + x$k <= ncol (x$x)) if (is.null (x$k.ini)) x$k.ini <- x$pc.ini$k x$k <- x$k.ini + x$k ## 2do: don't change k anymore to k.ini + k stopifnot (length (x$pc.ini$sdev) == ncol (x$x)) x$sdev <- x$pc.ini$sdev x$l <- x$pc.ini$load } else { x$k.ini <- 0 x$sdev <- rep (NA, x$p) x$l <- diag (x$p) } return (x) } .PCAgrid..DataPreProc <- function (x) { x$args <- list (method = x$method) ## 2do: which further args go here? ##x[names (x) != "x"] ## storing the function arguments x$x <- X <- .Conv2Matrix (x$x, x$substitute_x) if (is.function (x$method) && !is.null (x$method.name)) attributes (x$method)$NAME <- x$method.name ## checking/initializing parameters x$n <- nrow (x$x) x$p <- ncol (x$x) stopifnot (is.numeric (x$trace)) stopifnot (x$k >= 1) stopifnot (length (x$k) == 1) x$method <- .getScaleMethod (x$method) x <- .Check_DimRed (x) # x <- .Check_pc.ini (x) stopifnot (x$k <= ncol (x$x)) x <- .scale (x) return (x) } .sPCAgrid..GetLambda.ini <- function (x) { if (!x$k.ini) return (NULL) if (is.null (x$pc.ini$lambda)) return (rep (0, x$k.ini)) return (x$pc.ini$lambda) } .sPCAgrid..PostProc <- function (x, ret.C) { ret <- .PCAgrid..PostProc (x, ret.C) ret$lambda <- c (.sPCAgrid..GetLambda.ini (x), x$lambda) ret } .cut.pc <- function (ret, k) { ret$loadings <- ret$loadings [, 1:k, drop = FALSE] ret$sdev <- ret$sdev [1:k] if (!is.null (ret$scores)) ret$scores <- ret$scores[, 1:k, drop = FALSE] if (!is.null (ret$lambda)) ret$lambda <- ret$lambda [1:k] return (ret) } .orderPCs <- function (ret, k, k.ini, ord.all = FALSE) { if (is.null (ord.all) || ord.all) idx.ord <- 1:k else idx.ord <- (k.ini + 1):k if (length (idx.ord) == 1) ## nothing to sort. return (ret) ord <- order(ret$sdev[idx.ord], decreasing = TRUE) ord <- idx.ord[ord] ret$pc.order <- 1:k ret$pc.order[idx.ord] <- ord ret$sdev[idx.ord] <- ret$sdev[ord] ret$loadings[, idx.ord] <- ret$loadings [, ord] ret$obj[idx.ord] <- ret$obj [ord] if (!is.null (ret$lambda)) ret$lambda[idx.ord] <- ret$lambda [ord] return (ret) } .PCAgrid..PostProc <- function (x, ret.C) { ret <- list (sdev = ret.C$sdev, loadings = matrix (ret.C$l, ncol = x$p, nrow = x$p), k = x$k, obj = ret.C$obj, n.obs = nrow (x$x.orig), args = x$args, #call = x$call, scale = x$scl$scale, center = x$scl$center # , max.maha = ret.C$max.maha ) if (x$store.call) ret$call = x$call if(x$pHD) ## undo SVD for high dimensional datasets ret$loadings <- x$HDProj %*% ret$loadings if (x$cut.pc) ret <- .cut.pc (ret, x$k) ret$loadings <- .loadSgnU (ret$loadings) ret <- .orderPCs (ret, x$k, x$k.ini, x$ord.all) ndn <- list (NULL, paste ("Comp", 1:ncol(ret$loadings), sep = ".")) ## new dimnames if (is.null (dimnames (x$x)[[2]])) ndn[[1]] <- paste ("X", 1:nrow(ret$loadings)) else ndn[[1]] <- dimnames (x$x.orig)[[2]] dimnames (ret$loadings) <- ndn if (x$scores) { ret$scores <- t (t (x$x.orig) - x$scl$center) %*% ret$loadings dimnames (ret$scores) <- list (dimnames (x$x)[[1]], ndn[[2]]) } class (ret$loadings) <- "loadings" class (ret) <- "princomp" return (ret) } .get_par <- function (l, idx, default) { ret <- l[[idx]] if (is.null (ret)) return (default) return (ret) } #.HDred <- function () #{ # if (HDred == "svd") # { # svdx <- svd(t(x)) # x <- svdx$v %*% diag (svdx$d) # HDProj <- svdx$u # } # else if (HDred == "svd.mean") # { # x.m <- colMeans (x) # svdx <- svd(t(x) - x.m) # x <- svdx$v[, -n] %*% diag (svdx$d[-n]) # HDProj <- svdx$u[, -n] # } # else if (HDred == "qr") # { # qrtx <- qr (t (x)) # x <- t (qr.R (qrtx)) # HDProj <- qr.Q (qrtx) # } # else if (HDred == "eigen") # { # e <- eigen (cov (x)) # ev <- e$vectors[,order (e$values, decreasing = TRUE)[1:(n-1)]] # x <- x %*% ev # HDProj <- ev # } # # if (!is.null (HDProj)) # { # pHD <- p # p <- ncol (x) # n <- nrow (x) # if (trace >= 2) # cat ("reduced dimensions -> n x p =", n, "x", p, "\n") # } #} pcaPP/R/PCAproj.R0000644000176200001440000000752713124442372013114 0ustar liggesusers PCAproj <- function (x, k = 2, method = c ("mad", "sd", "qn"), CalcMethod = c("eachobs", "lincomb", "sphere"), nmax = 1000, update = TRUE, scores = TRUE, maxit = 5, maxhalf = 5, scale = NULL, center = l1median_NLM, zero.tol = 1e-16, control) { if (!missing (control)) ###ParseControlStructure (control, c("k", "method", "CalcMethod", "nmax", "update", "scores", "maxit", "maxhalf")) .ParseControlStructure (control, c("k", "method", "CalcMethod", "nmax", "update", "scores", "maxit", "maxhalf", "center", "scale", "zero.tol")) method <- .getScaleMethod (method) CalcMethod <- match.arg (CalcMethod[1], c("eachobs", "lincomb", "sphere")) x <- .Conv2Matrix (x, substitute (x)) n = nrow (x) p = ncol (x) if( k > min(n,p)) stop ('k too large') if(p > n) { svdx = svd(t(x)) x = svdx$v %*% diag(svdx$d) pold=p p=n } else pold=p DataObj = ScaleAdv (x, scale = scale, center = center) if (pold > n) # center and scale must have original data dimension: { DataObj$center <- as.vector(svdx$u%*%DataObj$center) DataObj$scale <- ScaleAdv(x%*%t(svdx$u),center=NULL,scale=scale)$scale } y = DataObj$x # m = l1median(x) # y = t(t(x) - m) if (scores) scoresize <- n * k else scoresize <- 0 if (CalcMethod == "lincomb") { update = FALSE if (nmax > n) { aux = matrix (runif ((nmax-n) * n), nrow = nmax-n) ##y = rbind (y, t(t(aux %*% x) - DataObj$center)) y <- rbind (y, aux %*% y) ## use this instead? } } else if (CalcMethod == "sphere") { update = FALSE if(nmax >n) #y[(n+1):nmax,] = rmvnorm(nmax-n, rep(0,p), diag (p)) y = rbind (y, rmvnorm(nmax-n, rep(0,p), diag (p))) } nn = nrow (y) if (update) ret.C = .C (C_pcaProj_up, as.integer (c(nn, p, n, k, method, scores, maxit, maxhalf)), as.double (zero.tol), as.double (y), scores = double (scoresize), loadings = double (p * k), lambda = double (k)) else ret.C = .C (C_pcaProj, as.integer (c(nn, p, n, k, method, scores)), as.double (zero.tol), as.double (y), scores = double (scoresize), loadings = double (p * k), lambda = double (k)) veig = matrix (ret.C$loadings, ncol = k) idx.mo <- ret.C$lambda == -1 if (any (idx.mo)) { veig [, idx.mo] <- .Null (veig[, !idx.mo]) ret.C$lambda[idx.mo] <- 0 } if(pold>n) veig = svdx$u %*% veig if (scores) .DataPostProc (DataObj, ret.C$lambda, veig, matrix (ret.C$scores, ncol = k) , match.call(), scores) else .DataPostProc (DataObj, ret.C$lambda, veig, NULL, match.call(), scores) } .Null <- function (M) ## Null function from package MASS -> 2do: move calls to LAPACK to C++ code { tmp <- qr(M) set <- if (tmp$rank == 0L) 1L:ncol(M) else -(1L:tmp$rank) qr.Q(tmp, complete = TRUE)[, set, drop = FALSE] } .DataPostProc <- function (DataObj, obj, loadings, scores, cl, bScores) { idx <- order (obj, decreasing = TRUE) obj <- obj [idx] loadings <- loadings [,idx, drop = FALSE] if (bScores) scores <- scores [,idx, drop = FALSE] ret <- list() ##loadings { c <- ncol (loadings) r <- nrow (loadings) ret$loadings <- loadings ret$loadings <- .loadSgnU (ret$loadings) if (is.null (dimnames (DataObj$x)[[2]])) dimnames (ret$loadings) <- list (paste (rep ("V", r), 1:r, sep = ""), paste (rep ("Comp.", c), 1:c, sep = "")) else dimnames (ret$loadings) <- list (dimnames (DataObj$x)[[2]], paste (rep ("Comp.", c), 1:c, sep = "")) class (ret$loadings) <- "loadings" } ##sdev ret$sdev <- as.numeric (obj) names (ret$sdev) <- dimnames (ret$loadings)[[2]] ##center ret$center <- DataObj$center ##scale ret$scale <- DataObj$scale ##n.obs ret$n.obs <- nrow (DataObj$x) ##scores if (bScores) { ret$scores <- scores dimnames (ret$scores) <- list (1:nrow (scores), dimnames (ret$loadings)[[2]]) ; } else ret$scores <- NULL ret$call <- cl class (ret) <- c ("pcaPP", "princomp") return (ret) } pcaPP/R/sPCAgrid_R.R0000644000176200001440000002473512777012547013545 0ustar liggesusers.sPCAgrid.R <- function(x, k = 1, splitcircle = 10, maxiter = 10, method = mad, lambda = 0, cut.pc = TRUE, trace = 0, f.rho = .ident, glo.scatter = 0, ord.mod = 2, center, scale, pc.ini, k.ini, inc.scores = FALSE, HDred = c ("eigen", "qr", "svd", "svd.mean", FALSE)) { # grid search for PCA, using Householder transformation for orthogonality of loadings # # x ... centered (!) data matrix # k ... number of components to determine # splitcircle ... number of directions to search # maxiter ... maximum number of iterations # method ... how to estimate the standard deviation # should be: "sd", "mad", "qn" # stopifnot (is.numeric (trace)) n <- nrow (x) p <- ncol (x) pHD <- 0 HDProj <- NULL f.HDred <- c ("eigen", "qr", "svd.mean", "svd", FALSE) HDred <- pmatch (HDred[1], f.HDred) if (is.na (HDred)) HDred <- 0 else HDred <- f.HDred[HDred] if(p > n) ## Dimension reduction for high dimensional datatsets { if (HDred == "svd") { svdx <- svd(t(x)) x <- svdx$v %*% diag (svdx$d) HDProj <- svdx$u } else if (HDred == "svd.mean") { x.m <- colMeans (x) svdx <- svd(t(x) - x.m) x <- svdx$v[, -n] %*% diag (svdx$d[-n]) HDProj <- svdx$u[, -n] } else if (HDred == "qr") { qrtx <- qr (t (x)) x <- t (qr.R (qrtx)) HDProj <- qr.Q (qrtx) } else if (HDred == "eigen") { e <- eigen (cov (x)) ev <- e$vectors[,order (e$values, decreasing = TRUE)[1:(n-1)]] x <- x %*% ev HDProj <- ev[] } if (!is.null (HDProj)) { p <- ncol (x) n <- nrow (x) #cat ("reduced dimensions -> n x p =", n, "x", p, "\n") } } stopifnot (k >= 1) len.lambda = length (lambda) if (len.lambda != 1 && len.lambda != k) warning ("length (lambda) should either be equal to 1 or k") lambda <- rep (lambda, len = k) if (!missing (pc.ini) && !is.null (pc.ini)) { if (missing (k.ini)) k.ini <- pc.ini$k } else k.ini <- 0 if (k.ini) { stopifnot (nrow (pc.ini$load) == ncol (x)) stopifnot (ncol (pc.ini$load) == ncol (x)) if (missing (k.ini)) k.ini <- pc.ini$k stopifnot (k.ini + k <= ncol (x)) k <- k.ini + k stopifnot (length (pc.ini$sdev) == ncol (x)) sdev <- pc.ini$sdev l <- pc.ini$load } else { k.ini <- 0 sdev <- rep (NA, p) l <- diag (p) } if (missing (center)) center = NULL if (missing (scale)) scale = NULL x <- ScaleAdv (x, center, scale)$x stopifnot (k <= ncol (x)) # if (splitcircle %% 2 == 0) ## forcing splitcircle to be odd (-> obj. function always increases during maxiter - apart from numerical issues)... # #if (splitcircle %% 2) ## forcing splitcircle to be even # splitcircle = splitcircle + 1 if (k.ini) y <- x %*% l[,(k.ini + 1):p] else y <- x if (glo.scatter == 0) scl.mean <- sqrt (mean (apply (x, 2, method)^2)) else scl.mean <- 1 for (nb in (k.ini + 1):k) { # loop over number of comp if (glo.scatter == 1) scl.mean <- sqrt (mean (apply (y, 2, method)^2)) p1 <- p - nb + 1 # dimension will be reduced for subsequent PCs ## p1 = dimensionality of remaining subspace if (p1 == 1) ## if the subspace is one dimensional the only thing left to do is to calculate sdev of the remaining (nx1) matrix Y { ## the loadings are already fixed - there's no free parametes (d.o.f) left sdev [nb] = method (y) next (nb) } # ordering of variables by variance nord <- order(apply(y,2,method),decreasing=TRUE) ## get the decreasing order of the scale estimates. yord <- y[,nord] ## order the data regarding to their scale.. # initializing the lincomb afin <- c(1, rep(0,p1-1)) ## with (1, 0, 0, 0, ...) yopt = yord[,1] ## y %*% afin # outer loop to run until convergence for (i in 0:maxiter) ## the 0 round initializes the system (as before), with div =2^i = 1 { sumabsdelta = 0 for (j in 1:p1) { if (abs (afin [j]) == 1) ## if abs (afin[j]) == 1 -> only the jth variable is considered so far (norm (afin) == 1)-> next (j) ## it wouldn't change anything adding the jth component again. we would only run into numerical issues. rf = c(sqrt (1 - afin[j]^2), afin[j]) ## rotation factors = cos (alpha), sin (alpha) if (afin [j] != 0) ## setting afin[j] to zero. only necessary when afin [j] != 0 { ## -> changing afin[-j] accordingly yopt <- (yopt - yord[,j] * rf[2]) / rf[1] afin [-j] <- afin [-j] / rf[1] afin [j] <- 0 } cury <- cbind(yopt,yord[,j]) # if (glo.scatter >= 3) # scl.mean <- sqrt (mean (apply (cury, 2, method)^2)) res <- .gridplane.shrk(n = splitcircle, div = 2^i, curL = rf[2], y = cury, method = method, afin = afin, nord = nord, curP = j, curK = nb, l = l, lambda = lambda[nb - k.ini], f.rho = f.rho, scl.mean = scl.mean, u = HDProj) sumabsdelta = sumabsdelta + abs (res$alphamax[2] - rf[2]) ## sums up the absolute change of the angles rf <- res$alphamax ## rotation factors <- c (cos (alpha), sin (alpha)) yopt <- yopt * rf[1] + yord[,j] * rf[2] afin[-j] = afin[-j] * rf[1] afin[j] = rf[2] #cat ("loadings:", afin, "\n") } afin=afin/sqrt(sum(afin^2)) ## normieren. -> why? objf <- res$objmax { ## thinking about dropping this block. if splitcircle odd -> the obj can't drop (or?!?!?)! (because the best candidate in the last round would hence be a candidate in this round too) if (!i || objf>=objfold) { objfbest <- objf objfold <- objf sclbest <- res$sclmax afinbest <- afin/sqrt(sum(afin^2)) ## why again? } else if (trace >= 2) cat ("objective function dropped:", objfold - objf, "\r\n") } if (sumabsdelta < 1e-16) #if (2^-i < 1e-16) { cat ("stopping execution after", i + 1, "loops\n") break ## breaks the maxiter loop, as there's no more progress.. } } # maxiter sdev[nb] <- sclbest # if (length (afinbest) == 2) # { # afin[nord] <- afinbest # afinNV <- matrix (c (afin, afin[2], -afin[1]), nrow = 2) # } # else { afinNV <- diag(p1) if (ord.mod == 1) { afin <- afinbest ## xxxord1 idx.ref <- 1 ## xxxord1 } else { afin[nord] <- afinbest ## xxxord2 idx.ref <- nord[1]#which.max (abs (afin))## xxxord2 } N <- afinNV[,idx.ref]-afin N.norm <- .norm (N) if (N.norm > 1e-6) ## use zero.tol { if (afin [idx.ref] < 0) ## we want the first (one particular - which?) value to be positive afin <- -afin N <- N / N.norm afinNV <- afinNV - (2*N %*% t(N)) } #afinNV <- cbind (afin, Null (afin)) ## Null creates the orthogonal complement of afin if (ord.mod == 1) { afinNV[nord,] <- afinNV ## xxxord1 ## nord must be inversed HERE, not before creating the backtransformation. ## otherwise the result would depend on the input order of variables (due to numerical issues when creating the back transformation matrix) ## thus ord.mod == 1 is the "better" way? why is default 2 then? maybe because the "real" PCAgrid algo does it that way? } else afinNV <- afinNV[,nord] ## xxxord2 } ## afinNV contains afin + its orthogonal complement l[,nb:p] <- l [,nb:p] %*% afinNV y <- y %*% afinNV[,-1] ## projecting the data into the complement of afin. if (trace >= 3) { y1=x%*%l[,(nb+1):p] cat ("numerical instability for component", nb, ":", .norm (y-y1), "\r\n") } } # loop over number of comp ord <- order(sdev,decreasing=TRUE) sdev <- sdev[ord] l <- l [,ord, drop = FALSE] proj.loadings <- NULL if(!is.null (HDProj)) ## undo Projection for high dimensional datasets { # proj.loadings <- l l <- HDProj %*% l } if (cut.pc) { l <- l [,1:k, drop = FALSE] sdev <- sdev [1:k] } ret <- list (sdev = sdev, loadings = l, scores = NULL, k = k, call = match.call) #, u = HDProj, proj.loadings = proj.loadings, x = x) if (inc.scores) ret$scores <- x %*% l ret } .gridplane.new <- function (n = 10, div = 1, curL = 0, y, method, ...) { nangle <- seq (-pi/2, pi/2, len = n) / div + ## the angles to check asin (curL) ## the angle - component of the current loading alpha <- cbind(cos(nangle),sin(nangle)) obj <- apply(y %*% t(alpha), 2, method) ## VVV like gridplane VVV idx.max = which.max (obj) list(objmax=obj[idx.max],alphamax=alpha[idx.max,], sclmax=obj[idx.max], idx.max = idx.max) } .ident <- function (i) 1 .inverse <- function (i) 1/(i+1) .gridplane.shrk <- function (n = 10, div = 1, curL = 0, y, method, afin, nord, curP, curK, l, lambda, f.rho = .ident, scl.mean, u, ...) { nangle <- seq (-pi/2, pi/2, len = n) / div + ## the angles to check asin (curL) ## the angle - component of the current loading alpha <- cbind(cos(nangle),sin(nangle)) ## afinN the new linear combinations, one column for each angle tested... afinN <- afin %*% t(alpha[,1]) ## applying the effect of the new param "curP" to all other params afinN[curP,] <- alpha[,2] ## setting the new param "curP" afinN[nord,] <- afinN ## reversing the sort order of the variables p <- nrow (l) #nOrigParams <- l [, curK:p] %*% afinN ## transforming the new params back into the "real" system of Coordinates if (!missing (u) && !is.null (u)) ## undo the svd transformation for high dimensional datasets u <- u %*% l [, curK:p] else u <- l [, curK:p] nOrigParams <- u %*% afinN # cat ("backtrans: \n") # print (u) # cat ("\n\n") shrk <- colSums (abs (nOrigParams)) ## the shrinkage factors for each angle scl <- apply(y %*% t(alpha), 2, method) ## the scale for each angle obj <- scl^2 - lambda * shrk * scl.mean^2 * f.rho (curK) ## objective function... # obj <- - shrk #browser () idx.max = which.max (obj) nang <- nangle[idx.max] # if (nang < 0.4) # nang = - (nang - pi / 2) #cat ("checking angles ", paste (nangle, " (", - lambda * shrk * scl.mean^2, ", ", obj, "),", collapse = " ", sep = ""), "\n", sep = "") #cat ("selected angle", format (nang, digits = 22), "\n") list(objmax = obj[idx.max], alphamax = alpha [idx.max,], sclmax = scl[idx.max], idx.max = idx.max) } .norm <- function (x) sqrt (sum(x^2)) .sumsq <- function (x) sum (x^2) pcaPP/R/plotcov.R0000644000176200001440000000730412777012547013307 0ustar liggesusersplotcov <- function (cov1, cov2, method1, labels1, method2, labels2, ndigits = 4, ...) { if (class (cov1) == "matrix") cm1 = cov1 else if (is.null (cov1$cov)) stop ("No appropriate covariance structure specified") else { cm1 = cov1$cov if (!is.null (cov1$method)) method1 = cov1$method } if (missing (method1)) #|| is.null(method1)) method1 = "Method 1" if (ncol (cm1) != nrow (cm1)) stop ("Supplied covariance structure has to be quadratic!") if (missing (labels1)) if (is.null (dimnames (cm1))) labels1 = paste ("V", 1:ncol (cm1), sep = "") else labels1 = dimnames (cm1)[[1]] if (missing (cov2)) { # only plotting cov1 .plotsingle (cm1, labels1, method1, ndigits, ...) } else { if (class (cov2) == "matrix") cm2 = cov2 else if (is.null (cov2$cov)) stop ("No appropriate covariance structure specified") else { cm2 = cov2$cov if (!is.null (cov2$method)) method2 = cov2$method } if (missing (method2))# || is.null(method2)) method2 = "Method 2" if (ncol (cm2) != nrow (cm2)) stop ("Supplied covariance structure has to be quadratic!") if (missing (labels2)) if (is.null (dimnames (cm2))) labels2 = paste ("V", 1:ncol (cm2), sep = "") else labels2 = dimnames (cm2)[[1]] .plotcomp (cm1, cm2, labels1, labels2, method1, method2, ndigits, col = "#0096FF", ...) } invisible() } .plotcomp <- function (cor1, cor2, labels1, labels2, method1, method2, ndigits = 4, ...) ## internal function { plot.new() # plot (0,0, pch = "", axes = F, xlab = "", ylab = "") oldmar = par ("mar") par (mar = rep(1, 4)) p = ncol (cor1) lim = c(-1, p + 1) plot.window(xlim=lim, ylim= lim, xaxs="i", yaxs="i") for (i in 1:p) { text (i - 0.5, p + 0.5, labels1[i], srt=90) text (-0.5, p - i + 0.5, labels2[i]) } for (i in 2:p) { for (j in 1:(i-1)) { .doEllipses (cor1[c(i,j), c(i,j)], pos = c(i - 1.5,p - j - 0.5), lwd = 2) .doEllipses (cor2[c(i,j), c(i,j)], pos = c(i - 1.5, p - j - 0.5), lwd = 2, ...) text (j - 0.5,p - i + 0.5, round (cor1[i,j], ndigits), adj = c(0.5,-0.1)) text (j - 0.5,p - i + 0.5, round (cor2[i,j], ndigits), adj = c(0.5,1.1), ...) } } lines (c(0.5, p-0.5), c(p - 0.5, 0.5), lwd = 3) # lines (mean (lim) + lines (lim[2] - 2 + c(-0.5, 0.3), c(-0.3, -0.3)) lines (lim[2] - 2 + c(-0.5, 0.3), c(-0.7, -0.7), ...) text (lim[2] - 2 - 0.7, -0.275, method1, pos = 2) text (lim[2] - 2 - 0.7, -0.675, method2, pos = 2) par (mar = oldmar) } .plotsingle <- function (cm, labels, method, ndigits, ...) { plot.new() oldmar = par ("mar") par (mar = rep(1, 4)) p = ncol (cm) lim = c(-1, p + 1) plot.window(xlim = lim, ylim = lim, xaxs = "i", yaxs = "i") for (i in 1:p) { text (i - 0.5, p + 0.5, labels[i], srt=90) text (-0.5, p - i + 0.5, labels[i]) } for (i in 2:p) { for (j in 1:(i-1)) { .doEllipses (cm[c(i,j), c(i,j)], pos = c(i - 1.5,p - j - 0.5), lwd = 2, ...) text (j - 0.5 ,p - i + 0.5, round (cm[i,j], ndigits), ...) } } lines (c(0.5, p-0.5), c(p - 0.5, 0.5), lwd = 3) lines (lim[2] - 2 + c(-0.5, 0.3), c(-0.5, -0.5), col = col, ...) text (lim[2] - 2 - 0.7, -0.475, method, pos = 2) par (mar = oldmar) } .doEllipses <- function (acov, pos, ...) ## internal function { acov = cov2cor (acov) cov.svd <- svd(acov, nv = 0) r <- cov.svd[["u"]] %*% diag(sqrt(cov.svd[["d"]])) m <- 100 alphamd <- c(1/3) # par(pty="s") e1md <- cos(c(0:m)/m * 2 * pi) * alphamd e2md <- sin(c(0:m)/m * 2 * pi) * alphamd emd <- cbind(e1md, e2md) ttmd <- t(r %*% t(emd)) + rep(1, m + 1) lines(ttmd[, 1] + pos[1], ttmd[, 2]+ pos[2], ...) } pcaPP/R/plot.opt.TPO.R0000644000176200001440000001755312777012547014050 0ustar liggesusers plot.opt.TPO <- function (x, k, f.x = c ("l0", "pl0", "l1", "pl1", "lambda"), f.y = c ("var", "pvar"), ...) { .plot.sPCAgrid.opt.ind (x = x, k = k, f.x = f.x, f.y = f.y, ...) } plot.opt.BIC <- function (x, k, f.x = c ("l0", "pl0", "l1", "pl1", "lambda"), f.y = c ("var", "pvar"), ...) { .plot.sPCAgrid.opt.tot (x = x, k = k, f.x = f.x, f.y = f.y, ...) } .eval.fx <- function (f.x) { if (is.function (f.x)) return (f.x) f.x <- f.x[[1]] .valf <- c ("l0", "l1", "lambda", "pl0", "pl1") f.x <- match.arg (f.x, .valf) f.x <- match (f.x, .valf) .F <- c (.l0sparse, .l1sparse, .lambda, .pl0sparse, .pl1sparse) return (.F[[f.x]]) } .eval.fy <- function (f.y) #, supr) { if (is.function (f.y)) return (f.y) f.y <- f.y[[1]] .valf <- c("var", "dvar", "pvar", "dpvar") #, "obj") f.y <- match.arg (f.y, .valf) # if (!missing (supr)) # if (any (supr == f.y)) # stop (paste ("Option \"", f.y, "\"cannot be used in this context", sep = "")) f.y <- match (f.y, .valf) .F <- c (.sumVar, .sumVarDiff, .sumVarP, .sumVarDiffP) #, .obj) return (.F[[f.y]]) } .format.PCidx <- function (k, kto) { if (length (k) > 1) { if (!missing (kto)) stop ("if kto is specified, k must be of length 1") kto <- max (k) k <- min (k) } else { if (missing (kto)) kto <- k else if (kto < k) { temp <- k k <- kto kto <- temp } } if (k == kto) return (paste ("PC", k)) return (paste ("PCs ", k, "-", kto, sep = "")) } .title.trdoffC <- function (k, kto) { paste ("Tradeoff Curve (", .format.PCidx (k, kto), ")", sep = "") } .plot.sPCAgrid.opt.tot <- function (x, k, main, ...) #, f.x = "l0", f.y = "pvar", ylim, xlab, ylab, main.pre, main.suf) { if (missing (k)) k = x$k.ini + length (x$pc) opt.idx <- k - x$k.ini stopifnot (length (k) == 1) stopifnot (any (class (x) == "sPCAgrid.opt.tot")) if (is.null(x$opt)) stop ("x does not contain iteration data. Set \x22store.PCs = TRUE\x22 for function sPCAgrid.opt.tot") if (missing (main)) main <- .title.trdoffC (x$k.ini + 1, k) ret <- .plot.opt (x = x$x, opt = x$opt, opt.idx = opt.idx, main = main, ...) # .opt.summary (x = x$x, pc = x$pc.noord[[opt.idx]], opt = x$opt, k = x$opt$k[[opt.idx]], ...) .opt.summary (x = x$x, opt = x$opt, opt.idx = opt.idx, idx.lambda = FALSE, ...) return (invisible (ret)) } .plot.sPCAgrid.opt.ind <- function (x, k, main, ...) #, f.x = "l0", f.y = "pvar", ylim, xlab, ylab, main, main.pre, main.suf, ...) { if (missing (k)) k <- x$k.ini + 1 stopifnot (length (k) == 1) stopifnot (any (class (x) == "sPCAgrid.opt.ind")) if (is.null(x$opt)) stop ("x does not contain iteration data. Set \x22store.PCs = TRUE\x22 for function sPCAgrid.opt.ind") n.k <- length (x$pc$lambda) .assureRange (k, x$k.ini + 1, x$k.ini + n.k) opt.idx <- k - x$k.ini if (missing (main)) main <- .title.trdoffC (k) opt <- x$opt[[opt.idx]] ret <- .plot.opt (x = x$x, opt = opt, main = main, ...) .opt.summary (x = x$x, pc = x$pc.noord, opt = opt, k = k, ...) return (invisible (ret)) } .applyPFunc <- function (PCs, pc, idx.pc, f, ...) { if (missing (pc)) pc <- PCs[[idx.pc]] f.0 <- f (pc = PCs[[1]], ...) f.1 <- f (pc = PCs[[length (PCs)]], v.0 = f.0, ...) f (pc = pc, v.0 = f.0, v.1 = f.1, ...) } .plot.opt <- function (x, opt, opt.idx = 1, f.x = "pl0", f.y = "pvar", ylim, xlab, ylab, main, main.pre, main.suf, ...) { k <- opt$k[[opt.idx]] f.x <- .eval.fx (f.x) f.y <- .eval.fy (f.y) if (missing (xlab)) xlab <- .GetFunctionName (f.x, k = k) if (missing (ylab)) ylab <- .GetFunctionName (f.y, k = k) PCs <- opt$PCs pdat <- .trdoff.sPCAgrid.ind (x, PCs, k = k, f.x, f.y, ...) if (missing (main)) main <- paste ("Tradeoff Curve PC", k) if (!missing (main.pre)) main <- paste (main.pre, main) if (!missing (main.suf)) main <- paste (main, main.suf) if (missing (ylim)) ylim <- c (0, max (pdat [,2])) plot (pdat[order(pdat[,1]),], type = "b", xlab= xlab, ylab = ylab, ylim = ylim, main = main) if (is.null (opt$idx.best)) return (invisible (pdat)) abline (v = pdat[opt$idx.best[opt.idx], 1], lty = 2) return (invisible (pdat)) } .opt.summary <- function (x, pc, optmode, k, opt, opt.idx, idx.lambda = TRUE, ...) { if (missing (pc)) pc <- opt$pc[[opt.idx]] if (missing (k)) k <- opt$k[[opt.idx]] if (missing (optmode)) optmode <- opt$mode lam <- round (pc$lambda [max (k)], 2) if (length (k) > 1) k.use <- k else k.use <- 1:k vartot <- .sumVarP (x = x, pc = pc, k = k.use, ...) ecv <- .sumVarP (x = x, pc = pc, k = k.use, v.0 = vartot, ...) # ecv <- .applyPFunc (opt$PCs, pc, f = .sumVarP, k = k.use, x = x, ...) ecv <- round (ecv, 2) LoS <- .l0sparse (pc = pc,k = k.use, ...) # LoS <- .applyPFunc (opt$PCs, pc, f = .l0sparse, k = k.use, x = x, ...) if (length (k.use) > 1) txtK <- paste (min(k.use), "-", max(k.use), sep = "") else txtK <- k.use txtECV <- bquote (paste ("ECV" [.(txtK)], ": ", .(ecv), "%")) txtLoS <- bquote (paste ("L"[0], "S" [.(txtK)], ": ", .(LoS))) if (idx.lambda) { ssL <- paste ("opt", max (k), sep = "") txtLambda <- bquote (paste (lambda[.(ssL)], ": " ,.(lam))) } else txtLambda <- bquote (paste (lambda[opt], ": " ,.(lam))) txt <- bquote(paste (.(optmode), " - ", .(txtLambda), "; ", .(txtECV), "; ", .(txtLoS))) mtext (txt, line = 0.25, cex = 0.8) } .trdoff.sPCAgrid.ind <- function (x, PCs, f.x, f.y, ...) { n <- length (PCs) x.0 <- f.x (x = x, pc = PCs[[1]], ...) x.1 <- f.x (x = x, pc = PCs[[n]], v.0 = x.0, ...) y.0 <- f.y (x = x, pc = PCs[[1]], ...) y.1 <- f.y (x = x, pc = PCs[[n]], v.0 = y.0, ...) rx <- sapply (PCs, .flexapply, f = f.x, NAME = "pc", args = list (x = x, v.0 = x.0, v.1 = x.1, ...)) ry <- sapply (PCs, .flexapply, f = f.y, NAME = "pc", args = list (x = x, v.0 = y.0, v.1 = y.1, ...)) stopifnot (is.numeric (rx)) stopifnot (is.numeric (ry)) ret <- cbind (rx, ry) # ret <- ret [order (ret[,1]), ] class (ret) <- "trdoff.sPCAgrid" ret } .assureRange <- function (x, l, u, name = substitute (x)) { if (missing (l)) { if (x > u) stop (paste (name, "must not be larger than ", u)) } else if (missing (u)) { if (x < l) stop (paste (name, "must not be smaller than ", l)) } else if (x < l || x > u) stop (paste (name, "must be between", l, "and", u)) } objplot <- function (x, k, ...) { if (any (class (x) == "sPCAgrid.opt.tot")) { if (missing (k)) k = x$k.ini + length (x$pc) .assureRange (k, x$k.ini, x$k.ini + length (x$pc)) opt.idx <- k - x$k.ini .objplot (x$opt, opt.idx = opt.idx) .opt.summary (x = x$x, opt = x$opt, opt.idx = opt.idx, idx.lambda = FALSE, ...) } else if (any (class (x) == "sPCAgrid.opt.ind")) { if (missing (k)) k = x$k.ini + 1 .assureRange (k, x$k.ini, x$k.ini + length (x$pc$lambda)) opt <- x$opt[[k - x$k.ini]] .objplot (opt, k = k) .opt.summary (x = x$x, pc = x$pc.noord, opt = opt, k = k, ...) } } .objplot <- function (opt, opt.idx = 1, k, main, xlab, ylab, type = "b", ...) { obj <- opt$obj[,opt.idx] if (missing (k)) k <- opt$k[[opt.idx]] lambda <- sapply (opt$PCs, get ("[["), "lambda") if (is.matrix (lambda)) lambda <- lambda [nrow (lambda),] if (missing (main)) if (length (k) > 1) main <- paste ("Model Selection (PCs ", min (k), "-", max(k), ")", sep = "") else main <- paste ("Model Selection (PC ", k, ")", sep = "") if (missing (xlab)) xlab <- expression (lambda) if (missing (ylab)) ylab <- paste ("Objective Function (", opt$mode, ")", sep = "") plot (lambda, obj, xlab = xlab, ylab = ylab, main = main, type = type, ...) cl <- lambda [which.min (obj)] abline (v = cl, lty = 2) # txt <- bquote (lambda[opt] == .(round (cl, 2))) # mtext (line = 0.25, text = txt, cex = 0.8) invisible () } pcaPP/R/sPCAgrid.obj.R0000644000176200001440000001127712777012547014032 0ustar liggesusers#################################### ## Tradeoff Area - Optimization ## #################################### .TPO <- function (f.x = .l0sparse, f.y = .sumVar, obj.pc.0, obj.pc.1, fa.Name = "TPO", ...) { if (missing (obj.pc.0)) return (list (x = f.x (...), y = f.y (...))) if (missing (obj.pc.1)) return (list (x = f.x (v.0 = obj.pc.0[[1]], ...), y = f.y (v.0 = obj.pc.0[[1]], ...))) x <- f.x (v.0 = obj.pc.0$x, v.1 = obj.pc.1$x, ...) y <- f.y (v.0 = obj.pc.0$y, v.1 = obj.pc.1$y, ...) return (-x * y) } .l1sparse <- function (x, pc, k, fa.Name = expression (paste (L[1], " Sparseness")), ...) { p <- nrow (pc$load) n.k <- length (k) n.k * sqrt (p) - sum (abs (pc$loadings[,k])) } .l0sparse <- function (x, pc, k, zero.tol = 1e-16, fa.Name = expression (paste (L[0], " Sparseness")), ...) { sum (abs (pc$loadings[,k]) <= zero.tol) } .pl1sparse <- function (x, pc, k, fa.Name = expression (paste (L[1], " Sparseness (%)")), ...) { p <- nrow (pc$load) n.k <- length (k) .l1sparse (x, pc, k, ...) / ((sqrt (p) - 1) * n.k) * 100 } .pl0sparse <- function (x, pc, k, zero.tol = 1e-16, fa.Name = expression (paste (L[0], " Sparseness (%)")), ...) { p <- nrow (pc$load) n.k <- length (k) .l0sparse (x, pc, k, ...) / ((p - 1) * n.k) * 100 } .lambda <- function (x, pc, k, fa.Name = expression (lambda), ...) { if (length (k) == 1) return (pc$lambda[k]) if (any (diff (pc$lambda) != 0) && length (k) > 1) stop ("This option can only be used when all considered PCs were calculated with the same lambda.") return (pc$lambda[1]) } .vn <- function (n, k) { if (length (k) == 1) return (n) return (paste ("Cumulated", n)) } .sumVar <- function (x, pc, k, NAME = FALSE, ...) { if (NAME) return (.vn ("Explained Variance", k)) return (sum (pc$sdev[k]^2)) } .sumVarDiff <- function (x, pc, k, v.1 = 0, NAME = FALSE, ...) { if (NAME) return (.vn ("diff Explained Variance", k)) return (sum (pc$sdev[k]^2) - v.1) } .sumVarP <- function (x, pc, k, v.0, NAME = FALSE, ...) { if (NAME) return (.vn ("Explained Variance (%)", k)) if (missing (v.0)) ## return the total variance of x return (sum (apply (x, 2, .getScaleFunction (pc$args$method))^2)) return (sum (pc$sdev[k]^2) / v.0 * 100) } .sumVarDiffP <- function (x, pc, k, v.0, v.1 = 0, NAME = FALSE, ...) { if (NAME) return (.vn ("diff Explained Variance (%)", k)) if (missing (v.0)) ## return the total variance of x return (sum (apply (x, 2, .getScaleFunction (pc$args$method))^2)) return (sum (pc$sdev[k]^2) / v.0 * 100 - v.1) } .obj <- function (pc, fa.Name = "Objective Function", ...) { pc$ev } ##################### ## BIC criterion ## ##################### .BIC.RSS <- function (obj.pc.0, f.BIC = .nBIC.Guo, f.RSS = .Calc.RSS.a, fa.Name = "BIC", ...) #.BIC.RSS <- function (obj.pc.0, f.BIC = .nBIC.CC, f.RSS = .Calc.RSS.a, NAME = FALSE, ...) #BIC.RSS <- function (obj.pc.0, f.BIC = .nBIC.CC, f.RSS = .Calc.RSS.e, get.name = FALSE, ...) { # if (NAME) # return (paste (.GetFunctionName (f.BIC, ...), "(", .GetFunctionName (f.RSS, ...),")")) RSS <- f.RSS (...) if (missing (obj.pc.0)) return (RSS) df_k <- .Calc.df_k (...) f.BIC (RSS0 = RSS, RSS = obj.pc.0, df_k = df_k, ...) } .Calc.df_k <- function (pc, k, zero.tol = 1e-15, ...) { sum (abs (pc$loadings[,k]) > zero.tol)} .Calc.RSS.e <- function (pc, k, fa.Name = "RSS: exact", ...) { p <- nrow (pc$load) if (length (pc$sdev) < p) stop ("all eigenvectors needed for exact computation of RSS") sum (pc$sdev[-(1:max(k))]^2) } .Calc.RSS.a <- function (x, pc, k, fa.Name = "RSS: approx", ...) { if (ncol (pc$loadings) < length (k)) stop ("at least k eigenvectors needed for approximate calculation of RSS") l <- pc$loadings[,1:max(k)] f.method <- .getScaleFunction (pc$args$method) sum (apply (x - x %*% l %*% t(l), 2, f.method)^2) } .nBIC.CC <- function (x, RSS0, RSS, df_k, k, fa.Name = "BIC", trace = 0, ...) { ## RSS0 as the restricted model's RSS ## RSS as the unrestricted model's RSS ## df_k as the number of non-zero loadings of the restricted model n <- nrow (x) BIC <- RSS0 / RSS + df_k * log (n) / n if (trace >= 2) cat ("RSS0:", RSS0, "; RSS:", RSS, "; df_k:", df_k, "; n:", n, "; BIC:", BIC, "\n") BIC } .nBIC.Guo <- function (x, RSS0, RSS, df_k, k, fa.Name = "BIC", trace = 0, ...) { ## RSS0 as the restricted model's RSS ## RSS as the unrestricted model's RSS ## df_k as the number of non-zero loadings of the restricted model n <- nrow (x) BIC <- RSS0 / RSS + df_k * log (n)# / n if (trace >= 2) cat ("RSS0:", RSS0, "; RSS:", RSS, "; df_k:", df_k, "; n:", n, "; BIC:", BIC, "\n") BIC } pcaPP/R/covPC.R0000644000176200001440000000315712777012547012635 0ustar liggesuserscovPC <- function (x, k = ncol (x$loadings), method) { if (!any(class(x) == "princomp")) stop ("Invalid parameter \x22k\x22: Data type princomp expected!") if (length (x$sdev) != length (x$center)) warning ("Calculating a rank", length (x$sdev), "- covariance matrix") ret = list() k = min (ncol (x$loadings), k) ret$cov = x$loadings[,1:k] %*% diag (x$sdev[1:k]^2) %*% t(x$loadings[,1:k]) ret$center = x$center if (missing (method)) ret$method = "Covariance estimation based on PCs" else ret$method = method class (ret) <- "covPC" return (ret) } covPCAgrid <- function (x, control) { pcs = PCAgrid (x, k = ncol(x), control = control) ret = list() ret$cov = pcs$loadings %*% diag (pcs$sdev^2) %*% t(pcs$loadings) ret$center = pcs$center ret$method = "Robust cov - estimation based on PCs (grid mode)" if (!missing (control) && !is.null (control$method)) ret$method = paste ("Robust cov - estimation based on PCs (grid mode -", control$method, ")", sep = "") else ret$method = "Robust cov - estimation based on PCs (grid mode)" class (ret) <- "covPC" return (ret) } covPCAproj <- function (x, control) { pcs = PCAproj (x, k = ncol(x), control = control) ret = list() ret$cov = pcs$loadings %*% diag (pcs$sdev^2) %*% t(pcs$loadings) ret$center = pcs$center if (!missing (control) && !is.null (control$method)) ret$method = paste ("Robust cov - estimation based on PCs (projection mode - ", control$method, ")", sep = "") else ret$method = "Robust cov - estimation based on PCs (projection mode)" class (ret) <- "covPC" return (ret) } pcaPP/R/qn.R0000644000176200001440000000035513124442752012226 0ustar liggesusers qn <- function (x, corrFact) { if (missing (corrFact)) corrFact = 1 / (sqrt(2) * qnorm(5/8)) ret.C <- .C (C_qn, as.integer (length (x)), as.double (corrFact), parOutD = double (1), x = as.double (x)) ret.C$parOutD } pcaPP/R/opt.TPO.R0000644000176200001440000002624712777012547013073 0ustar liggesusers opt.TPO <- function (x, k.max = ncol (x), n.lambda = 30, lambda.max, ...) { store.opt = TRUE ret <- .sPCAgrid.opt.ind (x = x, k.max = k.max, n.lambda = n.lambda, lambda.max = lambda.max, store.PCs = store.opt, f.eval = .TPO, ...) class (ret) <- c (class (ret), "opt.TPO") return (ret) } opt.BIC <- function (x, k.max = ncol (x), n.lambda = 30, lambda.max, ...) { store.opt = TRUE ret <- .sPCAgrid.opt.tot (x = x, k.max = k.max, n.lambda = n.lambda, lambda.max = lambda.max, store.PCs = store.opt, f.eval = .BIC.RSS, ...) class (ret) <- c (class (ret), "opt.BIC") return (ret) } .flexapply <- function (X, f, NAME, args) { args[[NAME]] <- X do.call (f, args) } .sPCAgrid.ml <- function (..., lambda, f.pca = .sPCAgrid.ini, f.apply = lapply) { args <- list (...) args$store.call <- FALSE f.apply (X = lambda, FUN = .flexapply, f = f.pca, NAME = "lambda", args = args) } #.listset <- function (x, y, name = "y") #{ # stopifnot (length (x) == length (y)) # # for (i in 1:length (x)) # x[[i]][[name]] <- y[[i]] # x # } .sPCAgrid.opt.tot <- function (x, n.lambda = 101, k.max = 2, lambda, lambda.ini, lambda.max, trace = 0, store.PCs = TRUE, f.apply = lapply, f.eval = .TPO, ...) { pc.ini <- NULL f.pca <- .sPCAgrid.ini # f.eval <- .TPO if (!missing (lambda.ini) && !is.null (lambda.ini)) ## use lambda.ini { k.ini <- length (lambda.ini) pc.ini <- f.pca (x = x, lambda = lambda.ini, k = k.ini, cut.pc = FALSE, ...) if (!missing (pc.ini) && !is.null (pc.ini)) warning ("argumens \x22pc.ini\x22 AND \x22lambda.ini\x22 were specified. Ignoring \x22pc.ini\x22.") } else if (!missing (pc.ini) && !is.null (pc.ini)) ## use pc.ini { k.ini = pc.ini$k lambda.ini <- rep (NA, k.ini) } else { pc.ini <- NULL lambda.ini <- NULL k.ini <- 0 } # if (missing (lambda) && !missing (lambda.max)) ## Change 20120407 # lambda.max <- rep (lambda.max, len = k.max) ## Change 20120407 p <- ncol (x) if (k.ini == p) stop ("all components have already been computed") if (k.ini + k.max > p) { warning (paste ("reducing k.max to", p - k.ini)) k.max <- p - k.ini } if (missing (lambda)) { # if (missing (lambda.max) || is.na (lambda.max[i])) ## Change 20120407 if (missing (lambda.max) || is.na (lambda.max)) max.fs <- .FSgetLambda (x = x, k = k.max, pc.ini = pc.ini, f.pca = f.pca, scores = FALSE, trace = trace, ...) else # max.fs <- lambda.max[i] ## Change 20120407 max.fs <- lambda.max[1] lambda <- seq (0, max.fs, len = n.lambda) } PCs <- .sPCAgrid.ml (x = x, pc.ini = pc.ini, k = k.max, scores = FALSE, cut.pc = TRUE, trace = trace, f.pca = f.pca, lambda = lambda, f.apply = f.apply, ...) opt <- .SPCAgrid.opt (x, PCs, f.eval, store.PCs, k = k.ini + 1:k.max, singlePC = FALSE, ...) if (!store.PCs) return (opt) ret <- list (pc = list (), pc.noord = list (), x = x, k.ini = k.ini, opt = opt) for (i in 1:length (opt$pc)) { pc <- .cut.pc (opt$pc[[i]], k.ini + k.max) ret$pc.noord[[i]] <- pc ret$pc[[i]] <- .orderPCs (pc, k.max, k.ini, TRUE) } class (ret) <- "sPCAgrid.opt.tot" return (ret) } .sPCAgrid.opt.eval <- function (x, f.eval = .BIC.RSS, k = 1, ...) { if (all (class (x) != "sPCAgrid.opt.tot")) stop ("x must be of type \"sPCAgrid.opt.tot\"") ##2do: check parameter k .SPCAgrid.opt (x$x, x$opt$PCs, f.eval, storePCs = FALSE, k = 1:k, ...) } .SPCAgrid.opt <- function (x, PCs, k, f.eval, store.PCs, f.apply = sapply, singlePC = TRUE, ...) { ret <- list () if (store.PCs) ret$PCs <- PCs if (missing (f.eval) || !is.function (f.eval)) { if (!store.PCs) stop ("either store.PCs must be TRUE, or f.eval must be a valid model evaluation function") return (ret) } ret$pc <- ret$k <- list () ret$mode <- .GetFunctionName (f.eval, ...) for (i in 1:length (k)) { if (singlePC) K <- k[i] else K <- k[1:i] obj.pc.0 <- f.eval (x = x, pc = PCs[[1]], k = K, ...) #.l0sparse (x = x, px = PCs[[1]], k = K, ...) obj.pc.1 <- f.eval (x = x, pc = PCs[[length (PCs)]], k = K, obj.pc.0 = obj.pc.0, ...) #.sumVar (x = x, pc = PCs[[length (PCs)]], k = K, ...) obj <- f.apply (X = PCs, FUN = .flexapply, f = f.eval, NAME = "pc", args = list (x = x, k = K, obj.pc.0 = obj.pc.0, obj.pc.1 = obj.pc.1, ...)) ret$obj <- cbind (ret$obj, obj) idx.best <- which.min (obj) ret$idx.best <- cbind (ret$idx.best, idx.best) ret$pc[[i]] <- PCs[[idx.best]] ret$k[[i]] <- K } if (!store.PCs) return (ret$pc) return (ret) } .sPCAgrid.opt.ind <- function (x, n.lambda = 101, k.max = ncol (x), lambda.ini, lambda.max, trace = 0, store.PCs = TRUE, f.eval = .TPO, ...) { pc.ini <- NULL f.pca <- .sPCAgrid.ini if (!missing (lambda.ini) && !is.null (lambda.ini)) ## go for lambda.ini { k.ini <- length (lambda.ini) pc.ini <- f.pca (x = x, lambda = lambda.ini, k = k.ini, cut.pc = FALSE, ...) if (!missing (pc.ini)) stop ("either store.PCs must be TRUE, or f.eval must be a valid model evaluation function") } else if (!missing (pc.ini) && !is.null (pc.ini)) ## go for pc.ini { k.ini = pc.ini$k lambda.ini <- rep (NA, k.ini) } else { pc.ini <- NULL lambda.ini <- NULL k.ini <- 0 } if (!missing (lambda.max)) lambda.max <- rep (lambda.max, len = k.max) p <- ncol (x) if (k.ini == p) stop ("all components have already been computed") if (k.ini + k.max > p) { warning (paste ("reducing k.max to", p - k.ini)) k.max <- p - k.ini } if (store.PCs) opt <- list () for (i in 1:k.max) { if (missing (lambda.max) || is.na (lambda.max[i])) max.fs <- .FSgetLambda (x = x, k = 1, pc.ini = pc.ini, f.pca = f.pca, scores = FALSE, trace = trace, ...) else max.fs <- lambda.max[i] lambda <- seq (0, max.fs, len = n.lambda) cur.pcs <- .sPCAgrid.ml (x = x, pc.ini = pc.ini, k = 1, scores = FALSE, cut.pc = FALSE, trace = trace, lambda = lambda, f.pca = f.pca, ...) cur.opt <- .SPCAgrid.opt (x, cur.pcs, f.eval, store.PCs, k = k.ini + i, ...) if (store.PCs) opt[[i]] <- cur.opt pc.ini <- cur.opt$pc[[1]] } pc.ini <- .cut.pc (pc.ini, k.ini + k.max) pc <- .orderPCs (pc.ini, k.max, k.ini, TRUE) if (!store.PCs) return (pc) ret <- list (pc = pc, pc.noord = pc.ini, x = x, k.ini = k.ini, opt = opt) class (ret) <- "sPCAgrid.opt.ind" return (ret) } .GFSL.calc.sPCA <- function (k.check, lambda = 1, f.pca = sPCAgrid, zero.tol = 1e-10, trace = 0, check.all = TRUE, ...) { if (trace >= 5) .flush.cat ("checking lambda: ", lambda, "\r\n", sep = "") if (check.all) return (f.pca (lambda = lambda, k = k.check, ...)$loadings[, 1:k.check]) return (f.pca (lambda = lambda, ...)$loadings[, k.check, drop = FALSE]) } .GFSL.is.sparse <- function (k.check, zero.tol = 1e-10, ...) { load <- .GFSL.calc.sPCA (k.check = k.check, zero.tol = zero.tol, ...) return ((sum (abs (load)> zero.tol) ) == ncol (load)) } .GFSL.is.same <- function (sparse.load, zero.tol = 1e-10, ...) { load <- .GFSL.calc.sPCA (zero.tol = zero.tol, ...) return (sum (abs (sparse.load - load)) <= zero.tol) } .GFSL.find.max <- function (lambda = 1, ...) { for (i in 1:16) { if (.GFSL.is.sparse (lambda = lambda, ...)) return (lambda) lambda = lambda * 2 } return (NULL) } .GFSL.find.range <- function (lbL , ubL, niter = 6, f.sparse = .GFSL.is.sparse, ...) { for (i in 1:niter) { mbL <- mean (c(ubL, lbL)) if (f.sparse (lambda = mbL, ...)) ubL <- mbL else lbL <- mbL } return (ubL) } .getFullSparseLambda.all <- function (uBound, ...) { if (missing (uBound)) uBound <- .GFSL.find.max (lambda = 1, check.all = TRUE, ...) if (is.null (uBound)) stop ("cannot find full sparse model") lBound <- ifelse (uBound > 1, uBound / 2, 0) .GFSL.find.range (lbL = lBound, ubL = uBound, f.sparse = .GFSL.is.sparse, ...) } .getFullSparseLambda.indiv <- function (niter = 15, ...) { uBound <- .GFSL.find.max (lambda = 1, check.all = FALSE, ...) if (!is.null (uBound)) { # return (.getFullSparseLambda.all (uBound = uBound, ...)) lBound <- ifelse (uBound > 1, uBound / 2, 0) return (.GFSL.find.range (lbL = lBound, ubL = uBound, f.sparse = .GFSL.is.sparse, check.all = FALSE, ...)) } lambda.max <- 1e6 load <- .GFSL.calc.sPCA (lambda = lambda.max, check.all = FALSE, ...) .GFSL.find.range (lbL = 0, ubL = lambda.max, niter = 25, f.sparse = .GFSL.is.same, sparse.load = load, check.all = FALSE, ...) } .FSgetLambda <- function (...) { ## find lambda which yields full sparseness ## Problem: if due to pc.ini the full sparse loadings matrix (vector) ## is not a 0-1 matrix (vector): ## In such a case full sparseness is achvieved, if a change of lambda ## wouldn't change the loadings matrix (vector) any more kc <- .FSgetK.check (...) if (.FSpossible (...)) .FSgetLambdaFS (..., k.check = kc) else .FSgetLambdaC (..., k.check = kc) } .FSgetK.check <- function (pc.ini = NULL, k.ini, k, ...) { if (is.null (pc.ini)) return (1:k) if (missing (k.ini)) k.ini <- pc.ini$k return (k.ini + 1 : k) } .FSpossible <- function (pc.ini = NULL, k.ini, k, zero.tol = 1e-16, ...) { if (is.null (pc.ini)) return (TRUE) if (missing (k.ini)) k.ini <- pc.ini$k l0 <- abs (pc.ini$loadings[, 1:k.ini, drop = FALSE]) > zero.tol ## return whether at least one row of lambda does only have zeros. return (any (rowSums (l0) == 0)) } .FSgetLambdaFS <-function (iter = 15, ...) { .FSiter (..., f.test = .FSisFullSparse) } .FSgetLambdaC <- function (zero.tol, ...) { pc0 <- .FScalc (..., lambda = 2^20)[[1]] .FSiter (..., pc0 = pc0, f.test = .FScompL) } .FSiter <- function (niter = 8, testL = testE^-2, testU = testE^5, testE = 16, ...) { L <- testL U <- testU for (i in 1:2) { lambda.test <- testE^seq (log (L) / log (testE), log (U) / log (testE), len = niter) sparse <- .FStest (..., lambda = lambda.test) if (sparse[1]) return (lambda.test[1]) if (!sparse[niter]) return (lambda.test[niter]) idx <- which (sparse)[1] L <- lambda.test[idx-1] U <- lambda.test[idx] } return (lambda.test[idx]) } .FStest <- function (..., f.test) { ## 2do. check, wether f.apply is specified. if not, do a binary search! PCs <- .FScalc (...) sapply (PCs, f.test, ...) } .FScompL <- function (pc, pc0, k.check, zero.tol = 1e-16, ...) { sum (abs (.loadSgnU (pc$load [, k.check, drop = FALSE]) - .loadSgnU (pc0$load [, k.check, drop = FALSE])) > sqrt (zero.tol)) == 0 } .FScalc <- function (...) { .sPCAgrid.ml (...) } .FSisFullSparse <- function (pc, k.check, zero.tol = 1e-16, ...) { n.k <- length(k.check) ## number of loadings vectors to check sum (abs (pc$load [, k.check]) > sqrt (zero.tol)) == n.k ## the number of non-zero loadings is equal to n.k } .loadSgnU <- function (x) { ## change the signs of the columns of a loadings matrix such, that each column's absolute maximum is positive idx.max <- apply (abs (x), 2, which.max) sgn <- sign (x[cbind (idx.max, 1:ncol (x))]) if (length (sgn) == 1) return (x * sgn) return (x %*% diag (sgn)) } pcaPP/R/data.Zou.R0000644000176200001440000000056512777012547013310 0ustar liggesusers data.Zou <- function (n = 250, p = c(4, 4, 2), ...) { ## generating testdata as Zou 2004 r.var <- c (290, 300, 1) V <- matrix (rnorm (n * 3), ncol = 3) %*% diag (sqrt (r.var)) V[,3] <- -0.3 * V[,1] + 0.925 * V[,2] + V[,3] dat <- matrix (c(rep (V[,1], p[1]), rep (V[,2], p[2]), rep (V[,3], p[3])), nrow = n) err <- rnorm (length (dat)) dat + err } pcaPP/R/pcaPP-internal.R0000644000176200001440000000417712777012547014443 0ustar liggesusers.centr <- function(X,m) t (t(X) - m) .mymean <- function (X) { if (any (!is.na (X))) mean (X[!is.na (X)], trim = 0.4) else 1 } #.scale <- function (X) #{ # med <- apply (X, 2, median) # dev <- abs (.centr (X, med)) # dev[dev == 0] <- NA # apply(dev, 2, .mymean) #} # .First.lib <- # function(lib,pkg) # { ## 2do: delete, using namespaces now; this function is useless. # library.dynam("pcaPP",pkg,lib) # library(mvtnorm) # cat("pcaPP 0.1-1 loaded\n") # } .ParseControlStructure = function (control, arguments) { if (!is.list(control)) stop ("Invalid argument type: control structure must be of type list") if (missing(arguments)) arguments = attributes(control)$names for (curname in arguments) { if (!is.null (control[[curname]])) ## if this argument is provided in the control structure: eval (parse (text = paste ("eval.parent (substitute(", curname, "<- control$", curname, "), n = 3)", sep = ""))) } } .ParseDevString = function (method) { if (method[1] == "mad") return (0) if (method[1] == "sd") return (1) if (method[1] == "Qn" | method[1] == "qn" ) return (2) return (1) } .Conv2Matrix <- function (x, sx = substitute (x)) { if(is.matrix(x)) return (x) if(is.data.frame(x)) return (data.matrix(x)) return (matrix(x, nrow = length(x), ncol = 1, dimnames = list(names(x), deparse(sx)))) } .colMedians <- function (x) { if (is.null (dim (x))) return (median (x)) apply (x, 2, median) } .GetFunctionName <- function (f, ...) { form <- formals (f) if (!is.null (form$fa.Name)) return (eval (form$fa.Name)) if (!is.null (form$NAME)) return (f (NAME = TRUE, ...)) if (!is.null (attributes (f)$NAME)) return (attributes (f)$NAME) return (NULL) } .flush.cat <- function (...) { cat (...) flush.console () } .colSds <- function (x) ## function for replacing sd until the R-people remove the sd matrix warning message { if (is.data.frame(x)) x <- as.matrix(x) if (!is.array (x) || length (dim (x)) != 2) stop ("'x' must be an array of two dimensions") apply (x, 2, sd) } pcaPP/R/cor.fk.R0000644000176200001440000000263713124442304012770 0ustar liggesusers #cor.fk <- function (x, y = NULL, cor = TRUE) #corissue cor.fk <- function (x, y = NULL) { cor = TRUE #corissue if (is.null (y)) { ## x is expected to be matrix or data frame if (!is.matrix (x) && ! is.data.frame (x)) stop ("x must be either numeric vector, matrix or data.frame.") { p <- ncol (x) dn <- colnames (x) ret <- diag (p) dimnames (ret) <- list (dn, dn) for (i in 1:p) { if (!cor) ## calculating the diagonal elements. if cor == TRUE the diagonal elements are all equal to 1 and hence don't need to be calculated # ret[i, i] <- cor.fk (x[, i], x[, i], cor = cor) ret[i, i] <- cor.fk (x[, i], x[, i]) #corissue if (i == p) return (ret) ord <- order (x[, i]) cur.x <- x[ord, i] for (j in (i+1):p) ret[i, j] <- ret[j, i] <- .cor.fk.2d (cur.x, x[ord,j], cor) } } } else { if (length (x) != length (y)) stop ("x and y must have same length.") ord <- order (x) return (.cor.fk.2d (x[ord], y[ord], cor)) } } .cor.fk.2d <- function (x, y, cor) { if (length (x) != length (y)) stop ("x and y must have same length.") ret <- .C (C_kendallNlogN, NAOK = FALSE, DUP = TRUE, ## 20130322 set DUP = TRUE - C_kendallNlogN implementation modifies x & y vectors!! as.double (x), as.double (y), as.integer (c (length (x), cor)), ret = double (1)) return (ret$ret) } pcaPP/R/l1median.R0000644000176200001440000001574113124442757013314 0ustar liggesusersl1median <- function (X, MaxStep = 200, ItTol = 10^-8, trace = 0, m.init = .colMedians (X)) { if (is.null (dim(X))) return (median (X)) l1median_NLM (X = X, maxit = MaxStep, tol = ItTol, trace = trace, m.init = m.init)$par } #l1median = function (X, MaxStep = 200, ItTol = 10^-8, trace = 0) #{ # if (trace >= 0) # warning ("This function (pcaPP::l1median)is outdated.\r\nFor better performance try any of pcaPP::l1median_* instead. Preferably pcaPP::l1median_NLM.\r\nOtherwise use (trace = -1) for suppressing this warning. ") # # if (class (X) != "matrix") # { # if (class (X) == "data.frame") # X = as.matrix(X) # else # X = matrix(X, ncol = 1) # } # # ret = .C ("l1median", PACKAGE="pcaPP", # as.double (X), # as.integer (nrow(X)), # as.integer (ncol(X)), # med = double (ncol(X)), # ret = integer(1), # as.integer (MaxStep), # as.double (ItTol) # ) # # if (ret$ret != 0) # return (ret$med) # stop("iteration failed") #} l1median_BFGS <- function (X, maxit = 200, tol = 10^-8, trace = 0, m.init = .colMedians (X), REPORT = 10, ...) { X <- .Conv2Matrix (X, substitute (X)) if (length (m.init) != ncol (X)) stop (paste ("length of vector m.init (=", length (m.init), ") does not match the number of columns of data object X (=", ncol (X),")", sep = "")) ret = .C (C_l1median_BFGS, NAOK = TRUE, par = as.integer (c(dim (X), maxit, trace, REPORT)), npar.out = integer (4), dpar = as.double (c(-Inf, tol)), dpar.out = double (1), as.double (X), #as.double (pscale), med = as.double (m.init)#double (ncol(X)) ) if (trace >= 1) cat ("l1median returned", ret$npa, ret$dpar, "\r\n") ; return (list (par = ret$med, value = ret$dpar.out[1], code = ret$npar.out [1], iterations = ret$npar.out [2], iterations_gr = ret$npar.out [3], time = ret$npar.out[4])) } l1median_CG <- function (X, maxit = 200, tol = 10^-8, trace = 0, m.init = .colMedians (X), ...)#, type = 1) { type = 1 X <- .Conv2Matrix (X, substitute (X)) if (length (m.init) != ncol (X)) stop (paste ("length of vector m.init (=", length (m.init), ") does not match the number of columns of data object X (=", ncol (X),")", sep = "")) if (type < 1 || type > 3) stop ("parameter type MUST be either 1, 2 or 3") ret = .C (C_l1median_CG, NAOK = TRUE, par = as.integer (c(dim (X), maxit, trace, type)), npar.out = integer (4), dpar = as.double (c(-Inf, tol)), dpar.out = double (1), as.double (X), #as.double (pscale), med = as.double (m.init)#double (ncol(X)) ) if (trace >= 1) cat ("l1median returned", ret$npa, ret$dpar, "\r\n") ; return (list (par = ret$med, value = ret$dpar.out[1], code = ret$npar.out [1], iterations = ret$npar.out [2], iterations_gr = ret$npar.out [3], time = ret$npar.out[4])) } l1median_HoCr <- function (X, maxit = 200, tol = 10^-8, zero.tol = 1e-15, trace = 0, m.init = .colMedians (X), ...) { X <- .Conv2Matrix (X, substitute (X)) if (length (m.init) != ncol (X)) stop (paste ("length of vector m.init (=", length (m.init), ") does not match the number of columns of data object X (=", ncol (X),")", sep = "")) ret.C = .C (C_l1median_HoCr, npar = as.integer (c(dim (X), maxit, trace)), npar.out = integer (4), as.double (c (tol, zero.tol)), as.double (X), med = as.double (m.init)) if (trace >= 1) { if (ret.C$npar.out[1] == 1) cat ("Algorithm did not converge (return code 1).\n") else if (ret.C$npar.out[1] == 2) cat ("Step halving failed (return code 2).\n") else if (ret.C$npar.out[1] == 3) cat ("A concentration of more than n/2 observations in one point has been detected (return code 3).\n") } return (list (par = ret.C$med, value = sum (sqrt (colSums ((t(X) - ret.C$med)^2))), code = ret.C$npar.out[1], iterations = ret.C$npar.out [2] + 1, time = ret.C$npar.out[3])) } l1median_NLM <- function (X, maxit = 200, tol = 10^-8, trace = 0, m.init = .colMedians (X), ...) { msg = 8 X <- .Conv2Matrix (X, substitute (X)) if (length (m.init) != ncol (X)) stop (paste ("length of vector m.init (=", length (m.init), ") does not match the number of columns of data object X (=", ncol (X),")", sep = "")) ret = .C (C_l1median_NLM, NAOK = TRUE, npar = as.integer (c(dim (X), maxit, 0, 0, 0, msg, trace)), dpar = as.double (c(tol, 0)), as.double (X), med = as.double (m.init) ) if (trace >= 1) cat ("l1median returned", ret$npa, ret$dpar, "\r\n") ; if (ret$npar[7]) stop (paste ("nlm optimization returned error code", ret$npar[7])) return (list (par = ret$med, value = ret$dpar[2], code = ret$npar[4], iterations = ret$npar [3], time = ret$npar[6])) } .l1median_NLM_Hess <- function (X, maxit = 200, tol = 10^-8, trace = 0, m.init = .colMedians (X), msg = 8, method = 1, GFlag = 1, HFlag = 1, Exp = 1, Digits = 6, ...) { X <- .Conv2Matrix (X, substitute (X)) if (length (m.init) != ncol (X)) stop (paste ("length of vector m.init (=", length (m.init), ") does not match the number of columns of data object X (=", ncol (X),")", sep = "")) ret = .C (C_l1median_NLM_Hess, NAOK = TRUE, npar = as.integer (c(dim (X), maxit, 0, method, 0, msg, trace, GFlag, HFlag, Exp, Digits)), dpar = as.double (c(tol, 0)), as.double (X), med = as.double (m.init) ) if (trace >= 1) cat ("l1median returned", ret$npa, ret$dpar, "\r\n") ; if (ret$npar[7]) stop (paste ("nlm optimization returned error code", ret$npar[7])) return (list (par = ret$med, value = ret$dpar[2], code = ret$npar[4], iterations = ret$npar [3], time = ret$npar[6])) } l1median_NM <- #function (X, maxit = 200, tol = 10^-8, trace = 0, m.init = .colMedians (X), alpha = 1, beta = 0.5, gamma = 2, ...) function (X, maxit = 200, tol = 10^-8, trace = 0, m.init = .colMedians (X), ...) { alpha = 1 beta = 0.5 gamma = 2 X <- .Conv2Matrix (X, substitute (X)) if (length (m.init) != ncol (X)) stop (paste ("length of vector m.init (=", length (m.init), ") does not match the number of columns of data object X (=", ncol (X),")", sep = "")) ret = .C (C_l1median_NM, NAOK = TRUE, npar = as.integer (c(dim (X), maxit, 0, 0, 0, 0, trace)), dpar = as.double (c(-Inf, tol, 0, alpha, beta, gamma)), as.double (X), #as.double (pscale), med = as.double (m.init)#double (ncol(X)) ) if (trace >= 1) cat ("l1median returned", ret$npa, ret$dpar, "\r\n") ; return (list (par = ret$med, value = ret$dpar[3], code = ret$npar[4], iterations = ret$npar [6], time = ret$npar[7])) } l1median_VaZh <- function (X, maxit = 200, tol = 10^-8, zero.tol = 1e-15, trace = 0, m.init = .colMedians (X), ...) { X <- .Conv2Matrix (X, substitute (X)) if (length (m.init) != ncol (X)) stop (paste ("length of vector m.init (=", length (m.init), ") does not match the number of columns of data object X (=", ncol (X),")", sep = "")) ret.C = .C (C_l1Median_VZ, npar = as.integer (c(dim (X), maxit, 0, trace)), nParOut = integer (3), as.double (c (tol, zero.tol)), as.double (X), med = as.double (m.init)) return (list (par = ret.C$med, value = sum (sqrt (colSums ((t(X) - ret.C$med)^2))), code = ret.C$nParOut[1], iterations = ret.C$nParOut [2], time = ret.C$nParOut[3])) } pcaPP/R/vignette.matlab.R0000644000176200001440000000106112777012547014677 0ustar liggesusers .getVtext <- function (idx) { stopifnot (length (idx) == 1) if (idx == 1) # the package name return ("pcaPP") if (idx == 2) # the package version return (installed.packages ()[.getVtext (1),"Version"]) if (idx == 3) # the matlab functions return (c ("l1median\\_HoCr", "l1median\\_VaZh", "PCAgrid", "PCAproj", "qn", "sPCAgrid")) if (idx == 4) # the example { fn <- system.file ("doc", "matlab.example.txt", package = .getVtext (1)) return (paste (readLines (fn), collapse = "\n")) } stop ("unkown idx value") } pcaPP/R/PCdiagplot.R0000644000176200001440000000512312777012547013644 0ustar liggesusers"PCdiagplot" <- function(x, PCobj, crit=c(0.975,0.99,0.999), ksel=NULL, plot=TRUE, plotbw=TRUE, raw=FALSE, colgrid="black", ...){ # # raw ... if raw==TRUE the raw SDist is computed, without using the median correction # # ksel ... select range for values of k # colgrid ... color of the grid if (is.null(PCobj$scores)) stop("No PC scores have been computed! Provide scores!") n <- nrow(PCobj$sco) k <- ncol(PCobj$loadings) if (is.null(ksel)) {ksel <- seq(1,k)} kl <- length(ksel) if (ksel[kl]>k) { ksel <- seq(1,k) warning("Not so many PCs available as specified -> set to number of available PCs!") } # initialize output matrices SDist <- matrix(NA,nrow=n,ncol=kl) ODist <- matrix(NA,nrow=n,ncol=kl) critOD <- matrix(NA,kl,length(crit)) critSD <- matrix(NA,kl,length(crit)) for (k in 1:kl){ # compute score distances: if (ksel[k]==1){ SDist[,k]=abs(PCobj$scores[,1])/PCobj$sdev[1] } else { SDist[,k]=sqrt(apply(t(t(PCobj$scores[,1:ksel[k]]^2)/PCobj$sdev[1:ksel[k]]^2),1,sum)) } if (!raw){ SDist[,k]=SDist[,k]*sqrt(qchisq(0.5,ksel[k]))/median(SDist[,k]) } # compute orthogonal distances: xc <- scale(x,center=PCobj$center,scale=PCobj$scale) ODist[,k]=sqrt(apply((xc-PCobj$scores[,1:ksel[k]]%*%t(PCobj$loadings[,1:ksel[k]]))^2,1,sum)) # compute critical values critSD[k,]=sqrt(qchisq(crit,ksel[k])) critOD[k,]=(median(ODist[,k]^(2/3))+mad(ODist[,k]^(2/3))*qnorm(crit))^(3/2) } # plot results: if (plot) { ## VT::10.10.2016 - remove a require(graphics) command ## ## require(graphics) if(plotbw) pg = rev(gray(seq(0,0.7,length=ncol(critSD)))) # gray level to plot else pg = rev(rainbow(ncol(critSD),start=0.9,end=0.1)) # color level to plot par(mfrow=c(1,2)) plot(0,0,xlim=c(1,n),ylim=c(min(ksel),max(ksel)),type="n",xlab="Index of the observation", ylab="Number of PCs", ...) title("Orthogonal distance") for (i in 1:n){ for (j in 1:length(ksel)){ howbig=sum(ODist[i,j]>critOD[j,]) if (howbig==0) { rect(i-0.5,ksel[j]-0.5,i+0.5,ksel[j]+0.5,border=colgrid) } else { rect(i-0.5,ksel[j]-0.5,i+0.5,ksel[j]+0.5,col=pg[howbig]) } } } plot(0,0,xlim=c(1,n),ylim=c(min(ksel),max(ksel)),type="n",xlab="Index of the observation", ylab="Number of PCs", ...) title("Score distance") for (i in 1:n){ for (j in 1:length(ksel)){ howbig=sum(SDist[i,j]>critSD[j,]) if (howbig==0) { rect(i-0.5,ksel[j]-0.5,i+0.5,ksel[j]+0.5,border=colgrid) } else { rect(i-0.5,ksel[j]-0.5,i+0.5,ksel[j]+0.5,col=pg[howbig]) } } } } list(ODist=ODist,SDist=SDist,critOD=critOD,critSD=critSD) } pcaPP/MD50000644000176200001440000001070614040447642011576 0ustar liggesusers11d5e523a4bc14031bf6c1b205b556a7 *ChangeLog 31de403090277c9ab851b1abd4c8f00a *DESCRIPTION d34fd6170be6273b828b421939288aed *NAMESPACE 33b74819d8e58393a5e7291b55eaaae9 *R/PCAgrid.R ad60d9aaf7a8e3e1651caeb94308b56f *R/PCAproj.R c4ceeafb84ef8ad3e2ed8ddb0dc6f0da *R/PCdiagplot.R f19604d5eebfda9a3490aca36a85279c *R/ScaleAdv.R 9914c368e2c44a858fc1453ee348ff6e *R/cor.fk.R bf8bed078f60f6f96e71cdd760b499a1 *R/covPC.R 7a2b51fcd735fd28d5d1bbd3903a9d01 *R/data.Zou.R 0f16444f6640b43eeb6a8b54102d6a04 *R/l1median.R de8b271aa6aea29b08fc2f95cd04d055 *R/opt.TPO.R 74a53ca213ddc068941018a7f26c2c5c *R/pcaPP-internal.R 1afc8741f217d90bcb8b1c9063de358e *R/plot.opt.TPO.R 26641019f10b72cec0b730d3eabc1b47 *R/plotcov.R a1a1a6bfcc1d119252512e6bc2b598ef *R/qn.R 53341a9a59d7ce972a77694cc9c3692c *R/sPCAgrid.obj.R da6e5bb651d4890cfed2c320d6863620 *R/sPCAgrid_R.R be57f0d8d50d109e203990c57553d0b2 *R/vignette.matlab.R 72c91e678012d05403d81be9b3b58c2e *build/vignette.rds 2e54398f33df481b15c5d7e6ccde8049 *inst/doc/matlab.R 574aa72943d76ee4ebfcfd7d702c20ef *inst/doc/matlab.pdf 75133c85758f26d5f9fc169861deb96c *inst/doc/matlab.rnw d6d549ddc4087f18768b4b728fca3b34 *man/PCAgrid.Rd 5d5aac20cf26fabf54e597ca66d87263 *man/PCAproj.Rd 9c3bf46eac5b32bb02f97bf4d416eb81 *man/PCdiagplot.Rd 5b3ba687c868ccc18b575e10c661e0f9 *man/Qn.Rd 35dcf333f7ebbb8fea62492d44401a4a *man/ScaleAdv.Rd a96f41a7d9d417aeb97550728e928ffe *man/cor.fk.Rd 193ab6afcb8aa26ab0034c824850c077 *man/covPC.Rd 2583a626dd02481809cc0ddc9c14bcee *man/covPCA.Rd 465863b60cf348f624267cfc44fa925c *man/data.Zou.Rd eee514e19caf50472021e742d57c9f12 *man/l1median.Rd 2848f30f7d72f7bbe1e2edbe30d18056 *man/l1median_NLM.Rd a0c50d86061249f9053a6e4a69c0fae1 *man/objplot.Rd 3f76f9825a35734d637abf8a066926c8 *man/opt.TPO.Rd 3718c7b284fc62b5c42efc87a47230d2 *man/plot.opt.TPO.Rd 57f4136e044461aa977a9ca2a5e91373 *man/plotcov.Rd d2269a51f3b82d40b4a98f85224f6bbb *src/L1Median.h 8c1dcf3de0b0ee7a1524ed48e7c7abd8 *src/L1Median_HoCr.cpp f67d656a430979062aaa24258d14c8eb *src/L1Median_VardiZhang.cpp ecd2a168df3dfeca85dccee4ef27399a *src/ML_meal.cpp a345008d7eb6f22c46fce474f0f5f4cc *src/ML_meal.h 5a8483fcd758b4fb2a7f9cb93bcd29e9 *src/ML_package.cpp ef72f6926440f161f4ae5d1f9ec72349 *src/ML_package.h 5190547fb04c808c41fed4bfaf34a7be *src/ML_passrng.cpp 33f5c7321b954c7b25874fc49fea65a4 *src/ML_passrng.h 4c0d792bef0f5df1a722caea26f4ded0 *src/Makevars 83ac5bece74b47c90a6bc09bbbc18bdf *src/PCAgrid.cpp 203750b33c1f918dfb0ac2d8fd33159e *src/PCAgrid.h ae70a374c98e90e3bc138fc2dd43a234 *src/PCAproj.cpp 5f517d32072969ea6e496a1624a4675e *src/PCAproj.h 55421a030d9e0cd85b3c41cc7ab0fed4 *src/R.Inc.h 809ddf5e64ece893d6d6394e5d2f4693 *src/R_meal.cpp ef84dfe2d938f779d7658b58fe940aa7 *src/R_meal.h 703214a4d2e7d23156a6e5054b291898 *src/R_meal_BLAS.cpp d070d10e3a11af082cf5c493e2ecff82 *src/R_package.cpp 654efe9ee03475f44ea31ed914fbf5ee *src/R_package.h d47d23eea4c8825db14365911f4a1dc0 *src/cov.kendall.cpp 7fb581db4e66072cfbec082025695d15 *src/cov.kendall.h c2082e97dbf33bd5c43bd313aced10e3 *src/defint64.h 5081b6f579daba74d374660b1445f549 *src/hess.cpp ef506c4becd2bd23e15d421303e63bc8 *src/l1median.cpp eb7beca41a2b26f28a995aef3be5d739 *src/outSDo.cpp 41578212ab83ff545c8dd1903b099f3d *src/outSDo.h 34304da3de5f95db56bcdd90fe9d556f *src/pcaPP.cpp da9be3ca652e21a39a8c1414de66359f *src/pcaPP.h bcc1bb053b7c3682ad34afe6939f5e29 *src/pcaPP_init.c 8ad5313fabf3b19d951888eeedc24455 *src/perftimer.h e78ff72e051dd9c5b050ebbcbf2990f0 *src/qnn.cpp 383842a520b736e834442a0d4d0def36 *src/qnn.h cd43b7f3dbb5a9ed92911f6a108c165c *src/smat.base.h af5cff60469d564e5db1e5d38e84abcc *src/smat.cpp f707f51fb21bdac052a9cc47a30e8099 *src/smat.def.h c2f1f4800e5c2bb239f13dd155f1eec8 *src/smat.elop.h be18645c82a502d4cdf0a26113a4b1d7 *src/smat.h 75ef01065bb651f9becf0754043e3932 *src/smat.math.h 81aabd3bda88afce83348d87a209217e *src/smat.matop.h 33cd9c94b77fb9428c92e2913b123d69 *src/smat.meal.h c55b0ed49a4544d35b4d6728becec3e2 *src/smat.mem.h f5f0c5980fc82dca801e1395b2e03458 *src/smat.misc.h b6139f03215ea9e97680293d4f2614fa *src/smat.random.h e7cc8752ee645ca9acd669986556fcbf *src/smat.sort.h 720f90ec2580a91fa5070970c83d430b *src/smat.stat.h d5c8e1a30c94e0032f9a4b5ada5bd3ff *src/smat_meal_passrng.h 52c8756a0535181b763022e84dc4f355 *src/smat_meal_passrng_hpp.h 759ddbeda153877c6a97d7c4caaf0674 *tests/tpcapp.R 399a685442d796811c6217095364cfe1 *tests/tpcapp.Rout.save ae969654e37fc177b4a27628b1486138 *vignettes/load.package.name.R 7b292ac6fd24a2eb975abf3633986ce8 *vignettes/matlab.example.txt 75133c85758f26d5f9fc169861deb96c *vignettes/matlab.rnw pcaPP/inst/0000755000176200001440000000000013300576522012235 5ustar liggesuserspcaPP/inst/doc/0000755000176200001440000000000013300576522013002 5ustar liggesuserspcaPP/inst/doc/matlab.pdf0000644000176200001440000027763412777012561014765 0ustar liggesusers%PDF-1.5 % 3 0 obj << /Length 1698 /Filter /FlateDecode >> stream xڝnFБB,\ mķhڢ+Rq[Lg;HWxM(ޚ^xʔiXTY^́Q88/xq 3{ip.KK)rʼ)sQ[@Z͑ZB;`,#-UܢD=]E~Gdc^$F[f @ɡr@ȾcYcB?,Vx9 )H[b Y)6$ '6Q4AEWlkx 9sKwT S洉+XV^__?r*oDQw ڋq٪oG 㢥vlG m?V5^> 6JS% M:V#S¢*B", C; نׁԱe *^F`nvsËz?-X"5 k2c5\)g&rg99եP4UiF<%I5}j6 \GgF,MMuF{^!R݈U W`jt^^ S?j(Er? J,^5Lw|VyKE P DDr:<3XߪKHwPn| A{ggϙԨ{BΧr \uQnHD j$<"6.W\wl*RH{o3K!~Tn5mP&gsSQ٨s}W;2KoľVh%?Ӈ C(rf]'yЈN]ंO\k07PG?b,7 Vz&/1%D٬O1 R/E2Yˌb翂 QW5H -3+2csĠI*RU,>5 W[IW GgBBMc$ GEh՚i*dPܸwrI< OԟIl0S>xy;O" {esAQSA[2I8VOh8߈R@5CuѼQO܌LK|QU6ȵ;!68qYg\lw1t|;4:u*yÓy> endobj 1 0 obj << /Font << /F38 4 0 R /F20 5 0 R /F45 6 0 R /F26 7 0 R /F57 8 0 R /F33 9 0 R >> /ProcSet [ /PDF /Text ] >> endobj 13 0 obj << /Length 1907 /Filter /FlateDecode >> stream xYK6WmDHJ9hP ^Pfڰu6"%zeghR$5|͐œ+OVfrf*[N-)r癆'_3h쯋&R.'.UY:s#W&Y1 3 ky rng"YVXn~HJiRRٺY6>-[: zlw  ,ZV?6IYf~ܑ8!QE]'8؇YfYJjVaK2tVkuZru3]ϻ&R}ns2#㞻A+YkZ #6ئyoµ \ikx33>n.,P&hs0\pb4{ ]V`.hSLPNMwmf۸&OX)@Ե* Y#d]tEXUdCǕÆ ٺ=Sb#v`[e㔫[sb)-N<زaص "Q}yjA4alP|JO黁$Wݯ̆ 禌 VgƎD"RD0.@  D7j}: P&I籲Fb LWizhcpq+**bN([.bd`Xoψ;4؆$f0iTɻ'5 %ϣ@iEֽ-"t0eBh4d8ibY"l$aI-<+.XN,,Ҏl/]\e="Z}V(ƪ]knk sÎu[m Bq.mv+cD{Fȓ7ݚ01ؘGUK^ &eE"+jUkY2"l wKuoAgwc#9|Gpn^{J\۔F^ʟdob|`1(ݍ HjN[2]F|1Qbp>qlg7Weyt"g*,]&NTQ}9TE^W!!N|_ RUmx %O+(q. >uף2'HIx#6wtt]I/-= ͥb֧puNdC x7tYc4kjNg Z"t4u?) 6J_Q-ߢ As^ YmTJn~OQ%C\ lHM3v ASLJ8ʪ:4|HePv|wC~ QEbKVyY.O;ժSx@CLA= 88D($Oc_;VE QկwOCO^^<@ endstream endobj 12 0 obj << /Type /Page /Contents 13 0 R /Resources 11 0 R /MediaBox [0 0 612 792] /Parent 10 0 R >> endobj 11 0 obj << /Font << /F60 14 0 R /F20 5 0 R /F45 6 0 R /F58 15 0 R /F57 8 0 R /F62 16 0 R >> /ProcSet [ /PDF /Text ] >> endobj 19 0 obj << /Length 1145 /Filter /FlateDecode >> stream xڭVo8 ~_آY,eol0`Xqm:N[wq#)ʖ;g֒(H~oΤJZ3[mfRgiPVهs)eoڙɬ`,zTC,UU)yr; }-Q ul-]$Z9ovJ.js Iu;]^eς>:CnΕ˾f8i1eBͥZ5hTYv\ïCHmeW MvW D`,I`Q-JB>:J{bMע i!L?p`[`#,wNxV 9ˁ#>B@4؟wxM *&7J(AĺYcFHLL ^q Ὁ:M=$'g_+˗=HBfϠ}Tb !~CEsАzE;[ŸI,Xj$8ׁ 4[%ll݁2ÔV ̏XQ䚳dPVbx`h Pu^H:/:([o!#b!j$,)@T! |tm(W̩7$>OM]j8)됂~JMi8g] H Ud䈮Nxs%ozhJ_2ڇDnz=_idõͩeCeM6Gh7&;s\h !8$ݘ]hOA(lwcԆ PNqܻߵI bT'ˆy #O݇}?n<,1>:'5$.~%K4ە/;A*W\,Ǯ)Hc1~rEhs"E)] ILOR1#=qh^u S^˼:O! <•A~ms\2%N֌7n qM?|#vG;^r7qcޣмK1FXń_?" endstream endobj 18 0 obj << /Type /Page /Contents 19 0 R /Resources 17 0 R /MediaBox [0 0 612 792] /Parent 10 0 R >> endobj 17 0 obj << /Font << /F45 6 0 R /F20 5 0 R /F57 8 0 R >> /ProcSet [ /PDF /Text ] >> endobj 20 0 obj [500 500 500 500 500 500 500 500 500 500 500 300 300 300 750 500 500 750 726.9 688.4 700 738.4 663.4 638.4 756.7 726.9 376.9 513.4 751.9 613.4 876.9 726.9 750 663.4 750 713.4 550 700 726.9 726.9 976.9 726.9 726.9 600 300 500 300 500 300 300 500 450 450 500 450 300 450 500 300 300 450 250 800 550 500 500 450 412.5 400 325 525 450 650] endobj 22 0 obj [514.5] endobj 23 0 obj [525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525] endobj 24 0 obj [777.8] endobj 25 0 obj [514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6] endobj 26 0 obj [489.5] endobj 27 0 obj [875 312.5 375 312.5 562.5 562.5 562.5 562.5 562.5 562.5 562.5 562.5 562.5 562.5 562.5 312.5 312.5 342.6 875 531.3 531.3 875 849.5 799.8 812.5 862.3 738.4 707.2 884.3 879.6 419 581 880.8 675.9 1067.1 879.6 844.9 768.5 844.9 839.1 625 782.4 864.6 849.5 1162 849.5 849.5 687.5 312.5 581 312.5 562.5 312.5 312.5 546.9 625 500 625 513.3 343.7 562.5 625 312.5 343.7 593.8 312.5 937.5 625 562.5 625 593.8 459.5 443.8 437.5 625] endobj 28 0 obj [544 544 816 816 272 299.2 489.6 489.6 489.6 489.6 489.6 734 435.2 489.6 707.2 761.6 489.6 883.8 992.6 761.6 272 272 489.6 816 489.6 816 761.6 272 380.8 380.8 489.6 761.6 272 326.4 272 489.6 489.6 489.6 489.6 489.6 489.6 489.6 489.6 489.6 489.6 489.6 272 272 272 761.6 462.4 462.4 761.6 734 693.4 707.2 747.8 666.2 639 768.3 734 353.2 503 761.2 611.8 897.2 734 761.6 666.2 761.6 720.6 544 707.2 734 734 1006 734 734 598.4 272 489.6 272 489.6 272 272 489.6 544 435.2 544 435.2 299.2 489.6 544 272 299.2 516.8 272 816 544 489.6 544 516.8 380.8 386.2 380.8 544 516.8 707.2 516.8 516.8 435.2] endobj 29 0 obj [667.6 706.6 628.2 602.1 726.3 693.3 327.6 471.5 719.4 576 850 693.3 719.8 628.2 719.8 680.5 510.9 667.6 693.3 693.3 954.5 693.3 693.3 563.1 249.6 458.6 249.6 458.6 249.6 249.6 458.6 510.9 406.4 510.9 406.4 275.8 458.6 510.9 249.6 275.8 484.7 249.6 772.1 510.9 458.6 510.9 484.7 354.1 359.4 354.1] endobj 30 0 obj << /Length1 1828 /Length2 11009 /Length3 0 /Length 12156 /Filter /FlateDecode >> stream xڍP\-;k{pww7hӸ5x` !@xdfUUW>볽׷P3ٙ Ll̬|qE16v++3++; 53; qG&t~ T\67++?v| @ g9P{8ZYX:W)=t-(-A/+u;S+tvcaqssc:19Z3ܬ-j '+ eWk( K+?vn@G2A^R\ f GuY=gŸ6w 45B< s+0,B~Nv/@Whu @JT|L읝{d]e%!fv o~V ӗ}`pm vn s+6\Y4!V. Yb^L(,@.VVVn^r7d='oK>^v6@>V栗?/'+ `S 2;@E~l߿ ^ff{kH0N11;w bww?aUZŎs;MqKt =WP{3@YXM_lCGWI V`"^2v/PmП-f6_3eBD!࿷Idbljs /V ?3yT^e{IIc(/cx mX!v/)|v(O"^|w A/y .߈ b~b/` _dbn/ s;%X rX,_hY 0 PP PrľrPB/ d{ao/7^rt.nvJxR?icZ_ǥ LQL;jDܘv&gwS陼;]~b &W \wM\ٖY&{:lm@ kKPm~4SiGYRp(Z?HL̤!` -GC%m@ڽ~xn5M%,UR#YdNb8, YK޽$P6es(@thX=+x(Ik 3rc {XZ<4Nk?l?y{0ohw!O$n$Y ~sw4)KJ%p͒<8K{x F4jFzv]_)4HxP`^ fcAc%xѬL4n' dWϫK<3P . hߴY\ߪM6L|@=03-: 1t RB-C;!'y|[{jD UPq䈢Q(ؑB)3nV2VePueH#C/mS[JtZ3J9}-1D/FN*ͷe]%&'y]H죇nTck\],K KL.E4̡|g*|;񍔣bf[ ?sGb;s4{[^+AJ@,]t.osг ;sY{W$D-T㌘A㉡j} x~nP3@o;AbmoV0(o IKsvCȪOd8<싴:qQ :nvy, ׼6T;%H"a;џjCtJ&fϰȧ(HV.y?yt/|J?0zBF 62u],¡ZJԒeNJ^OoF;kip-gÍ  fpHR7BIM;H $tDbN2!rhyTUM[xpeB&K5ܫ@K9f\-]i;JS6[fpuvJ I HU"|spgsFjd<J1;=5j H2Xd[ϲGM&[c+.&j=$֏oʲuubI6"u Va@acuC>9xȫ;-ތr9co )MW`pf76MIBjCJrnf1{ 4MōH R{@S kv''E7?$2*,^wm5I'e(E4J=K]e2+ټl1Aee{WdVΜZPs;ZPq UPVZQ.`4rk4txX߄E i}`9}1>/x/[G hJt$m1lTв/\DXU}F{n|ȫa9۟c?5w+22bp|\9a N1nW3X.u)4kyk|䒵z_ /Q}(K*H>O%u9Ubkì$бCĤ3SS򺰢?UXcT||yh \{ );t-afJuQl[l+{<27qx.z9IJ:qLVw Zs.<.vwiN.Tt#ZPZ7EPOm!֊IsY4[5ijMʆBK31#  p#NhDolzTRwXLMB7!po/syqpE(r1քFFsTdHS"}}a 8Kzb$m q()I]$cǟz-m߆]& D`\, 38Ԫnpb#ͧB^lZF !qH1^8xd #7&~R]+zq3;zSW$+Cb?4ȓ3:Wb]IBOCvt>zw嶜SyMup.p8CIF^͝VW0饻lciNp$VoI1g\(#`ڥF)]Tk Bb ym:7+55D紐"j/ -.hXN|]Tڻ1=^kLp )]}Rʙ,z04RXz`0y#-4|(D8lsۈsݪ#U8$dn bs?!XٕK ǾK{ԅD`6IA#Y/F*9pͺ|79]qqv>8URk|U,&w][5ߕ,6p&ɎwT$ y&л~Dq {;vDSԨ@[/+\mk@yF}v-l2K霡FXsOr*Q⿛S%Ur U4;>TJf8ƷJ9AcƟ;qPoAڬZT~~#1}bߋG-4j-]UhR //]XG9p33>),wEI #!zl.Ph?/1O6o{(ErG#R![ˬ.u? "LH؈esp L\;7¯jfݽO2!Q_yd~bx"?Nܹ1G-9| o :US?nn\lT@'irJ ؁|P 7+JՎ_RAɡ{"ɅW^4g |әQ.: COߓ D \hC{ڨ*7Q:.{fpcKRTaBS q]zNRc{fUjjUI%߈=؞ jǽFa Դ1>l54eɽ, +hPs*G4%gUu7&sd,_En胳Be9dO0\ܐ=4}bq3\NJK`:;1y| E\*1#{Qh~z TƳ@K.>ņۜ7vx Vbak,+v̈6O{w :}PC %4Nq,P4R!A,u$̜Tb Qf+N#Ҡz)ɻy{~j+$Uo^vî:D1J4uBkځ#,^v%ތr~Ma,t"aUд噢:gn"Ƃ$b¾~6R7u] ^TZ%A-4Q0d@Ks!"15-nKkc&ļh\osX9?LldB</۠|CMt+̿^iGUD^wLKbhýc &m74p^αbD+98x4"t٪u [ǁ%:ϛH@ӄEYn?Nx& l=vs1_\h. YpoDGJ6]`ZX!:Q"|P3Kѩ'ؘ pҼod5HHiիxԷ+O(*slsߴ?#nߎL(GxlT?w]ӳTHլd7M}6>.l9t-e ~"P,4i9C޸q-a\/rM~0u!TyI`=60w^teQHhFK ,r"m`)ZoO =Yd+eH"vH=]ܓP7Ho>F^C2iop;Kڝstkt.ϳ%]/ 2C\2 Y[1p$'KDoͼOY<)@3֓2v.+.ޙMe}=ZABirstΠf[䭹%sZ"ȏW]g9noQGіv] ȣFѓĬKGT"QTy7(F?#t=vǞC% ˋ4un޲3-"zBֹZğmhɺ9 K4O0dT޸J[}hO6N3I-\#k/g)pc*#~de'=#n <?f|ʐ)CF+WF+tvw.ӝg`Uô +25+8SjcF*hlNǯ@^h 8, )e11x,Q1h +s:43 ~O/ dIDRi5鰺5>if&ELFǢynj^B _Y/- Dx`܍[,")oL Y R ԥOѰu={`+u ţO7+w= y/`NO(~,7KUS&'r$4X#%2֐Y~kN>:PJ L /M;E3)dfUNJ=7{u0sf4A%g5c@#+rLf e 6gh EBӈifq$ z~si~dʭ5o>*x+?BAmѳؑDrݠR%Y9jv ExѾNiիP1>`~`I7 ~O)G/Gh06Şj҉5!f-3mwS܈siJf0U$\HKq\bHtb!R^> uZ=*ȭ-@4dAWTEVgN^B`^|>W蝳ɱNwkH[[fj˱O'{#TY0;|k\`,H1 M͎:>5M\*S bBF-?_R.ѕcSq\uq犢M&z X(T,Q> ˆnbnO.fws})ʃ8&-="DPIkzw9e6Ge$ [o I+%Y卡٧sFjsb uFXIB<'<ٍ w9kMH?0.Fl;|,y #[(<{bbřB Cu?wZcMhLTX%n +_&CKֻ\ ݴkL*o=bViqfؘAeyslnBa傣+oVE˦sZEճv4Ih;N{~f2_}Z( 쨩S-Ia }lIًY{eWS(M|G2gPOoG5d^BVOgnua ;é _8 .?$U)Dӆ%"wWD*e'U%8$zÆ`sy<*q8\P/3?]s:*an/)UG脍Uuڜ"^f5G>Z6uL?=] cYh<^[?7dp!;ơp7)]aNJD%N-B$ ]R$MEqbHT`@Ŏ&\A;v(A49wP{Qm`O^7V@V_"8܋u`|)M1U<ܲ9ml}>ft[u 4IjimLgAIW` ~SR&OdA7:p\Y鮔d,zW<0V)6V7~:ȮjĹ\pv5U&]GPp¢TgQXd  -jdu4/Q(z5߫ｸG`"|ٛp'gvo oh&c.Ss'@ )YC%T0k.KbxEbx/F2:A׶2d;;&DmXTSF|lNaR07~[xZw0} :ܛ.4f!ҧ!_Ei+TrF4< N+Ὲ_oj0`Ф M &1XD3MP7hU-&!-RuB[K58ti|Zkvkp#k^*@:N};:[>F{JTA);k0JFh-19\t:eQZw.TI?LL;ѶPN8x#%|D1Ue נi(5LRYF$v{&x 4dS |qE'eG o}N{8;\ksPH.eZE%Ԩi}ֺ=C"5\kL endstream endobj 31 0 obj << /Type /FontDescriptor /FontName /RKVHFX+CMBX12 /Flags 4 /FontBBox [-53 -251 1139 750] /Ascent 694 /CapHeight 686 /Descent -194 /ItalicAngle 0 /StemV 109 /XHeight 444 /CharSet (/C/I/M/P/R/S/U/a/b/c/d/e/five/four/g/h/i/l/m/n/o/one/p/plus/r/s/t/three/two/u) /FontFile 30 0 R >> endobj 32 0 obj << /Length1 2230 /Length2 15594 /Length3 0 /Length 16929 /Filter /FlateDecode >> stream xڌP[ 0ku ];w.p9畜{*ղzP(0%mmXyb,ff6FffVx Ufx u#ֆb@Cw{ @ `eef23'ց n23dmmbv 3s26p: mN@ƆV[c(͝x\]] mi 's24%`h 2Fx 9_v[S'WC `28g8ۘ*2rE;Ϳ@wo,,w_D m mA6fS()D01+=deh "-dK"_4]189u>qLYKS_"Ll@@̀Nfff.vt36g^/oO;[;7prpz{`2v@6@wg?龏IM^ANK_ux2X9X<.fWmU2lelLm<޻pTP{ch[A}?lob{ Ig+܆ +OV۾ k& gq2|3( r(5Bwz+ P׳|flAa \>\w;NVjX$eT!BhM7b里$nzl,ӿzV6ve"Ei&SC`+0^/"q8.[Z1(;J0bK1dDhɷÏ!q}U{Զ|OH"+Y0V1Tq\}hZ! >l$arXgU#+|OAZ"^T7GVfax]\*{2^$gChhr4vp k2k!fK1[0;Ov8FsA֌9].[:ohR lhℼzMэ1WvK;n/@Hh=stK+}b1+==q&{Mpm"؜fpWpxcLM%,,~Kvj2!ifdivY_}FEzI ڵ@HpC}0d$1>^S5j4m›'5 (P>s޺J@0)iYke}EW۾sι"o@SJ6bb,vP[w4efe>'o$r?ㄝZv!=m']IQCM%q˛ܪ\J/81g!ڇ$TZ[}N$ܓlkMUY}(K ="$l@ZkZˆ%#]12> "^g~lOr?oIA +1`XN| Mc7q 2wbe-tZZvėL%q忷'@>idE)Kay6rTMܭ!?MÏa/֢Qu/.爲-{.ۣv S6v哯2j[JiH3-#ɨJ /j/~'q_PjZ}^1:Kl;->,SlE~,[NIЋ I2xBOhZ#U_AJՀ R^yͳPpS90vCZ!ԡ_R^jw{ *88>-XA' !ܨj}vff./p%$k‹MOXga`S r ǕfLDGfJ&?̉ MhSf=F?+F3ĆW;A5 ZQK+Q8L0i%8bjT͟q׭\yipOQƩ[;V~Sr23haN: eMCAīH6G ש~IE3ϾLI3dAPxC :֠+&.MP$A+qr= Lv۲&!&ؖ$ǔ[=kYnY&gIU*c׷6Ԙp;> cġγ1n>~FZn)3\lţYTU=1>q`eޏ<9њ)t2ٽ:7Z&`_db?qiɉ'ޚȰY8Qp2QGdIf€6rAᆤ ֕:3ܲ,B|y=dHЀR _D’aub"x#*V0 >`q{J3QxE)!'d("6_ƯXكlb>(1|T)68svk[ɒ!YqFVȾ] LK .O+$&؀%o,:l +u`3"'=!uB[غgӡՓ~'/QwoƒTJmXqثǦ{kϮԭP|Yg]|Ġ<@8Jq-A$=Ft26aj Ey$Qbc{'e@21m|YJ[񪲠Aۦns k%`^JbK% HmжIXA8%3o)u5 LA>=^{,з6d8JIe&M(ZW-WX}wdS \M&l"3xfyS<ϥ_lp*6vg'w{%"lBQʨ٢~Sj^%tj !a1U61 [Lsz|Bx[qDU¹(`HU+PԙRD+:DXvX ,dm7{7 O5Ah`R@=M.֤E,&a=駖fz@]MG6@>5V3v?.L $^nS//T_^0 pZZna/\Ct\[#-"1,!j"NY]ށ΄"ܵ VyFMhx=j'4!چeb1 T%yPL0l f?S!k]:R0v7y}3~角C7-L?=Hc3$Oan˰94*zݦ}^B<H́m3*@XxF#>GnOXk1fNw3µ6,4!?ciαmŃ34gOwk qpw\qaM:p+#w.ƹ1 Ω?7)~AX8 4VVHN)Sp *4}P )pDS`:&m̃PO9HW[ ‹=Fk"V~}N)_<x*{" 7~Wϡ+.wNu3?Fg,1i%]D`HHé~Eȼi-ߍV:rb=],6 =c: 1~ы'I:JzƷI tAcV/L:`_}B W՞L e~zY}RP߷R"SeND\lRɮ+~Xm54hht!Z#(~@G=ZE]5g]osIoa% +S ̧#eQ3Wcn6Qh Yi5!c/xarε' \A$K| 6Ԫ}t(f)xbLE 2hi1*px*4k':xWmR{K<\HF6v>:J z g=~u7$$تE.)u"i#.Is]w4O\qI$xJUNlɉ-LӮV=)N10x4dN ;~|&M/Pp$Yg{P'ܽ|J }[R#33X_y4y6kp{:l'=N_JmF`Ӥ|te-!o-wDWQdd{N+Mk\մg 6 j=i/ؾӚuͩkTYX)w'~bS[G''ܥĩېޝaSY0\S$#69֭汷Vqhg#㗮n[ G. FʲJY|ќ,8S?&I/{ >I`*IZiC/C߯LFպhVigw|^×^a+mpXX]0TsGݚHk@E:3E&Bo8l*\udiq<␍5>RMhң @ o-;xƅܩ%k8(E^A,mJ0V'/~.xeUM1sx.OsȫAk H2>g_y+x %T}_lJ% $v3%,<8RqUC"-X7 afk:m=EvRܨ-+8.٬946tqsU3h wv?9:-,`B$+~}%٧!)Po[T8AB2E@ k]X`7chWyS)$+Z;2 mFP,)^W5뤯U>tZjQ}^OHiSg-zC ?!њ=d3`. E#,B8/Lkί>ߣʥLd464pP ˓5N[(6 ,b:ڤ| f7pFXB >xS?F Av"bCEU{*Eok?fSn\}Y`U&0NCgp]5TFÉK]cޓu~s>]Ծ93-8jO(IN>ߗX9|dcE!}HPN+FGP Ņ'Fm.WXRxꑮ}xvVmhzL \|Lz YPBı@/"걫ڴmQKpRiqh5G#Jz\ :v1QAb,U0n5qkų W~!8bϘ:K'V5I7uGFǶ]0 Q]wDunQҀTPsסP}TRZZ) ]ݬ=sFGv1Q( G–Y2^مjUfxG/C3g~-m;Z[#* ?>j5̅v2cwץ[|/8$sM8s[$5Bd` b_G9=WOTkH_i}mI!Z4ECSuiVGM}\OpD3r &`#ATG 33i6#:}XV!d ߭6KyIf=& =8ZɏaI|9{AMdݒi TSmh]/|Z?SΫ}hW?%S:7 3,thS<"^nKzR>`q@E-Z?_5u9]$4AAu{҄.$)̚G1l1FBHz& gnt%Hi X *9;NTm?0H3!WĂ7huԚɋz`yP.ia[!POU:PRQ 1\㏱,:5Ao@rz+S9"I:BV>WUk_p"B%{%\-I4N5.FQ/_cQ4/g?Aqĵ2ݼYOR,do=$մ2`,ੇ \*WB?;i~X/ eNs6ErKۥ!K/^?CGL}H(eT%P)Y{s4a:r!R؎Ox^zpϩ{t?0n6WL$o :3iC}ǎd_+pX>#Xv/~(y"UF!D-&Jz i^] KȗM죷 Ή- K-O. ѓ6T|񯤠Q]7{QRȡ4٦4M]3R[ u5+34j{GTqv  M=ANF[9f ~O!0h9d2$^;`gc3ȃܝW#U>oYNk’C+'}1-F-' hz-!fBҪFanT4aW$jvYhM]j.DZN5խ,([RbSvkP&VXtlt4@7L$@WÞ-HPƍ*^;S\ x1GT'h#&ߓ{%?ܜfoGdhN ^XzbxGq٦TVC_n8\\_vu}?RItt&*)HM^3h^L}mZC`2}^ɾk^;9`g*2z3MY3.H/VnTzj0'}%0Rb9iyuBKVI n%59LJvf"0̒j,2l^?#;/} ʄ% ɰS:,3u mcm4EX۪٦9(.tc%d|t32_cO')ǙQk7AnI_S?EzKX Čqiy eYG+|ϳ6/iOI:N5'509v"+H8TMQdCU]2 ]^(0ڞ˿mM\J'-  (.T:T0K?oqD"N\K]g1B іNxT|[O^l#hwߐx߁v)N! =h?f`hes>9OvKci>fxqyb: %7q̷hűϰp<< E:wu~5 YnQ;͒ΑA\;îvj`Yj,ggK~V6T*_RQ@~$9mNR4 JdpXw5bv'NjTg,\+;oWd`(bVU\}m(e"[$HLBQWNd0$Dg&(~APl C ^hO!~6D%/BT}JZ|Rij*g2oĵ3El9uH&{*by_3Rme'Wҷ'b lEPԏDW6^[k5oM,[(/핪4|kg伺Ԭ硥mhhe9 (tA*ñҨ!#/6`C[/sO˛!r$b5/md꿍gI{qPeSrQ^=u.5{Nia?/]^@^e oP</ $ylaU!AS%H\Ba~,}Qakva8'кh40 C lep<9m2Q^k'.a@t+L\S5'-H% H2Rks7 :(s//0QBxjc0{ґʇ(5H\bf{mʾ1wjHrd %!t~\'WIH"b)bo䖖~G~&ãb`ȯ돂`>'lP\mA=*$`Cw 9YTZ: IxǍ|VΈ>C ACD|[wSEh w*oScA]oZ(lgM8ѐ̮ e :ӘU"3@2tcTpR3(%<1#\% ک`ޓ1L`(MpTN#P&ܶvt 3gDtّb$:5QM7tL]\!^ǣGUS+/0BDkj&rqrOClCm*aсe:Da 'p+n*"wӭ}`C*M`@$PMdOraM|n4FbCϦJKy#%8rد7aGU-/-*axi`&vbMsĀ'"č|TGa=]+ {ǮY)e!Ɛ4UsyjP1;c>%mv{63'Tz\{͉ 3ec0>Y;ohv1@9$mId)+`^-#@pj+oĀ(s)b FrQr(&}# 3mQ8.H2 ZZARH᪵f4H4 N3Iky'pz?>'r'1Vmk{c,YdRr':;'5OoROHB}1v/kfNu(e7Ƨ,ԟNRz:Y6IbpȼCK^~s3>RL&n1Ֆ0bZ4{r 8Hr|| Z3)˰ l4ѥzԶkmKwG!oSAԉ ÒUFu I(`G0s`qw6 3Zf] kg]C%RNJEW2)^o? ԭ"WkmHz33eQȾN2}aN2$(o/5\G}ǾЏz!2(-'$u=;FSCu4 ɼ ?k5͍z?][HcO EES+SQSt7LR&e&\Fa~NU}hFȉ#Doq$#=a/`9dPDօyҌu3M|#ߦˡlD~½!AYT~X7Q 7:* -,/]SX`6Qy^qF mLrS䬔C+$suxsJggjυ/bH- !Lsm'MVб`D{hՂ"}z V9gHT-!H)6vܴ \m<xOM9M~9;_iq{/eh?gۗ?Ĺ^i|~Ä]ߤ/J՘%h/᲋-8Yy^MofXb SoQj9%ێ#uuhá )](X~b|r[26q$K!/5' Y6;0+X"҉g+5žۋ{&&svUshEn&pU=mf|:4CH_)S "j{R,){$a. / tÞHP(Q]Ez3ߣ=SDR.#.7Sq}A?6sbpҬN#.uSv}HӋ}yfSq6Cy.ôC $3'չkr#[㾥-B:IqNѺŽpS,RW#5U/Oo@&} NƄd+Eq ܽ/q٩W(ҕL9+pw!RHwI91,[ s3i3'-Ⱦ?6FQg8luaL~SE…&82inotjߠ}^J|<+b_(gHfc DB#4TeCCp0P÷ (a7dnEuʷnQoD}Z(,Aa0R_(?Qs@՗?fDV\'{̋l12tL#c}m9ږ_׃Ҙ΅="JR:SG|1"ziPѝC!o0n8[̉ DzJ{+U2%7WX˭,=G<<摄lF6Fs)w)>z'pVNvWY<4"?F0jucTCC쫻*RjkFNzuBI$N}-Dr[~jB9pӴn'c y9$E~שO{p@kɡ]o_7|%#\-_X'_""AҿI|irdKwrV3*{c}}ߜGSۊ@#ǻ%ob_­)Hl 9ZDSCAǕn`+mcA314^!;si(&x|HN:B1F,ĺS{_G9 endstream endobj 33 0 obj << /Type /FontDescriptor /FontName /UMNLZC+CMR12 /Flags 4 /FontBBox [-34 -251 988 750] /Ascent 694 /CapHeight 683 /Descent -194 /ItalicAngle 0 /StemV 65 /XHeight 431 /CharSet (/A/C/D/E/F/H/M/N/O/P/S/T/V/a/b/c/colon/comma/d/e/f/fi/five/fl/four/g/h/hyphen/i/k/l/m/n/o/one/p/parenleft/parenright/period/plus/q/quoteright/r/s/six/t/three/two/u/v/w/x/y/z/zero) /FontFile 32 0 R >> endobj 34 0 obj << /Length1 1604 /Length2 8697 /Length3 0 /Length 9736 /Filter /FlateDecode >> stream xڍTT.L )1tP13twttwtH )H\[5k9[{?~޽ %$ J< @ڃ4h]P$AfO6I3ק8%( f`g@ _Pg~; B@.4PG/g2-||<̿b gdjrxZ\S^ՑÃl- A. gw%af4Mv 3d[ .OnK3iq"@#Xf]_fPG3b ۃ*Ҋ3@3{S)bj'sp;QdURK k`gS۽8Y;'C,~tsdӂ@rn) UkΗb){/D|Z#Zߨޛ$O.|(> }F¢)W;K&ɍCŵGg@U˧Xb Jfh sf (\YHQq{b\\NM<'2q_x}3RMHMO@ 3:I#*?S.uA>0 uAx'v\Yr=1* 廷tD=JW0=V5hGlV 8,.Y#ɒL#ۯ:AԪEi¬כi7[~zC2t-]fD^ 2k#pDhO7B,pqqEc,2ƌF^w =B?]'E/S0:.t!ș\Ey5e֊@I !c/՗x兴G@ѻ4i:UFr7'c]<(&e pT>MQ0!`U 1򳜌_#q&ϽHuu#S{PVH`\ ۆÛfF3QaPm)bX$)me/lWZW輸j?}BA˟,axqymyDcˬ9tټԩЧGCWN-L?~)z`\JOT+qyXi?=R<8{aW2[:U0S 3YXl\5qU+uR%ي=C߄#( >ePc`N6PaD2\3=ZR˚!'ivH<}3,~vlPgךeCn̼;K{B*z,L:#M 6~צZE墯djƱ#Ɓ=Sd/7bx't?iPgs}qtI;b|e# ?ek wnu*}~Z}lަ}?2V8i_42 HEGdXT8_('!ZF2rB>R}+K:!!foꢾB]̌' m1|p-uy}t/fmci(PkؒLQ˓wR.Q]INڑ;kk6 ,͏)tE00]wtԶ-QG3:zj`Dh9Y ~x΅EE|Ϣ\q!u՜7DoM_ {7,>"1GQw{\w[Kӣ :EtZh>EXJ c I132-Y 3ihKKWәb|1`8wYwP [쩄u|Oҳʃ bALbEC`&ҚFl`J?JPZK ۇ 7l;yJ[e+lFd%n` (jWydۄi~{q?#rhn E1%v[3S39?( [̵7\1i/XK*(yyiS ;fO=<}_=a4'' ;(cB"[2ȧ"'oԁ~+CuXm?[E8KEljNЀ/ !mF Pa U_:2FZ:N ƘHoYwʹl̗[f+Q ^qP}# ^FN_4<h#t!Ueh^;=pX3VDEDH%A4dy:8>@GTYjL*o7M=9jvuP[/DrKG;q Y@oXლDD굟ٿ1((E*wEY7̺Xxh yێF6eȏC^6AbZ"*EpXIGۚ+2fL+&6q~$UBf|6o[]wC ;D\[!2-ɗTЉ/ƆǥQܻ*1 2H1#ݥ.FcyVФ#ݭ|Y\lE^6 UeaH0_G|FRwM._",n ee{%GIC pO{M4ƴa+85ND'"33p>Щ ͟(->@p4p d~6o^';$.r3>ѩoƹxe֑TZDjUc:mIľ8$[#R< ]OFѶ+G}a%'ze!1XlXswzBT) Ծ=7w^BkoTZ>Zo|ôCwc_]z!ңQD"dsݏ͞sI$ ueAR1 ҂J{hQS1h9/0TE\N < &p-Fـ@3l:ۻTD֕94ǾxϵMqG[̳X6 ~az#k0"6:Vcs11g5 Ajva>{$:r)~ 쮛6ly6M1&Wa/3xp]iGTۥA!`VKK\hBOM\䝎n  E sBӓ a­~ڧBuX%$XID48`ydJm36sn,6H%{xU" DϤ7yNJ=oG{AFmc8|Íb䊢XCQ[ -(J` i3Q5Ka"]9̓ΎEN܇ XQȊOtI_vw"p[Ԍۅ$Kr'GIFB{I犣_T>֝T#ރ,t klϚzzB4u^+<ҴIi%GǵBj@L fq%yKhq-F4]hA0w]k6=3 G%a 9wn#^{\)Ϝ9k`r@h^2Qs &YQ#0 ?d[_H7by3*L)yP'y Fe咞8G 7D&zDښgۮ)IШU ujXm!^OV`Pؗ]hL-h+FX޵<ܺLp]Ϸύͳ#`"pZ=' A_Y$n8)fL(H Z$ ȉNbB~,JL}ẗPaGT&Z3Kc(#kg$k~\!+pkV9)S vt"Zd%B|<1SX$y!Ҏc\~EX OIhu巾Ɣ*`OlbO(+܅8n%ژ=jtFimuM?dZxԓNJQ98pVS"SSHHZ+!);)>\VId^A7cʐhd\0KYĆԏ10V/FRB DHwsiHu EMQX/ۄ0,=D*ޠ2 2VZ^n+ _-L(:쿦1M&r;D6ˆp厤=KNpJ1CyDHO43:^YX!QkCSk;\C]*U{tE%>ki&Ci7 4Yd3;N۔cy)<(r%#VJ@"D8n{ {ɬ*: W7Ͳ8m8ǎ"K~KĻIfo]$Supiﳰ8h^SNCGQeAB3x_b47h)}r"9|6QF(BUqOS X7^Wezr6eApyt=]ӤBn ]#":QZNu79kWUq|zQGS%?4eeDAKTRDW&7z Uf'zRc#`-Ǫ¤)YEi.soJq֕BY\;3`=b1- *β$4wwgk.T iK$-Z_/nT^OwIT.0eoEoZGm-X"U*o Ve/S|@8xwiF;+Ӣ05 ݄4ZڀD.o", n >MC  OD . UK;>PHT ؑ#5x5 X .MnfaH*_f+pVaJBu{j =zO{^;4H) Jb’fq@N%w@'G) ZWO*Ӯ!^qr?6 X7;R N`hc|Ì9' VTJsm ҾİfEnM1{E?5)mPm*fJ@He;|)݇[>q,p(iExkY7ٖ)(&o)[ItpѨ J!,3>'ްlײd J>ߢ)2~|)vPV®|e#}LI`j)N }f.2 gi]ROƜ%hqƜq4`{r+'-u{CI] Y֌&2^zisv:+ -ۄԫ=cw5l7#\\Y~wcEqU Cqb);G&vu^1[Lł}DE2+pLa^ dzU ?"j[IhX Ue6XoZ\-,-/LOB˯jNRs2qQ!?U116,>YIcD4 CphR<8-8Z+~Ly^ 3Vag=ʯ;(Hƒk߈`P2X"nkftR;Ӱc{(; F)tή \z]h RqCH L]mm\!̈ﳓ Yy^y |NQ6mHQ]<ڗ|/g,0'p|sW=p(@kqD?>\kX6\@}G>b}#GZ&m>ۈ#;\M-BAW:h= hȣGC:W(` )w"e< @P]=a/2/H*#JiOLb8F]?g;Ox;;Ϥʍ֋k.%=\{;: 5YS~[My8kq(v ss\C!|OZ;VC᫏CIr?'вmafBfcOGvd'k[UJPp_f֯B-{JVWB-B >k9c/NR w#zyu4[ߢeS2?n޲{峱kЕ0jec wM2  #ĿF:T7"MГo)qY!?i@SA+OS7Bpז۽D8]);¦dg.v,=VdWƭ9Eo{^m_WMe? endstream endobj 35 0 obj << /Type /FontDescriptor /FontName /YSXVFD+CMR17 /Flags 4 /FontBBox [-33 -250 945 749] /Ascent 694 /CapHeight 683 /Descent -195 /ItalicAngle 0 /StemV 53 /XHeight 430 /CharSet (/C/M/P/a/b/c/f/g/i/l/m/n/o/p/r/t) /FontFile 34 0 R >> endobj 36 0 obj << /Length1 1976 /Length2 11331 /Length3 0 /Length 12550 /Filter /FlateDecode >> stream xڍuX.ZC\Z(N[)))(VP]p}ٻ~$yg53Z3+0Шi[B2PG;K pqppqqc00hA`= :`WQ ۤ@08UPpy@~a0KD0@ (s`W I ߯& fPHHq Pl {&yO600'b-l`W;[6@G@& r{h+T!+{{@?^;  h ؃2J0Ohw׃A{9W :BW ̕b[%0v:8a듂-;9B=}VGKR,ݜ8!n`yYpƿ6k0 %?X3ia;/'㍏ `~?0|\A` O" ` G``x@<\&~f 3K׿S^YQVK%$vn.;7(@leUA.VPTJnT#.>. yZ7?L]_ R? o`!QG3`K핇"h oxv!^!2OfaW8!`5+`P'~ɸ/>`Uj{ ո>@Z=r'#_+|`>Z~o_HA\NS$gAp 8ݿAHi,pi8@x[sU؃`Z ?iƆ^ͿE "6G=#9uώ`+ؿVL?f~.pmH…pA ? \ǿ~pzuz-\6_O Zօ_Ո{okztňG@BbWJΛw!NJmFY1,\:VNH)a(\$!GKa4S{^_i3JhA) vvUQɩ *UwgPSF6)e5K^ l>oasrRΑO76;؊rwي/甐_?o}N)9nU5v"3"\ N4#/9rAܗ1hH8oy6N#ɓۓ^Z45F_;Yh)"|qpՄ1{#=F1J(HRz` [NIz%:ϐRholOIx6XzPԹ8Dgu>U*EԷRMoJY8\4Ta[քn<|ּdN"II.=ҫPK|HЫ8eR nԍ%qr}PӋPTf 8A\јZqPɨ9p5M^خxV\~S$rh7p- 0qCO_zdŀehA;Ӊr,kc#uI:(I`_yEo Wa o{D͠2zGTw`BIΐɘzH| ffGۣsvle|h1t.8:DLY.}wAx^Wߠ"rJMr:x>FʠdžjpK=lb1)ݚYSn}ߑĈͺuN]Ky nn霚z1xU^fe2ݕ@l H^L[U8nG3! Y%OZRԧtFbx1`*Nóy>R/ km%h,dϐ̺[_hǍqPkvmŮʫ埮0ĪYSX_Q=kAq~u~NEI[O -o^K!e|gї#ޒikƿxy 2U._RuS'EDJB_w7~jð 5 pb&̝aQள& yTZ$ku,_C4\P3/j{IVmyriY Y&jYXS(ɗ-b2QiH[+J~ [!qTRcעP^hF{TtG%ڀA`pM86S/)@\#wH}ϝĹȌ3dwty,H~"!V&XF/9x>Jt\ 8r!HE2iʡp+Z. nC HV!G]s0inkN=il/ӬM(#/O;[_b4R,ЙNfT#UK~ȒkR6a?4ݞ˗lwb 1/=|gw׸f{DTiu-4MYׄӪg<-{W=B'EYEy|oeUs#B^E%N.HEd[*TE.W<>Ykd7kLG5hU$uڑgVEZ͡9X3:EHճbF4kD/|Y=χǺ+0J/+" {]NՍ'gUI2XrF:ŝҦIk.6+H֥ZqjB!D>,h574Ssak)Hyr, 4c3yy᧴K c Oei]J72K5/Dޕw7cEΙˋ^2q^9LΪY(0sɹx0ty2vJ"-^IgJFL8\mRXϕǷJsd1>^[jӟgf_ALk2Rz`ExIa @_%0ʖ(L޺`P2kpsE$M!j1/ͳQW&RSuLs]yR >/EQGch-(Y,&k⮾"bYLM_\*<,Y[ȇ7~ΕEorJXNyLN|s>emvUzVt6#3ަT"γ hKҙ`_U8i_Yr~ʧU!woZ]U<eN}j#x:LAPn.&ƻ!UqV?<{H>3쳤MyQ=`yzx[hGD,ʟ~~6Y~{R T*-6uiJyȽbk{R7?Tfc5],JWKϟ~C!C%Hݣ&m$̨rueff8#,Gj~u[qH|j' yC 7]zqiq@ Aos9%Y:o*H:mȑV7=yQ>#VIoGUyŪaz7Rrʨ)u rv#n˵өUf^ T`;RC ӇD39u;9`T {ҊJi@AI 8!"^}rC.Q]..N{QK,SWc#اsNi=5BP2CkwЭ)*JfQE#x@X_g& NjlzbnH@x+_8 ê!z(Q64*pڷ(kĽjiV d·*\,Ԋw{>DMsYO>9XLU dZECWQ0:A bEϨOLb0CIkvqME~x"ޣ@RlGc|*~BL c$)%)k %q<KZg-l@b1c)#5h(o\{ 1=EuY*hnR{QqW"r' B SrkW8IQu ?r!3F6 K WTf- =Gb٢ER(C(g߻xt$[gjxҒ29K\vOX31y"5sHW'q@.,ڜ蚄V-8Sџ Y87@ydB0r?֒]T>*#1WdU|ޛl!89͖V*"b5%" ͰE@QPcPgвK'J"+h!xAhM⒘M$C |n|NKO1ŭXsZ8I3(Ԏ%q`a ,oGjkJx|>'۪^E!S+U> >M Bcsl{%)tq/~$pW3qV)6~pbTb-唴Dlf?u6)&)X_Ɇ+K`B;ﭶ^^]ˈ(WՌofb:0١7,AJϪ)S޴UJUcvLbODx2}0s3,%Od1t6ǹp)mt8EH"vt\Zp:+0M{03żgdUh{,sJFwh<1>?,v.|<}3acUvr5J;SB:KF5'eּǪG/nw6-I^onak% }K1vj{.y]+;Z,_8Ш[[,f4>t~q.;\%sM HcVz$RkZr͙S6q /7:Xg* R KE ;}#7?"c&x ;!ocBF:E>hrjZוWT0p0-B|1`L/|+dj>#CnXY_s'LKDanɝQKe!Z(i~<(o&껱 &#닍ѵy1Kܼ*ߋMNVU -n yTN:?ܹaۀYQ-U?lyrdmbgkgrt2!n.̅ˣaV~9MEoqy%?oKNvO g(?xxݶb1OTZQ=E8LLQJ_Ӣ DJQ]2~-aVaxoku.%!Ҏs4O{(:YC'٠3w}C'i.}dZC>獟7h4[I$ۍȘ& /M`4Nx ̶&ZDzKwE=Q3 聏U.P=fu*ԈHrBѨ B 03\ՇQnpl34JOET7mAA 56<)^u#{i7m761+lqY)n3ю=/x1JǏ|/r|̣};]t[C do?mH ~g/Lx"FV+kZ囟TFĕi@Eer=j7d P/E&)3H4Ky2#%F|ko{τ93w w#Z1tL]ΗYTnTW@jኆJr~4ƥ'@*TUty/z)E-VBNΫ.zV4:(6S۬,QvX[hei3>ɅGDl%uɕkR׋G) VqElSEz y"֣_p`9XJ)KM:EijPE&gE9{8ء{`I{ &1ƳCjX8S8Q˻V_N6Z0??Sz@$3wU$Y/2%ox/ܴ"pΔ r5Y9ir+SrZzy,qa JjG+<nvg| &),_۵nll21m4K3NTzvʊ:%䢲,f?%_+RUçP@A}^\Ӗr[ZaJ!Ze!ʈdsP={O2835qw>%>EBm ڮB^ Yaն:@IYY?։\hAr?d8!?e'2 ɬ{an#$-%/tG :)ze, |Z;g6|-ATWqބ6OW-ά8EP@RTtE sanyOϴHZI=VRgCV^!3WvGU, f%h%DJ1sA7$O\e&oV6(IE< H0|3?j4%q>^rDz3 Dޫ9Cv띲q޼ zycJJ/LmA)|xA))q5Y׹-Qf\N (%Og'ϡCZnnAka"tn_)cҝt}@1eRg bcF|fn4b24bF/1vu#< gBtcYwaI>8n)]kE碝N(*k>,κ=#,/HQz8ˡJMyVF%(nVlpg P7%,{j6 DPW!6VLJgH_䉮b }Jb7ummLw^DɅs[JsC1HG!Ce"K*RGυI_q4V,Ҩ2suؽT5fC`[Ʀ4iNhT熬5iV"&J?G>jFx&avw{orмՇnϾVY}3="6G_t\k>Š,,h1XI7WgO6l{u M濳ZGٲrJђH%-n-Dz2J+߲d;r1ˊe>f{cpS#`:N!15O T2+,s[6`:{My((t( Ex\޻%Ǵ"V[= - jv$Qn /ܸ "}EP-eIlu6Ffc [K)V24ZJӒj'Q .*j 3}q-|`HV1 Td T../hEq}xYj5c3{K`iK: +ag(tn$J][w吐;6dG~\A ME#4D϶wM7ʌ3#r,gfCu~|sәzcQXP/Fh,ֺ4(OcSUx9ӵ+O4VM ;Ӭo,~&pgTɿOfsi hk'>{a\;53DګINV+>mTȽD3X)ĐB?\·;wG68Jk+S1sS#}U츪f9oRc[ORPNB B品p:ShT=׷:p:q4~t5w+  5B DOo3=q,֕( T1 T0j){UK޻T;[6YG\4 d62;p0"zڅ)p&UiKbXPAN|Tbj~+`PpVQw~(|#V(FS?JRhC*S_`պNJeO,L>,-FO; kf߫D퍹#k5FI5:ٰ^:dMO&”D=#67 3]N`l %—ؑk:%EpVZ~6n8]r3|Y '(‚bY|Oez7*5ǧ0/l{4lT(`?5 ]T+ޓ9 'h;2 :ЌD[GTϽ+@uk6^TU oUF'eH7o^#:X,5w/0?i\VR_h΄C3TuF߄%K%Ƃ=X ;N!B +(ln :1Kؔ )R̀U ^'=T7FνeqR^*y[DKal+Bg^0 7+DM35}P.%{c*VTW-/;7\2e =tjѤ\=0 hߠ%\_k{ 4 pِ8=foi3D*"IpY %O'{U)z.ea{b(&ejRd|#2m?gi$}+֥Rvڣ^Fi5$?M31(c0w}V-#Ny B,;xe&zMF1R$Mn_OW ʒztz'P4,7"< *TI(tco"qmk/>w>JV/Z3[glh:MOӘ'A"Lq +TNYZ"svH=/3ChMy540CS-'C$xnt/;hY_FT޸ReyL-/ȼp]`?-(nv=SS:$_6Rq2[IQ!K8O5'oق,o><73p}w@+8Dr<$v'*p";|;+pTj%TumǴYuRc?Q`;wְ-h2ޕvWh\8܎8 ,|ހ/$Z>pip=<[^vr9U 'q.r4K 5)[|b)HnDK˟lu⫟FǶ {etI!6cV *G"eے eNZNm)uTA :8 e!O |+}4֟7y!J'N! Bۄ7j+Nx~Gi KEP#g#'FPdϸ[,X?q9ʬu~\ w"vv65a6!v|#3NwV/ڻ*P` "ܸBf^4RB[r$0^Q*-ͫdSa 1 I>z/>@gZ#el>JcPf98whmwE2 diC<4C?1u(2څ)[[a]?J~AwM+MNKliLxGyGӞ= /-GkآyfldUgXu.YA@Ï&8*#_ >#5p:u$诼R˨'FymAʎ-@ZuӤlup˻an 43m^?r>m`6ESr$̈X4?xU endstream endobj 37 0 obj << /Type /FontDescriptor /FontName /IMKGTT+CMSLTT10 /Flags 4 /FontBBox [-20 -233 617 696] /Ascent 611 /CapHeight 611 /Descent -222 /ItalicAngle -9 /StemV 69 /XHeight 431 /CharSet (/C/M/P/S/a/asterisk/b/c/colon/d/e/exclam/f/g/greater/h/hyphen/i/k/l/m/n/o/p/parenleft/parenright/period/plus/r/s/slash/t/u/w/x/y) /FontFile 36 0 R >> endobj 38 0 obj << /Length1 1409 /Length2 6135 /Length3 0 /Length 7094 /Filter /FlateDecode >> stream xڍxT>R= !-  3 )%! J HK#Hw{}Ykw~9gf 3>="y|>>A>>ff0ێlraP@ȻlH- ԄAj _X_D '7.P4yj0(,sq;:!u~bb"\ w0 дE8\> !|&c 灹;Js'r~QhٺPa89a/[wi (m7/_.+ݟ_@ :@[IBm!p2 C~o$ E2t!1aa!~) tU یs8 i @{?? D@`(ο# |H~dT= 7wyu 4 U8PSN p ""B UgwQEyz ?cg-R ۿo'DwO)y@ l+Գ90@j k5A`"l3" uDꜛ1`dF@ր AF9z@G UaFP@H`n냃Tr%GΪ=kӧg5Ĕ$j y#ɃIjp9KDFb4ӅIZ}h JXo|ţhIv`cG<0껖~jNJˮL5Pb1 ZmOP\e' XIBD?ցй8/OjVHdġ(Su['%Lw)KɈO0& hdjaMӾ^R2E2M4=º=[%ڹ `Yw9ٔj!'ovLOEfW ˞Y;sxo"[eN ܰ~l &ao'kڎJKSbaeAưbHeSPhC[,Mpͯ$oY6jx*xH:.&Q"懎eU!Dc,ɡ g"HVx`%e/':^A_ZqOϼ&}dauv,R+hbD>^-=h!*4MPhxq+a-O=EI2AûnEOzVr՚0z%u#B"PUω5RݗH%x +a0NypD_prD1W[Um[VFl~WhM3>}3W=;kĴDV/2l*JU7VpK u.^EY4HV1-^gX4ZÓo& 5g,y&KԧKI,Kq lVvY0V~kJ&;'6_C?-c͕7H6K,#zcZQ嵐M\b: H3|?lZ>V> =5(8=|0n^cEY@ K%4"xW#KI3\L Nk)na"sK: e"d!ShzQnIdh6{X^3~8v2nd=W{~VD NO6 FgXȃ 8ʟZ~-c MRyUNlɋ1590$?&h;Zh*7R˴*#Pgb{֪ޭnj&(/ Ա丮#5f7T}o/#0Ԫ mMy_1q-M}Gۋs[k~ᖩ{hqKz;^7qY/*"TgBNjwehHiɮ\@}KR/̸<3!kX;J561ViuX bEO'R,%kV_Ғ nT@ : {Z;%xǘyocS9wj6[f(UADBI|W$(3V<0uSEP.7-NiF+ܣxMmOȭ)L{˹ZdVT5wHWݘm9A7|L6\'%TPP҅IAw.Uf= a⣝ n5w?|{#:],e ;.up;ciGaʤm|oDɯ!%gF/reϨ>/9_{;`sa^sξ۫Q85C j.::YLvbycEc9eG~)ŧYWH1ݡ)a:2LDqLwȭ#hxv&Я)-ߊ?g6&XAQ?o]H cx$<%6֯u4Tno/11ɨB><& h4Sٿl\TV~qXYE %P~MF49Xw7lBMIUa BՇ~GE ?$(qT}[6jl* K:tryXޭ;rU3OWO4q3$2+o/#d'JߟAa P+Γyݭ6_; E)^[W_bZgͰ~)n|نXtfJ~uKP I ^eDh{yFWkvʎ).4_%[%؞:[ASC6SUX63;۲X* _4 xYNfSsdR*pfD%v3J¬$38 qpY>TL]uz?*HԀwe{tzjM=oeEY5֎۵OL6z!eADZ.05 gkK~+s qgč)%H< 3KOƎ.5!NYSg0(^;[})B7}B"3bYkc}R؜+Zes&GnBXY~0מOr}_}gE> zh5dxD=if ,<(N2Q1;*O9 gb74PI D¤UGjx#.݃HO7; Ȼ v1R\Xމ:bR昶,a9%Q |_0R 75՗II=Hݩ&V}_Yk H_I<)F`_{܈/t^(I(uϪs9ż_9M.O!@>ڎԼ:3Ztg>MH.o_f=((OzTm=:CM4˘n۽J}'ף脇Zܺ(Jrm"f$Ր=jCzy ]#@Ld *1 x X%:f#f(\+Nf(Xk%6^B*ģVu6üz'bW'F&9>sP`pcv(ÏfG7b}9y8UꖜײZ*L.~+U•ryX#ktI-dޙ^؟JhÕZVr=c TLoA'|MXc`~Ű< 0*gR9ǭVbĜ"OQ.LH GͽOa$5n{}u216`˹30Ҕfuy~~8p_@a)EV}.Y!RLo͇5|V%\Y;Dk'O- k/o˽sZ)JP TjniǬǹvCoYէl܀ K?q/U2kcZ>D$-ܩt!`WE+VuR˹fEt/bRf@&NtjXrT/GI?lܭQcǔ q$is]#b8JqN+1UQwGŝܞͿ]#o2ԅ9R9{W7-n`^N+'xR }N~"QoWI }22ټI=3oeӻIqhKυeHv˼K˕pS]6/hze=/1|0eY9LJ*hwTtbt#@JT jm\k1E|З؏(5ۅK=نb*lw}ӟ~nɁ1Y}_ֶAT1X\ fNG]2tU'6' Qz~Oj0wn~my_ endstream endobj 39 0 obj << /Type /FontDescriptor /FontName /PDTLUH+CMSY10 /Flags 4 /FontBBox [-29 -960 1116 775] /Ascent 750 /CapHeight 683 /Descent -194 /ItalicAngle -14 /StemV 40 /XHeight 431 /CharSet (/greaterequal) /FontFile 38 0 R >> endobj 40 0 obj << /Length1 1610 /Length2 8645 /Length3 0 /Length 9701 /Filter /FlateDecode >> stream xڍT.w@p .=@VS;KZXR^-gs{WJg晙w .5qrrA| dbzqsmdzvC`P1\n6y G: Pqwxxŀ@(7*XԹ*0($svڹ=j# vXY@nv`NJV]_)X%ܜxx<==-0W[)6N']=րߒN࿤qc2A:ta6n`bCܡ`Wcu.H IV 9^n+w"` ++@ME5n7/7N7{8ZX>xu 6Q_Vg787[#4mVZP78:@aP߿ jm[3y4ac@({Y.Q3`(?`-<7Ww0yy+7%'l'~<W8~L'u((ir%?NYY_' 䯷Dؽx5 +h `g@/%#og~? /<=:qCK} sw,wDj8\@?" lqs>(X w= | v|d8 >;/q <&;ZE >&W]]o?f?.0 l9= kZ>:E@ᱩ"'qu_=%6}DWO t0]K#kF\&ޅmCmIu{>Fr>$XyQaw~i06 ?6RXLVKGc_AgһWg8!T;;8ΪY;Ri[BÀLk 7oXCNÂY-::jM;k7!"1Go/Bg-VU :J^x'֌d"|PCKj]oss+4ie]h|^\p>/~$>͊#*\*E#V0P-Nh7| #񯱳9dc] ֢*tG(Rg1+i>y!5]T+*zHb 'z4zj1Л'VTO]XG5'){Qy4UtvAȔ'c4e9K9^م'Iny~(on! ey)Fr" JۂW.V-wY4X҅DLaAprCχ_LQaWWW*d&o-kdоxPG> ͙zS\JkҔ Qus]O$BU~ҹ(V뉤n ; 1w^Y+~~kJ\cjpw*+>['iGAb:rT,KsԽ,2 eclއdvMTP@:ޗIwU5$|z=٫`W-E*Hxiޏ6\ܹY/7Hu ҔXTVlbq&ꬍX$ wTokClDO1  |Zb~߽WR_@4 <hp)*X-T։Eok| nj[8J+w!\MTX?d`ng=$5ut.$YZm"^0AxaIO%M({8 ~!¹ntgIh׫[JazLTXiU |nT>F۾`'odaeƎjDeâ.̧C QWÄDMvm9e;fGsڷ_IׁdJ߬hL?|ܒ=my]%RXܻ{y" Nnr'wfD/v'}_A)K#}%"Mdö* ؗ łW&<=P$#IW/~sFĤψ$V`"U;]!)@D7*C7i1I5leJe$hƷ݇_I0kEQP^ I}2LMQ:7m߁Fic]-kf 8ClwR?yuyYQ$:IOҹ?d(Iiݓ>68V?aLuUmKz<.:<ЊK:;R -c<۠ٛש\$Z1Tp`y?Z,>R$K /IIfTqC ,`lPTrxs86 a } 2@8/TBfVR$8Jp )7GÝe2ԕpql%b':Vm`B \4ЧC]ɛIg4z{7δg}X_}Px[,vvp@eJ-=Q[sq k{*Hjg$l . }MJ|Ya̶3w-೉َsD*(E;)Mr٧="W1ًxaK,nmF}٘B8%hx>=kW$;fGgm )N#nfD/UQD޽Hbq.i>}%Jsjp{6e) "{{tαku9(XL')8$bֽs/՞΋L{' jQ~fA g)lIR88UwzL2* Q|xv-xH uWf] 3y~!Wy;f/)C !FNoS)vU&08+V6lș@3',˖qkH@.O]{Z]fgaSr W)}oczWJ׾UckYoX`E2;? ` ?T0ÁZQ@5*+:%Րjij=^dZӾ2*B'u}n\ 76UgLk :{ ciPEe!LVS*= aԬqv7}B?Ĭy^~)sB,ZmNf=4-|wKi&% Z,\-*7K])5=]MEQMI[sg29 ߃y%DS@جz5Kq٣9BͽZ;)r B+rO)Dܞ|VI 2O,)$o=%@2Th8ioƞWS.6 )pDLY"(MY 3 G@/vwEjlBX=<&MwƩe9 DP'\Ȇ&m^y5^\nOIEJ:4")2' "=Q%ߎGuwcտ7|".@ e!Ud͔6(V$K%"T}ԁe)^7DUN\՝N:eV.XO,R9C>RƟyr]հ>UšB|jSٱmTѨLp^Pu8*HgCE'I(csޯ' 8NqCk)9 RZqq;$@OH^Pu8p=#}+C q]jA,.xޣM&~+tvM0اD`~aX_é 9M!Zyl__i"SrxRn+n .]DhJa^&fHy: "a8;=bM4sk#d.3G9$5`ʆmgSk[4`7[t%2?kҬKGƅT.=яMZ"֡@JJlsK̋;տeH*8c0b辖/p^4%fj1op_`̾><&+䙰eIw4 AҦ{T%]Y}1A 9|2~KȜբ5;Q4r%bNJF$4$7?d\{YtWG5 ._L_TpXٺ{Q8F_\7», ?:yɇT0 <[;h kBe,F9ݴ1 &inH4$"aW#(l;F|K4=S܊U m& g>;1x:1UN۾ϭVW\iHoGe: *O7wǭHT3 6.X7UU2:80%dǑc3Sawr>kH >0=gV}02٤6+.9 e"K`G*3+g3~,#*`c "m6yV2RK~EEذokn`ȁi3mV҇`|]D{]|o[}҂- =7(M"*W:/KL370?D~8w/_5C&$uCN`b`RNG-.F\uZ^S?6> Sͽ6EDxZ:{Q0RhnThl4QbI7#tNx_¥Jަ?d8l坠'ājX¾h7>*d<#iY#gk~yL7^hugEۋn~vN ? Ra5R3уaer{AfS~tݛMww'~<ְmֺۢ'B˴Zm2y8~r?wE]_wsTF,4"n'&hLi&2sTd^&סsf=]_qv9ǘoJF,7=21N͋dg: ԛ,$hS)D΋ ,hDY8HRЫyC^Y=ޙEFPCe3F;,ۼ3dԉW^ Hb"K0fP`hHVSS)`@mM{.&R|7@2V;]etuF~)Ț%vW =hdr=9GԸkC^[רc£>0Ӷjy9 cc%eA?sAQk?9%f-Ib>zM²&V;χI=U2 Rأ.e?&n5b#ӴB[+ K6_vX+e,gVvjANH'FbCa3T`!(^F7Ht}"v N,&rQbwFnG9ZC%ktK0⠕SWLY?Zamk!cկn躸cp{yNZ* d tkn8$>Fc:l80~?^A>n(%S BbNHzEGW9qs:o:]]f'W煘#& jtM*ITFV}ջ|xcqԶaImhP?_%Σ5{;Rg0B\qꜭHaj~}?q@,Usax0_TZDP1(aE wҷ ŒuCGYFj|wKH1;G^ 8 ԄϱQ'3yo9W!Eٵɾ20wc Ұ9{1ǾqLxh]4-q&#q1(]Z9RqMq)s* ;TA%4%&P1^Y[՝,6m\x%C/l˖\%mc8,4r'̫m}ɛ?2V/&+b`r0<%{WSu{!L0ږ1=^vy3/NSx[2 9d׬7_Le hҎ0)tlЦu9VhQlβ'u%~u/b R"UeZV=QAƻV)'}Dݭw!e&gY[Ĝ IX$*9斴,lMײy2IȚBILC"CA^9iܑ&S){&Do=*h`IǍjCQO[G)V"6e&UC'V-x}GJfa0.c/V"lJQ P;ȩ%W+vˎHqi:!?.6ZU34}d?ww j"ީ۳+m ?ޭэLҶwX[AI_2Jq r)JwW5[udcvEҴ|\4F1 ~,vk_毹г!UJ3a1b8k_a]Z/9Y՟?"tKCHv-k}{=.-GS"u?A'`H䙈L8A@! )sT" )ZZ+ьWpdRϠ ¯p"3(kEԫRsΎXr0ݷj ~F)%YTnLv1Q''uYEqa]cw.rZ4/`i'W4WYQe[!Vj\4/8|i3LoxYosy+p$Nu:" LU2;p?\鯽IcH1o6"Ea{ҁl*ҝC@yyh rP y58=TZTynnuO[8`LvTI06š~"S}ĉv% l{|cU֛ހ> endobj 42 0 obj << /Length1 1999 /Length2 6662 /Length3 0 /Length 7863 /Filter /FlateDecode >> stream xڍT7N TDJcKiiD@Ii))IA@AAxs\ʬ+C(w^~>8e`/@ |Wb5cܐh_ 8+Sc (@ oC "!#(B"aF@ ho #a t-hApglF[EݽC"{zzA{iNnp]8 A ub Hh;wO(`NH[8 ⁂16; hQkcj;/P[[ DvH'8@QP'74zt` ~t(/~nG06+` hgg8 >E$n7:О(A6D!]=jl"=@ {"?x*}].i|ݠw;  svȏ'K('??o< xa!0(TUO<5wҸk.8~- ' i" ~?O:[O=?=;BcY Cz8V9F"ݔ^psb=lt'$ vCo^~tؕu)nc7Ph؏@17/aa0|(;Џ#% ~A"X7(Bn`H kia3@ 1l c3آW#`_Tz`wAl + `o(%vAΈ!X.AlAlNA,?[XWLcG)T?jl!.؅AK ĒL*ݰxrܜn)X ?Gf]%l?P[ϟ$1z`0+ՂsxrT%ɻ8, Dr'fxAn`a܋7KdzJM@>eĊ_y_Bhg%oknKfwQ0+_`t3zNV,rEfC˓^0])2mz ޜͫR/ISq>~3lqwQ'%kC`[v'qMG=K ]iznx.uZ dfo~҆d`eK;d! _ZC0NVgy6SZO+{ 7J`yC^LG,f2~PRe\Hbj޻s 8߫zIKe讘J`;ܴn0m9s94E(A#Ă ˅׶Bb v s<&1Jǡ"_ruљKk:0/,)W6"Vgcʍ8:r}cU֚zS~dTQc;YWz:>@znE+ TV휦*ov뭕2IIEs 3/v@rQ8+#sR= mB”A;wNp Prs7DW{l7HSP`M<:xN"KyM}!+!0$K涺P6pCѸm<,@xV?)9XJDB zW>S&Qt;p"P("gR PB(/g^i:LuQ&YMnitGC-O?ay]^O\Ey{m_oTbIڲyGnW,.%*P>:Qqyh7˧^%& hX)[œy䐐"wr)m 1ι&]n3auM־̀7{>V4ss5Hq?"OVNt =Tp)fY:bgTهTf'WMSMbQtFlR}-hgz*K΁rsiHVAzݓy%MW; .pGv$(j4 43M%_Qge(ÕhPj'+e>LVʱZ+/Ҕ?0'@ڡ+jΗ57W7G9rOq 烺K.׊lr~7s6>UZ5h:k_ABT?իv#v!D櫱@ Xɥ/MKN8^, $ *Ph!z[pkQ: Ku{lՌn7՛;~_oMk_0ɹ&VM6!8PkG YWG{{M4 6 /H,K9HկPdw8\GdM!e+H~9Qܽ";# S,5~sήkܕ|R%(e!t\neX,w;Oߠb[ɣez?]uJtpvÌWқ69^YXJ+R0RШX6+Aް{>"< :3)aNMDE'Q)z}c EN;‹'#.+-rG% >d7ҟyE[Cq:ѝ>}Ыs=쉞tJҚ)L1O8+e-U(ھgT8 -Jk=)؟(]>[Gŝv/s)l>g F5K&d JA $)J<J}Q]xzx0"=IA#k#Rv]q 2Rgt癚T#Cr2r[(!,ϪeѤ ,ߠblӊ{ԛGX=5f&"ޒ0˯} sКSs^OZבGb+oZse jb8ҕu_W֯Wk$z5;ZޮkJn$9'zpUmJ EH29kze&&.yl<@ t i'|yreJ@cM8rjn=0EĵK1 3j/ɩ]SybA555ggHz@LGsDBH4""LM{ zlvMSӸ%<ʵ2QnYǡ Gܴ<-)(/yeEv֛%[%kgK&w=eXN.3Ob̜H 7jV1p_j4NB+!1}߬I~7td&C$ÅJ )@n `r7v35&]Mx.X*޽X{̣(̟c roJjkWsgxRMzWdbR:8ĭВ͡\>HAdh3퓡pN*XsX|[(i^iꦱg.F ,TbOl_”Q(FɺN=nu3>Miv+LϜ`"e>]kp^VMXVGC heUڟJg>%L}qh//ekxҦpsz!焉ΰ@mK9{yӖZr۾fܝ.9טZ˼d2dIHȌ~ʔWJkul'|"@{o͖8DUgriǺcKYN )_聗8>Ӵֶ"=DunC@:506ox4SReA:FN*SRUv3@>-h0)ŘR8cjsՔ.ƁDn !&/1 /!|]<~oT^c4ni6^{h~[RcsŰ-ܤMQ:F\}%Qj"¸Wڄ?]7>@yaR<b2q$4^'iX:G@-HLm—LN- w# |f6NtH4uv8&ueH#J3QV3cҬ=g TRGO_J zzz4x\E'/sĶ^[ץEq}aeS$״%oP"'F$ cVpI?}}R.C5C +֟~0Z]j#\K. ' Wfxs99EGof}~^@X])c$A8-K԰YIY'³Vej\W.)'+`{,du^BdruZV?sGi;#^}W)~Z)fy;b̈K[RU2Ex\zW#Թ͕ "-w> {OB}KchDۃΦkǷf;:g tbv,]ZM Z] x5]t)()k,E7|+;DD"! yMig?EbdR?ipTQu}мu}*5\#G|?Ṷy?=hz2i\VzUA!!1Kea3rǩD% X0lw+ Qlʫ'`> z_$ld(ejJqˤE'ut\vfNH0|ܜPQ61Hz~%upT}aܝ9 i~ W[LHSs4 KSIB3ˌi_XN#aA#f+z_chߤݐ`<:?(]Ttq{&ƛeF,ںU\vݜfZ 'k$d=.[d\o ,ud;g?D?CU3n.&?=:z7qБe9Y׆TD4}VGJ4{H+o3RΘ|qvk('ͦQ x$tl-eŢ1onyGc!WOFu{>Rk=p8^ORMDec$}gϸ,F=ZpXǍ_ï1Dgpw!Xεs^ƕ1 vjTz]TQR}D!3n\DWʤQ%)#MOP2*[ U|jʡ_\b/ ŷ$hDžkM_oj9&".d?@y+M5CHk 7D\;`g3Ƣ6qflPAz )sq[m8`e[O7凑RN!ݴ[ xAJ_ -n2Q<#0 y^7F\PYhr8GF)or𕈑*x}E҈-K9&&jtl;1ȭۄ|/e#G{8y׍5Zv+ڠҸ`cbح)[xXGA !J$;d{b\zLUԙ%9)t6 UWw>j&GNQtv3PͪY9Z8LF矎]3.=~$)uFۺ$Aa6c61&Icص0tGG0ap'GjsfıcAՑe/*:Xú _-3H6?roӝK.$Б8r(Ml,$˶KY>s06>Ir.r},TD,%ˆ;λ^Q?l\Ry!"e`nUsI5Ƅ+uNJYDZ?SN'r[ 5wƴr77SplsXZ Ei"FS0<ժ᳌+H<]/$a2 J,rzZ=eu%@ՠctgLjS3B]ILoBó>_&v NntvS~a@"~gi'<éa 9h}$XMaD@9^-AdP|0|3yV}AR_|cǼS*X[ՊBfv!sJeC2QQ}VFnǜx]",Yf˸]ZAgo/zԵDj4#xLnVRsPy#"JY;|,]/.h׮8RUk endstream endobj 43 0 obj << /Type /FontDescriptor /FontName /EISOSG+CMTT12 /Flags 4 /FontBBox [-1 -234 524 695] /Ascent 611 /CapHeight 611 /Descent -222 /ItalicAngle 0 /StemV 65 /XHeight 431 /CharSet (/A/C/H/N/P/R/V/Z/a/c/colon/d/e/equal/five/g/h/hyphen/i/j/k/l/m/n/nine/o/one/p/period/q/r/s/six/slash/t/u/underscore/w/z/zero) /FontFile 42 0 R >> endobj 44 0 obj << /Length1 721 /Length2 5243 /Length3 0 /Length 5832 /Filter /FlateDecode >> stream xmrPZ5P*P+ł-RBBHRJqw(NZ] ]9{vs^Da\<ym5^>?3# G!e0Q> Ёx^f neZNPB\ր...R.N\\M:0m X0UA]CMgnP[N0 @,PH(/MN\ @,Qv59: ' #Uv$I pk:?0ACUA\( H|SBZ9{@algB`A;a5h̑/Jh{V;`PM8jKsĽEa wvBQH>y?r@-e9 GZt^;BK]4=wn7<\__d,+ D?r-aH߆o"`n0 )XM|͇BoѢou٧x1 5!wZCTD#~Ej(`8}E.cwVeEo=J; uCt{MA䴝Re|q2m-D?A*MX'VKZfH^,Oce/3SYgٯbYytdWzg}.VbC}DJ/aUֲR+}ծP[yW6JQ G8[am0 ]VoIYk 6}|nz#M H} j]AtLKHd_,~Rɍ?&gf N,1 Gbtwk#kuCWKU*1Ohh.;/v~Fpl`JԤ0 rĀ8;.,W4 \vuŽ8}l0r|5U͗|>yΓ䫗Sj\]W(/hǁ@x* (bA,n ңJcoN:VWRش@$tl=m0e]󌭉Nt) o&ƴ|n!3i4m] |)xZBfF?aov1 PH?/B3<S^56яt.;.zl1 Y?6?NGYB4d&d"kXkH ]SFh6co)糈j&%[SPn2^h9>g&<

=7op܉(ʎT/( Qv l(y .Ewr9_gR.U2.#Ot7)sZC˩/A3S¯PԶL/!ư T/TƐ-r[!+ԇe6>o;VBM)ii]f2t;}"4ږզey)XΒ`l+ɷwNyů\6+7 q 5m}:鍷w\x(g͔u20F+ o} I3(XmDYbD&#CL=61`uN6?NA[mԺإD-W.]%#,n{@vݣfh:ҍI^ŝZ\E.Y;qAzCfDlK*_.T_|'YiW0<cdlTr- ;qP%Ó =dpfeK;J̩<|p7':BjUݶ^/I$G6L֤?XaH?O__rH1*1) Ny~Ў9Gr`nYʨ(~7og/q.0C1wIqW-:|cgdy X`}JE wfp``egtB@Jg'*DCԭTNGni7>y=}0tx3sL|tڝ7#ke0˽` .1`A8hAR$1o'=Z3dT)?0}rUc %sjõ>wV"-8<>jPY,V!}zj.>CbN /\c, I2&iO\-b @U:u+?>8W61YNECHC'VPrȖBgq_$cFeO14Q@TU0}0վO}~/sN5)zJ c-I6cx?ek+\Xy`<Ϥ>'q$Մ͙H֖ܡii(3?tOP!cƮBGUQ~?_DOAfkK+$YW7D6uwNr4qͽD4u2A]ijOvWm#@@{P/^ Ips74`!mdX0lөiqX[9m鋋=jVzC8:e(DO1k|1k sRh<4`4)7LhHdR/wR+uK6 Cc fk4äe֨$)R0arإs{m+A=Qrb{+V?%i5+p}ߟbF(2I /_kL,ڻ^L$L/'G`2&|ln=B=" 2?,M^qS4}߼gW8D Ty>t T{0J(@Sd̒4k}`d-?̉O3XPg{eh/ Sy-ǔT2!@SJ=1 WŬIx.ɾܩ'%77\Ej2i\->] o>haHL586uϋbo>4 SDH>%j-Y |uQ8'-HmwjlJIա\xp{ZDȟֳ:v?ZQś1ZͅWni|Rdj c6uQiy.COUwhan+JnYmPT5$VY.va;CJ~t쩢)Q:{O>XqkIkF6]^8UXy[s6!%l;._.6~^dc뱪Ϫ fF Ӂs1Q>QX03L8 u' 2Ɲ$YbݦZɖfgg v}5G]ߜ+IӼ蔿nm<`~e!i_Z <\m?_-[[\+kě5?:6xtvX0eƅ&eft*G~غd*#R /)xi`7ovmLsä.|ղ)C* endstream endobj 47 0 obj << /Type /FontDescriptor /FontName /VZFLZZ+SFST1200 /Flags 4 /FontBBox [-154 -360 1351 829] /Ascent 0 /CapHeight 0 /Descent 0 /ItalicAngle -9 /StemV 50 /XHeight 430 /CharSet (/quotesingle) /FontFile 46 0 R >> endobj 21 0 obj << /Type /Encoding /Differences [39/quotesingle 136/bullet] >> endobj 6 0 obj << /Type /Font /Subtype /Type1 /BaseFont /RKVHFX+CMBX12 /FontDescriptor 31 0 R /FirstChar 43 /LastChar 117 /Widths 27 0 R >> endobj 5 0 obj << /Type /Font /Subtype /Type1 /BaseFont /UMNLZC+CMR12 /FontDescriptor 33 0 R /FirstChar 12 /LastChar 122 /Widths 28 0 R >> endobj 4 0 obj << /Type /Font /Subtype /Type1 /BaseFont /YSXVFD+CMR17 /FontDescriptor 35 0 R /FirstChar 67 /LastChar 116 /Widths 29 0 R >> endobj 14 0 obj << /Type /Font /Subtype /Type1 /BaseFont /IMKGTT+CMSLTT10 /FontDescriptor 37 0 R /FirstChar 33 /LastChar 121 /Widths 23 0 R >> endobj 9 0 obj << /Type /Font /Subtype /Type1 /BaseFont /PDTLUH+CMSY10 /FontDescriptor 39 0 R /FirstChar 21 /LastChar 21 /Widths 24 0 R >> endobj 16 0 obj << /Type /Font /Subtype /Type1 /BaseFont /LZJEGO+CMTI12 /FontDescriptor 41 0 R /FirstChar 47 /LastChar 119 /Widths 20 0 R >> endobj 8 0 obj << /Type /Font /Subtype /Type1 /BaseFont /EISOSG+CMTT12 /FontDescriptor 43 0 R /FirstChar 45 /LastChar 122 /Widths 25 0 R >> endobj 7 0 obj << /Type /Font /Subtype /Type1 /BaseFont /TWWQBJ+SFRM1200 /FontDescriptor 45 0 R /FirstChar 136 /LastChar 136 /Widths 26 0 R /Encoding 21 0 R >> endobj 15 0 obj << /Type /Font /Subtype /Type1 /BaseFont /VZFLZZ+SFST1200 /FontDescriptor 47 0 R /FirstChar 39 /LastChar 39 /Widths 22 0 R /Encoding 21 0 R >> endobj 10 0 obj << /Type /Pages /Count 3 /Kids [2 0 R 12 0 R 18 0 R] >> endobj 48 0 obj << /Type /Catalog /Pages 10 0 R >> endobj 49 0 obj << /Producer (MiKTeX pdfTeX-1.40.14) /Creator (TeX) /CreationDate (D:20161010232553+02'00') /ModDate (D:20161010232553+02'00') /Trapped /False /PTEX.Fullbanner (This is MiKTeX-pdfTeX 2.9.4902 (1.40.14)) >> endobj xref 0 50 0000000000 65535 f 0000001897 00000 n 0000001792 00000 n 0000000015 00000 n 0000095681 00000 n 0000095542 00000 n 0000095402 00000 n 0000096383 00000 n 0000096243 00000 n 0000095963 00000 n 0000096702 00000 n 0000004115 00000 n 0000004007 00000 n 0000002020 00000 n 0000095820 00000 n 0000096543 00000 n 0000096102 00000 n 0000005575 00000 n 0000005467 00000 n 0000004242 00000 n 0000005666 00000 n 0000095323 00000 n 0000006018 00000 n 0000006042 00000 n 0000006416 00000 n 0000006440 00000 n 0000006926 00000 n 0000006950 00000 n 0000007388 00000 n 0000007993 00000 n 0000008307 00000 n 0000020583 00000 n 0000020877 00000 n 0000037926 00000 n 0000038318 00000 n 0000048173 00000 n 0000048419 00000 n 0000061089 00000 n 0000061435 00000 n 0000068648 00000 n 0000068879 00000 n 0000078699 00000 n 0000078955 00000 n 0000086937 00000 n 0000087275 00000 n 0000093225 00000 n 0000093444 00000 n 0000095098 00000 n 0000096774 00000 n 0000096825 00000 n trailer << /Size 50 /Root 48 0 R /Info 49 0 R /ID [<655EE74C92261CAFA9633452CEA8C034> <655EE74C92261CAFA9633452CEA8C034>] >> startxref 97047 %%EOF pcaPP/inst/doc/matlab.R0000644000176200001440000000335312777012561014376 0ustar liggesusers### R code from vignette source 'matlab.rnw' ################################################### ### code chunk number 1: matlab.rnw:9-28 ################################################### source ("load.package.name.R") library (package.name, character.only = TRUE) vt <- eval (parse (text = paste (package.name, ":::", ".getVtext", sep = ""))) cat (sep = "", # "%\\VignetteIndexEntry{Compiling ", vt (1), " for Matlab}\n", ## these lines cannot be created automatically - unfortunately.. # "%\\VignetteDepends{", vt (1), "}\n", # "%\\VignetteKeywords{Matlab}\n", # "%\\VignettePackage{", vt (1), "}\n", # "\n", "\n", "\\newcommand{\\dapck}{", vt (1), "}\n", "\\newcommand{\\daver}{", vt (2), "}\n", "\n", "\n" ) ################################################### ### code chunk number 2: matlab.rnw:94-96 ################################################### cat (sep = "", ">> cd ('C:/work/", vt(1), "/matlab')") ################################################### ### code chunk number 3: matlab.rnw:104-109 ################################################### cat (sep = "", "Compiling the ", vt(1), " package ... ok\n", "Copying the '", vt(1), ".mex*' file(s) to '../matlab' ... ok\n", "Changing the current directory back to '../matlab' ... ok\n\n", " Successfully compiled the ", vt(1), " package for Matlab!") ################################################### ### code chunk number 4: matlab.rnw:120-121 ################################################### cat (paste ("\\code{", vt(3), "}", sep = "", collapse = ", ")) ################################################### ### code chunk number 5: matlab.rnw:127-128 ################################################### cat (vt (4)) pcaPP/inst/doc/matlab.rnw0000644000176200001440000001240412777012561015000 0ustar liggesusers\documentclass[12pt]{article} \usepackage{Sweave} %\VignetteIndexEntry{Compiling pcaPP for Matlab} %\VignetteDepends{pcaPP} %\VignetteKeywords{Matlab} %\VignettePackage{pcaPP} <>= source ("load.package.name.R") library (package.name, character.only = TRUE) vt <- eval (parse (text = paste (package.name, ":::", ".getVtext", sep = ""))) cat (sep = "", # "%\\VignetteIndexEntry{Compiling ", vt (1), " for Matlab}\n", ## these lines cannot be created automatically - unfortunately.. # "%\\VignetteDepends{", vt (1), "}\n", # "%\\VignetteKeywords{Matlab}\n", # "%\\VignettePackage{", vt (1), "}\n", # "\n", "\n", "\\newcommand{\\dapck}{", vt (1), "}\n", "\\newcommand{\\daver}{", vt (2), "}\n", "\n", "\n" ) @ \newcommand{\sourcefile}{{\dapck}\_{\daver}.tar.gz} \newcommand{\proglang}[1]{\textbf{#1}} \newcommand{\code}[1]{\texttt{#1}} \newcommand{\link}[1]{\texttt{#1}} \newcommand{\path}[1]{{\it #1}} \title{Compiling {\dapck} for Matlab} \author{Heinrich Fritz} \begin{document} \maketitle \section{Introduction} The main functions of the \proglang{R}-package {\dapck} are implemented in an environ-mentindependent manner, which allows the user to use this package beyond the scope of \proglang{R}. The package has also been prepared to be compiled and used with \proglang{Matlab}, which is summarized and demonstrated in this document. The following items are required for using {\dapck} together with \proglang{Matlab}: \begin{itemize} \item The {\dapck} package sources \code{\sourcefile} \\(available at \link{http://CRAN.R-project.org/package=\dapck}). \item \proglang{Matlab} (version $\geq$ 2010a). \item A compatible \proglang{C++} compiler (for currently supported compilers see \link{http://www.mathworks.com/support/compilers/current\_release/}). \end{itemize} Section \ref{sec:instcomp} helps to set up a suitable compiler together with \proglang{Matlab}, whereas Section \ref{sec:comp} gives instructions on how to actually compile the package. Section \ref{sec:ex} demonstrates some examples on the usage of the package and Section \ref{sec:concl} concludes. \section{Setting up the Compiler} \label{sec:instcomp} Assuming that \proglang{Matlab} has already been set up properly on the target system, the first step is to set up a suitable \proglang{C++} compiler, such that \proglang{Matlab} recognizes it. A list of compatible compilers can be obtained by typing \begin{Scode} >> mex -setup n \end{Scode} into the \proglang{Matlab} console. Once a compiler from this list has been installed on the system, select it (by using the previous command) and make sure that \proglang{Matlab} locates it correctly. Note that after installing a compiler \proglang{Matlab} might have to be restarted for correctly recognizing it. Finally assure that the compiler has been set up properly by typing \begin{Scode} >> mex.getCompilerConfigurations ('C++') \end{Scode} \proglang{Matlab} should now correctly display the chosen compiler's details. A more extensive introduction to the mex-interface and its configuration can be found at \code{http://www.mathworks.de/support/tech-notes/1600/1605.html}. \section{Compiling {\dapck}} \label{sec:comp} Extract the downloaded package sources (\code{\sourcefile}) to a working directory, (e.g. \path{C:/work}), and set \proglang{Matlab}'s current directory to the \path{{\dapck}/matlab} subfolder: \begin{Scode} <>= cat (sep = "", ">> cd ('C:/work/", vt(1), "/matlab')") @ \end{Scode} Now the package is ready to be compiled by calling {\dapck}'s \code{setup} routine: \begin{Scode} >> setup Changing the current directory to '../src' ... ok <>= cat (sep = "", "Compiling the ", vt(1), " package ... ok\n", "Copying the '", vt(1), ".mex*' file(s) to '../matlab' ... ok\n", "Changing the current directory back to '../matlab' ... ok\n\n", " Successfully compiled the ", vt(1), " package for Matlab!") @ \end{Scode} Note that this \proglang{Matlab}-setup routine has been tested with Microsoft's Visual C++ 6.0 compiler. Other compilers supported by \proglang{Matlab} are very likely to work as well, but have not been tested in this context yet. \section{Using {\dapck}} \label{sec:ex} Once the preceding code has been executed successfully, the {\dapck} package can be used almost the same way as in \proglang{R}. The following functions are available in \proglang{Matlab}: <>= cat (paste ("\\code{", vt(3), "}", sep = "", collapse = ", ")) @ and work as described in the \proglang{R} man pages: \begin{Scode} <>= cat (vt (4)) @ \end{Scode} \section{Conclusions} \label{sec:concl} The configuration of a \proglang{C++} compiler in the context of \proglang{Matlab} has been discussed briefly, as well as how to compile the \proglang{R} package {\dapck} in this environment. Further some examples on how to use the package in \proglang{Matlab} were given. Due to the package's architecture the same \proglang{C++} sources can be used in both environments, which increases the availability of this software beyond the scope of the \proglang{R} community. \end{document}