BayesFM/0000755000176200001440000000000014632664630011552 5ustar liggesusersBayesFM/MD50000644000176200001440000000572614632664630012074 0ustar liggesusers068d5b46808e110d3a037853c6c04d9f *DESCRIPTION 6852746a8e06b05964bd45ccd0f9bef9 *NAMESPACE 285a6cd37591a8de19fde770e970e1fb *NEWS.md bb8d5b4f99a15ee558a37b384215baa6 *R/BayesFM-package.R 43077cbfb4f0db933c285b09be8c376e *R/befa.R 979ae6bed5cb873652c8f5abea20a14b *R/extract.data.R f3515b14893c11d7a32bfa99211d007b *R/plot.befa.R 8b5eb0490d266a020bbeba1add5cc13d *R/plot.simul.R.prior.R 27dcc5fd74c87343cb29ea5705b801f6 *R/plot.simul.nfac.prior.R 75aa5512d93ee0f69fce027d0e70aa6c *R/post.column.switch.R a345a58c0d025c50aa4cf0644b8f64b5 *R/post.sign.switch.R aef50a045f3cadea0fe0009efff2b08c *R/print.befa.R aa7cc2d51eb95cd31d2228517fda1ae7 *R/print.simul.R.prior.R ad8512cb3c5cc68d7ddf23c8b5d21882 *R/print.simul.nfac.prior.R bfe8182c1eda379fa522e4ad3ef67c1d *R/print.summary.befa.R 34815816a1aed68a3c289f8347cf16e4 *R/print.summary.simul.R.prior.R bcc431d95965680de638d110457f16a8 *R/print.summary.simul.nfac.prior.R e2ef6994118ca625b4a0f477ee4da09f *R/simul.R.prior.R 0d8ef7b4562f76bb79c9b17ccdb264d0 *R/simul.dedic.facmod.R 67a554dc66dbca34b367628f7a7c037a *R/simul.nfac.prior.R 0cd2e1e5c41057258f6352327b8d3e22 *R/summary.befa.R 3e88f4a1f497026c7e3c9c5de9744085 *R/summary.simul.R.prior.R a1a529b8315580036e2fe907bc3cc8a9 *R/summary.simul.nfac.prior.R 18d70df292f8657399497f2fb0c722ee *R/utils.R 72d789027c0ba099ce5d4f0b2c1bf0bf *R/zzz.R 7faeac5d7642d46068414336c72ca689 *README.md f61db891eb928123aba4412ca322f508 *build/partial.rdb eec286c9e172bb87dd6972c9962886d5 *configure 8999f0c2faf32f48bbec564a221f124d *configure.ac d41d8cd98f00b204e9800998ecf8427e *configure.win 8e89b635a63390707500ab6012f135ea *man/BayesFM.Rd 7ea03f6fc8d4fd8ec753008bccd37dfd *man/befa.Rd 7b06e0936c08d85efe8c985a1e641bea *man/plot.befa.Rd 3401500fc6770c280b360a66bf49dafb *man/post.column.switch.Rd dbf93cb5778b6e37ba4077144eedd9c4 *man/post.sign.switch.Rd 2bbd6208085bf73c5c270b88ca474d67 *man/simul.R.prior.Rd 2f705946c7b178474c5461a1cc0221af *man/simul.dedic.facmod.Rd b72e6e6d7d4eb3317c7923e4c41ace64 *man/simul.nfac.prior.Rd a00ad8f849a2f5f35615232b434f5304 *man/summary.befa.Rd 0ce4933d95625689ebd27c6417341966 *src/BayesFM-win.def 92656b615665e7abaf71930e364f13f0 *src/BayesFM.h d03adbd4d7d70c714507bdf178138414 *src/Makevars ac31a97dc10b1452d6590cc1220d67eb *src/befa.f90 614f4f63ce1eb11557796a13b1213bb5 *src/covariates.f90 895dce7973867c7124d05282a9543595 *src/covmat_block_invwishart.f90 e4cda5847b1870b54b20e6bedfcd11a4 *src/factor_normal.f90 4c2330da1c3b3090413d511fd01a514e *src/factor_normal_block.f90 463d8443a0daf93103385a55828d2fb8 *src/global.f90 78ab3f425d7a8ec1eb598c48521357da *src/indicators_dedic.f90 0b04a21d95821c44c0965adb7cee9216 *src/init.c 452601eb0b17cce4a4a36a816ce290b9 *src/loading_idioprec.f90 84797e49cccdf9db877d8607e9655b2f *src/matrix.f90 45f8ccd404ea6fa31498822746dedfde *src/mcmc_progress.f90 06c6ab839bc6fd83d8e72aab3d59f4a9 *src/mda.f90 6f7b2b5adcbe27d9447ad2230c441c6f *src/measurement.f90 5f429b8c7c0b408f86aa005a9d60b175 *src/probability.f90 167b2faa059337e0aca54333b034c3f8 *src/simul_nfac_prior.f90 BayesFM/configure.win0000644000176200001440000000000013742567211014236 0ustar liggesusersBayesFM/R/0000755000176200001440000000000014631161175011746 5ustar liggesusersBayesFM/R/BayesFM-package.R0000644000176200001440000000226714631161175014757 0ustar liggesusers#' BayesFM: Package for Bayesian Factor Modeling #' #' The long-term goal of this package is to provide a collection of procedures #' to perform Bayesian inference on a variety of factor models. #' #' @details Currently, this package includes: Bayesian Exploratory Factor #' Analysis (\code{befa}), as developed in Conti et al. (2014), an approach to #' dedicated factor analysis with stochastic search on the structure of the #' factor loading matrix. The number of latent factors, as well as the #' allocation of the observed variables to the factors, are not fixed a priori #' but determined during MCMC sampling. More approaches will be included in #' future releases of this package. #' #' @note You are very welcome to send me any comments or suggestions for #' improvements, and to share with me any problems you may encounter with the #' use of this package. #' #' @author Rémi Piatek \email{remi.piatek@@gmail.com} #' #' @references G. Conti, S. Frühwirth-Schnatter, J.J. Heckman, R. Piatek (2014): #' ``Bayesian Exploratory Factor Analysis'', \emph{Journal of Econometrics}, #' 183(1), pages 31-57, \doi{10.1016/j.jeconom.2014.06.008}. #' #' @docType package #' @name BayesFM "_PACKAGE" NULL BayesFM/R/post.column.switch.R0000644000176200001440000000603714142560501015651 0ustar liggesusers#' #' Perform column switchting on posterior MCMC sample #' #' This function reorders the columns of the factor loading matrix for each MCMC #' draw, as well as the rows and columns of the correlation matrix of the #' factors, to restore the identification of the model \emph{a posteriori} with #' respect to the column switching problem. #' #' @param mcmc #' Object of class '\code{befa}'. #' #' @details The reordering of the columns of the factor loading matrix is based #' on the top elements of the columns (i.e., the first row containing a nonzero #' factor loading in each nonzero column of \eqn{\alpha}, starting from the top #' of the matrix). At each MCMC iteration, the nonzero columns of \eqn{\alpha} #' are reordered such that the top elements appear in increasing order. #' The rows and columns of the correlation matrix \eqn{R} of the factors are #' switched accordingly. See section 4.3 of CFSHP (p.42) for more details. #' #' @return Same '\code{befa}' object as the one passed to the function, where #' the indicators in the matrix \code{dedic}, as well as the rows and columns of #' the correlation matrix of the factors saved in \code{draws}, have been #' switched appropriately to restore the identification of the factor model with #' respect to column switching. #' #' @author Rémi Piatek \email{remi.piatek@@gmail.com} #' #' @references #' G. Conti, S. Frühwirth-Schnatter, J.J. Heckman, #' R. Piatek (2014): ``Bayesian Exploratory Factor Analysis'', #' \emph{Journal of Econometrics}, 183(1), pages 31-57, #' \doi{10.1016/j.jeconom.2014.06.008}. #' #' @seealso \code{\link{post.sign.switch}} to restore identification a #' posteriori with respect to the sign switching problem. #' #' @examples #' set.seed(6) #' Y <- simul.dedic.facmod(N = 100, dedic = rep(1:3, each = 5)) #' mcmc <- befa(Y, Kmax = 5, iter = 1000) #' mcmc <- post.column.switch(mcmc) #' #' @export post.column.switch #' @import checkmate post.column.switch <- function(mcmc) { assertClass(mcmc, classes = "befa") if (attr(mcmc, "post.column.switch")) { warning("column switching already performed, nothing done.") return(mcmc) } # issue warning if M-H acceptance rate too low if (mean(mcmc$MHacc) < 0.2) { warning(paste("M-H acceptance rate of sampler is low (< 0.20).", "Check convergence and mixing!")) } Kmax <- attr(mcmc, "Kmax") nvar <- ncol(mcmc$dedic) iter <- nrow(mcmc$dedic) R.npar <- Kmax * (Kmax - 1)/2 # index matrix used to reconstruct matrix from lower triangular elements R.mat <- diag(Kmax) * (R.npar + 1) R.mat[lower.tri(R.mat)] <- 1:R.npar R.mat[upper.tri(R.mat)] <- t(R.mat)[upper.tri(R.mat)] v <- 1:Kmax for (i in 1:iter) { d <- mcmc$dedic[i, ] # relabel indicators mcmc$dedic[i, ] <- relabel.dedic(d) # reorder rows and columns of correlation matrix u <- unique(d[d != 0]) r <- c(u, v[!v %in% u]) R <- c(mcmc$R[i, ], 1) R <- matrix(R[R.mat], nrow = Kmax) R <- R[r, r] mcmc$R[i, ] <- R[lower.tri(R)] } attr(mcmc, "post.column.switch") <- TRUE return(mcmc) } BayesFM/R/simul.nfac.prior.R0000644000176200001440000001063214142560501015255 0ustar liggesusers#' #' Simulate prior distribution of number of latent factors #' #' This function produces a sample from the prior distribution of the number of #' latent factors. It depends on the prior parameters used for the distribution #' of the indicators, on the size of the model (number of manifest variables #' and maximum number of latent factors), and on the identification restriction #' (minimum number of manifest variables dedicated to each factor). #' #' @inheritParams befa #' @param nvar Number of manifest variables. #' @param Kmax Maximum number of latent factors. #' @param kappa Concentration parameter of the Dirichlet prior distribution on #' the indicators. #' @param nrep Number of Monte Carlo replications. #' #' @details This function simulates the prior distribution of the number of #' latent factors for models that fulfill the identification restriction #' restriction that at least \code{Nid} manifest variables (or no variables) are #' loading on each latent factor. Several (scalar) parameters \code{kappa} can #' be passed to the function to simulate the prior for different prior parameter #' values and compare the results. #' #' An accept/reject sampling scheme is used: a vector of probabilities is drawn #' from a Dirichlet distribution with concentration parameter \code{kappa}, and #' the \code{nvar} manifest variables are randomly allocated to the \code{Kmax} #' latent factors. If each latent factor has at least \code{Nid} dedicated #' variables or no variables at all, the identification requirement is fulfilled #' and the draw is accepted. The number of factors loaded by at least \code{Nid} #' manifest variables is returned as a draw from the prior distribution. #' #' Note that this function does not use the two-level prior distribution #' implemented in CFSHP, where manifest variables can be discarded from the #' model according to a given probability. Therefore, this function only help #' understand the prior distribution conditional on all the manifest variables #' being included into the model. #' #' @return A list of length equal to the number of parameters specified in #' \code{kappa} is returned, where each element of the list contains: #' \itemize{ #' \item \code{nfac}: Vector of integers of length equal to the number of #' accepted draws. #' \item \code{acc}: Acceptance rate of the accept/reject sampling scheme. #' } #' #' @author Rémi Piatek \email{remi.piatek@@gmail.com} #' #' @references G. Conti, S. Frühwirth-Schnatter, J.J. Heckman, R. Piatek (2014): #' ``Bayesian Exploratory Factor Analysis'', \emph{Journal of Econometrics}, #' 183(1), pages 31-57, \doi{10.1016/j.jeconom.2014.06.008}. #' #' @examples #' # replicate first row of table 2 in CFSHP (p.44) #' # note: use larger number of replications nrep to improve accuracy #' prior.nfac <- simul.nfac.prior(nvar = 15, Kmax = 5, kappa = c(.3, .7, 1), #' nrep = 10000) #' summary(prior.nfac) #' plot(prior.nfac) #' #' @export simul.nfac.prior #' @import checkmate #' @useDynLib BayesFM, .registration = TRUE, .fixes = "F_" simul.nfac.prior <- function(nvar, Kmax, Nid = 3, kappa = 1/Kmax, nrep = 10^6) { # sanity checks checkArgs <- makeAssertCollection() assertInt(nvar, lower = 1, add = checkArgs) assertInt(Kmax, lower = 1, upper = nvar, add = checkArgs) assertInt(Nid, lower = 1, upper = floor(nvar/Kmax), add = checkArgs) assertNumeric(kappa, lower = 10^-7, finite = TRUE, any.missing = FALSE, min.len = 1, unique = TRUE, add = checkArgs) assertCount(nrep, positive = TRUE, add = checkArgs) reportAssertions(checkArgs) out <- list() for (kap in kappa) { seed <- round(runif(1) * 10^9) sim <- .Fortran(F_simnfacprior, as.integer (nvar), as.integer (Kmax), as.integer (Nid), as.double (rep(kap, Kmax)), as.integer (nrep), as.integer (seed), nfac = integer(nrep), restrid = logical(nrep), PACKAGE = 'BayesFM') lab <- paste('kappa =', kap) out[[lab]] <- list(nfac = sim$nfac[sim$restrid], acc = sum(sim$restrid) / nrep) } attr(out, 'call') <- match.call() attr(out, 'nvar') <- nvar attr(out, 'Kmax') <- Kmax attr(out, 'Nid') <- Nid attr(out, 'kappa') <- kappa attr(out, 'nrep') <- nrep class(out) <- 'simul.nfac.prior' return(out) } BayesFM/R/summary.befa.R0000644000176200001440000003577714631161175014505 0ustar liggesusers#' #' Summarize 'befa' object #' #' Generic function summarizing the posterior results of a 'befa' object. #' Optional arguments can be specified to customize the summary. #' #' @param object #' Object of class 'befa'. #' @param ... #' The following extra arguments can be specified: #' \itemize{ #' \item \code{what}: How to summarize the posterior distribution? #' \itemize{ #' \item \code{what = 'maxp'} (default): Only factor loadings with #' highest posterior probability of being different from zero or #' discarded from the model (if \code{dedic = 0}) are #' summarized. #' \item \code{what = 'all'}: All factor loadings with corresponding #' posterior probability to be allocated to a given factor (or #' to be discarded from the model) larger than \code{min.prob} #' are summarized. #' \item \code{what = 'hppm'}: Highest posterior probability models #' with probability larger than \code{min.prob} are summarized. #' } #' \item \code{byfac}: Sort factor loadings by factors if \code{TRUE}, #' otherwise by manifest variables if \code{FALSE} (default). #' \item \code{hpd.prob}: Probability used to compute the highest posterior #' density intervals of the posterior distribution of the model #' parameters (default: 0.95). #' \item \code{min.prob}: If \code{what = 'all'}, only factor loadings with #' posterior probability of being dedicated to a given factor (or #' discarded from the model) larger than this value are displayed. #' If \code{what = 'hppm'}, only highest posterior probability models #' with probability larger than this value are displayed. (default: #' 0.20) #' } #' #' @details #' This function summarizes the posterior distribution of the parameters. #' The algorithm may visit different configurations of the indicator matrix #' \eqn{\Delta} during sampling, where the manifest variables are allocated to #' different latent factors. When the posterior distribution of the factor #' loadings is summarized separately for each manifest variable #' (\code{what = 'maxp'} or \code{what = 'all'}), the function provides the #' latent factor each manifest variable is allocated to (\code{dedic}), and the #' corresponding posterior probability (\code{prob}). If \code{dedic = 0}, then #' \code{prob} corresponds to the posterior probability that the manifest #' variable is discarded. Discarded variables are listed last if #' \code{byfac = TRUE}. Low probability cases can be discarded by setting #' \code{min.prob} appropriately (default is 0.20). #' #' Idiosyncratic variances, factor correlation matrix and regression #' coefficients (if any) are summarized across all MCMC iterations if #' \code{what = 'all'} or \code{what = 'maxp'}, and within each HPP model if #' \code{what = 'hppm'}. #' #' \strong{Highest posterior probability model.} #' The HPP model is the model with a given allocation of the measurements to the #' latent factors (i.e., a given indicator matrix \eqn{\Delta}) that is visited #' most often by the algorithm. #' #' When specifying \code{what = 'hppm'}, the function sorts the models according #' to the posterior frequencies of their indicator matrices in decreasing order. #' Therefore, the first model returned (labeled 'm1') corresponds to the HPP #' model. #' Low probability models can be discarded by setting \code{min.prob} #' appropriately(default is 0.20, implying that only models with a posterior #' probability larger than 0.20 are displayed). #' #' HPP models can only be found if identification with respect to column #' switching has been restored \emph{a posteriori}. An error message is returned #' if this is not the case. #' #' @return If called directly, the summary is formatted and displayed on the #' standard output. Otherwise if saved in an object, a list of the following #' elements is returned: #' \itemize{ #' \item \code{MHacc}: Metropolis-Hastings acceptance rate. #' \item \code{alpha}: Data frame (or list of data frames if #' \code{what = 'hppm'}) containing posterior summary statistics for the #' factor loadings. #' \item \code{sigma}: Data frame (or list of matrices if \code{what = 'hppm'}) #' containing posterior summary statistics for the idiosyncratic #' variances. #' \item \code{R}: Data frame (or list of data frames if \code{what = 'hppm'}) #' containing posterior summary statistics for the factor correlations. #' \item \code{beta}: Data frame (or list of data frames if #' \code{what = 'hppm'}) containing posterior summary statistics for the #' regression coefficients (if any). #' \item \code{nfac} (only if \code{what = 'maxp'} or \code{what = 'all'}): #' Table of posterior frequencies of numbers of factors. #' \item \code{hppm} (only if \code{what = 'hppm'}): List of the following #' elements summarizing the different HPP models, sorted in decreasing #' order of their posterior probabilities: #' \itemize{ #' \item \code{prob}: Vector of posterior probabilities. #' \item \code{nfac}: Vector of numbers of factors. #' \item \code{dedic}: Data frame of factor indicators. #' } #' } #' Data frames of posterior summary statistics include the means (\code{mean}), #' standard deviations (\code{sd}) and highest posterior density intervals #' (\code{hpd.lo} and \code{hpd.up}, for the probability specified in #' \code{hpd.prob}) of the corresponding parameters. #' #' For the factor loadings, the matrix may also include a column labeled #' '\code{dedic}' indicating to which factors the corresponding manifest #' variables are dedicated (a zero value means that the manifest variable does #' not load on any factor), as well as a column labeled '\code{prob}' showing #' the corresponding posterior probabilities that the manifest variables load on #' these factors. #' #' Summary results are returned as lists of data frames for HPP models, where #' the elements of the list are labeled as '\code{m1}, '\code{m2}', etc. #' #' @author Rémi Piatek \email{remi.piatek@@gmail.com} #' #' @seealso \code{\link{plot.befa}} to plot posterior results. #' #' @examples #' set.seed(6) #' #' # generate fake data with 15 manifest variables and 3 factors #' Y <- simul.dedic.facmod(N = 100, dedic = rep(1:3, each = 5)) #' #' # run MCMC sampler and post process output #' # notice: 1000 MCMC iterations for illustration purposes only, #' # increase this number to obtain reliable posterior results! #' mcmc <- befa(Y, Kmax = 5, iter = 1000) #' mcmc <- post.column.switch(mcmc) #' mcmc <- post.sign.switch(mcmc) #' #' # summarize posterior results #' summary(mcmc) #' #' # summarize highest posterior probability (HPP) model #' hppm.sum <- summary(mcmc, what = 'hppm') #' #' # print summary with 6-digit precision #' print(hppm.sum, digits = 6) #' #' # extract posterior means of the factor loadings in HPP model #' alpha.mean <- hppm.sum$alpha$m1$mean #' print(alpha.mean) #' #' @examples \dontshow{ #' summary(mcmc, what = 'maxp', byfac = TRUE) #' summary(mcmc, what = 'all') #' summary(mcmc, what = 'all', byfac = TRUE) #' summary(mcmc, what = 'all', min.prob = 0) #' summary(mcmc, what = 'all', min.prob = 0, byfac = TRUE) #' summary(mcmc, what = 'hppm', byfac = TRUE) #' summary(mcmc, what = 'hppm', min.prob = 0) #' summary(mcmc, what = 'hppm', min.prob = 0, byfac = TRUE) #' } #' #' @export #' @import checkmate #' @importFrom stats sd #' @importFrom coda as.mcmc HPDinterval #' @importFrom plyr count summary.befa <- function(object, ...) { if (!inherits(object, 'befa')) stop('object passed to print.befa should be of class befa') # extra arguments args <- list(...) min.prob <- ifelse (is.null(args$min.prob), .20, args$min.prob) hpd.prob <- ifelse (is.null(args$hpd.prob), .95, args$hpd.prob) byfac <- ifelse (is.null(args$byfac), FALSE, args$byfac) assertNumber(min.prob, lower = 0, upper = 1) assertNumber(hpd.prob, lower = 0, upper = 1) assertFlag(byfac) what <- match.arg(args$what, choices = c('maxp', 'all', 'hppm')) # container for summary object output <- list() ### column-switching and/or sign-switching problems if (!attr(object, "post.column.switch")) { warning("MCMC output not processed by function 'post.column.switch'. ", "Posterior results for factor loadings and factor correlations ", "may not be interpretable! Make sure column-switching problem has ", "been fixed before summarizing.\n", immediate. = TRUE) if (what == 'hppm') stop("Highest posterior probability model (hppm) can only be searched ", " for if columns have be reordered a posteriori. Use function ", "'post.column.switch' first.\n") } if (!attr(object, "post.sign.switch")) { warning("MCMC output not processed by function 'post.sign.switch'. ", "Posterior results for factor loadings and factor correlations ", "may not be interpretable! Make sure sign-switching problem has ", "been fixed before summarizing.\n", immediate. = TRUE) } ### Metropolis-Hastings acceptance rate output$MHacc <- mean(object$MHacc) if (output$MHacc < .2) warning('Metropolis-Hastings acceptance rate is low (< 0.20). ', 'Check convergence and mixing before summarizing.', immediate. = TRUE) ### function summarizing draws from posterior iter <- attr(object, 'iter') summarize.mcmc <- function(z, prob = FALSE) { if (length(z) == 1) { sd <- 0 hpd <- c(NA, NA) } else { sd <- sd(z) hpd <- coda::HPDinterval(coda::as.mcmc(z), prob = hpd.prob) } res <- c(mean = mean(z), sd = sd, hpd.lo = hpd[1], hpd.up = hpd[2]) if (prob) res <- c(prob = length(z)/iter, res) return(res) } ### function sorting manifest variables according to the factors they load on ### (variables loading on no factors are listed last) sort.byfac <- function(a) { a[a[, 'dedic'] == 0, 'dedic'] <- NA # make 0 -> NA a <- a[order(a[, 'dedic'], na.last = TRUE), ] # sort, putting NAs last a[is.na(a[, 'dedic']), 'dedic'] <- 0 # make NA -> 0 return(a) } ### highest posterior probability models if (what == 'hppm') { alpha <- object$alpha dedic <- object$dedic dedic.tab <- plyr::count(as.data.frame(dedic)) dedic.tab <- dedic.tab[order(dedic.tab$freq, decreasing = TRUE),] if (dedic.tab$freq[1] < iter*min.prob) stop('Probability of HPP model lower than min.prob. ', 'Try to decrease the value of min.prob') dedic.tab <- dedic.tab[dedic.tab$freq >= iter*min.prob,] hppm.freq <- dedic.tab$freq/iter hppm.dedic <- dedic.tab[-length(dedic.tab)] hppm.dedic <- as.data.frame(t(hppm.dedic)) colnames(hppm.dedic) <- paste0('m', 1:ncol(hppm.dedic)) hppm.nfac <- apply(hppm.dedic, 2, count.unique.nonzero) output$hppm <- list(prob = hppm.freq, nfac = hppm.nfac, dedic = hppm.dedic) output$alpha <- list() output$sigma <- list() output$R <- list() if (!is.null(object$beta)) output$beta <- list() for (i in seq_along(hppm.freq)) { if (hppm.freq[i] < min.prob) break hppm.id <- apply(t(dedic) == hppm.dedic[,i], 2, all) a <- apply(alpha[hppm.id, , drop = FALSE], 2, summarize.mcmc) a <- cbind(dedic = hppm.dedic[,i], t(a)) if (byfac) a <- sort.byfac(a) rownames(a) <- colnames(alpha) lab <- paste0('m', i) output$alpha[[lab]] <- a output$sigma[[lab]] <- t(apply(object$sigma[hppm.id, , drop = FALSE], 2, summarize.mcmc)) output$R[[lab]] <- t(apply(object$R[hppm.id, , drop = FALSE], 2, summarize.mcmc)) if (!is.null(object$beta)) output$beta[[lab]] <- t(apply(object$beta[hppm.id, , drop = FALSE], 2, summarize.mcmc)) } if (length(output$alpha) == 0) stop("No hpp model found! Try to decrease value of 'min.prob'.") # factor loadings: insert NA values when not dedicated to any factor for (i in 1:length(output$alpha)) for (j in 1:nrow(output$alpha[[i]])) { if (output$alpha[[i]][j, 'dedic'] == 0) output$alpha[[i]][j, c('mean', 'sd', 'hpd.lo', 'hpd.up')] <- NA } ### general case (not HPP models) } else { alpha <- mat2list(object$alpha) dedic <- mat2list(object$dedic) # posterior number of latent factors iter <- nrow(object$dedic) nfac <- table(object$nfac)/iter output$nfac <- nfac[nfac >= .05] # discard if prob < 0.05 # summarize posterior results for loadings if (what == 'all') { bysum <- function(x, d) by(x, d, summarize.mcmc, prob = TRUE) a <- mapply(bysum, alpha, dedic, SIMPLIFY = FALSE) a <- lapply(a, function(x) do.call(rbind, x)) a <- lapply(a, function(x) cbind(dedic = as.integer(rownames(x)), x)) for(i in 1:length(a)) rownames(a[[i]]) <- rep(names(a)[i], nrow(a[[i]])) a <- do.call(rbind, a) a <- a[a[, 'prob'] >= min.prob,] # drop rows for which prob < min.prob } else if (what == 'maxp') { get.max <- function(x) as.integer(names(which.max(table(x)))) dhp <- sapply(dedic, get.max) hpsum <- function(x, d, dhp) summarize.mcmc(x[d == dhp], prob = TRUE) a <- t(mapply(hpsum, alpha, dedic, dhp)) a <- cbind(dedic = dhp, a) rownames(a) <- names(alpha) } if (byfac) a <- sort.byfac(a) output$alpha <- a # summarize posterior results for remaining parameters output$sigma <- t(apply(object$sigma, 2, summarize.mcmc)) output$R <- t(apply(object$R, 2, summarize.mcmc)) if (!is.null(object$beta)) output$beta <- t(apply(object$beta, 2, summarize.mcmc)) # factor loadings: insert NA values when not dedicated to any factor for (i in 1:nrow(output$alpha)) if (output$alpha[i, 'dedic'] == 0) output$alpha[i, c('mean', 'sd', 'hpd.lo', 'hpd.up')] <- NA } # convert parameter summaries to data frames, # rename duplicate row names if necessary (esp. for factor loadings) mdf <- function(x) as.data.frame(x, row.names = make.unique(rownames(x))) if (what == 'hppm') { output$alpha <- lapply(output$alpha, mdf) output$sigma <- lapply(output$sigma, mdf) output$R <- lapply(output$R, mdf) if (!is.null(output$beta)) output$beta <- lapply(output$beta, mdf) } else { output$alpha <- mdf(output$alpha) output$sigma <- mdf(output$sigma) output$R <- mdf(output$R) if (!is.null(output$beta)) output$beta <- mdf(output$beta) } ### save attributes and return object attr(output, 'Kmax') <- attr(object, 'Kmax') attr(output, 'Nid') <- attr(object, 'Nid') attr(output, 'iter') <- attr(object, 'iter') attr(output, 'burnin') <- attr(object, 'burnin') attr(output, 'what') <- what attr(output, 'min.prob') <- min.prob attr(output, 'hpd.prob') <- hpd.prob attr(output, 'byfac') <- byfac class(output) <- "summary.befa" return(output) } BayesFM/R/befa.R0000644000176200001440000007554114142560523012777 0ustar liggesusers#' #' Bayesian Exploratory Factor Analysis #' #' This function implements the Bayesian Exploratory Factor Analysis #' (\code{befa}) approach developed in Conti et al. (CFSHP, 2014). It runs a #' MCMC sampler for a factor model with dedicated factors, where each manifest #' variable is allowed to load on at most one latent factor. The allocation of #' the manifest variables to the latent factors is not fixed \emph{a priori} but #' determined stochastically during sampling. The minimum number of variables #' dedicated to each factor can be controlled by the user to achieve the desired #' level of identification. The manifest variables can be continuous or #' dichotomous, and control variables can be introduced as covariates. #' #' @param model #' This argument specifies the manifest variables and the covariates used #' in the model (if any). It can be specified in two different ways: #' \itemize{ #' \item A numeric matrix or a data frame containing the manifest #' variables. This corresponds to a model without covariates, #' and the argument \code{data} is not required. #' \item A list of model formulas. Each element of the list specifies #' a manifest variable and its corresponding control variables (e.g., #' '\code{Y1 ~ X1 + X2}' to use \code{X1} and \code{X2} as control #' variables for \code{Y1}). #' If a formula has no left-hand side variable, covariates on the #' right-hand side are included in all equations (e.g., '\code{~ X3}' #' means that \code{X3} is used as a control variable for all the #' manifest variables). Argument \code{data} can be passed to the #' function in that case, otherwise parent data frame is used. #' } #' Binary manifest variables should be specified as logical vectors in #' the data frame to be treated as dichotomous. \code{NA} values are #' accepted in manifest variables only. #' @param data #' Data frame. If missing, parent data frame if used. #' @param burnin #' Burn-in period of the MCMC sampler. #' @param iter #' Number of MCMC iterations saved for posterior inference (after #' burn-in). #' @param Nid #' Minimum number of manifest variables dedicated to each latent factor #' for identification. #' @param Kmax #' Maximum number of latent factors. If missing, the maximum number of #' factors that satisfies the identification condition determined by #' \code{Nid} and the Ledermann bound is specified (see CFSHP, #' section 2.2). #' @param A0 #' Scaling parameters of the variance of the Normal prior on the nonzero #' factor loadings. Either a scalar or a numeric vector of length equal #' to the number of manifest variables. #' @param B0 #' Variances of the Normal prior on the regression coefficients. Either a #' scalar or a numeric vector of length equal to the number of #' manifest variables. #' @param c0 #' Shape parameters of the Inverse-Gamma prior on the idiosyncratic #' variances. Either a scalar or a numeric vector of length equal to the #' number of manifest variables. #' @param C0 #' Scale parameters of the Inverse-Gamma prior on the idiosyncratic #' variances. Either a scalar or a numeric vector of length equal to the #' number of manifest variables. #' @param HW.prior #' If \code{TRUE}, implement Huang-Wand (2013) prior on the covariance #' matrix of the factors in the expanded model, otherwise use an #' Inverse-Wishart prior if \code{FALSE}, see CFSHP section 2.3.5. #' @param nu0 #' Degrees of freedom of the Inverse-Wishart prior on the covariance #' matrix of the latent factors in the expanded model. #' @param S0 #' Scale parameters of the Inverse-Wishart prior on the covariance matrix #' of latent factors in the expanded model: #' \itemize{ #' \item if \code{HW.prior = TRUE}, scale parameter of the Gamma #' hyperprior distribution on the individual scales of the #' Inverse-Wishart prior. #' \item if \code{HW.prior = FALSE}, diagonal elements of the scale #' matrix of the Inverse-Wishart prior on the covariance matrix of #' the latent factors in the expanded model. #' } #' Either a scalar or a numeric vector of length equal to \code{Kmax}. #' @param kappa0 #' First shape parameter of the Beta prior distribution on the #' probability \eqn{\tau_0} that a manifest variable does not load on any #' factor. #' @param xi0 #' Second shape parameter of the Beta prior distribution on the #' probability \eqn{\tau_0} that a manifest variable does not load on any #' factor. #' @param kappa #' Concentration parameters of the Dirichlet prior distribution on the #' indicators. Either a scalar or a numeric vector of length equal to #' \code{Kmax}. #' @param indp.tau0 #' If \code{TRUE}, specify the alternative prior specification with #' independent parameters \eqn{\tau_{0m}}{\tau_0m} across manifest #' variables \eqn{m = 1, ..., M}, otherwise use a common parameter #' \eqn{\tau_0} if \code{FALSE}. #' @param rnd.step #' If \code{TRUE}, select randomly the number of intermediate steps in #' non-identified models at each MCMC iteration, otherwise use a fixed #' number of steps if \code{FALSE}. #' @param n.step #' Controls the number of intermediate steps in non-identified models: #' \itemize{ #' \item if \code{rnd.step = TRUE}, average number of steps. The number #' of steps is sampled at each MCMC iteration from #' 1+Poisson(\code{n.step}-1). #' \item if \code{rnd.step = FALSE}, fixed number of steps. #' } #' @param search.delay #' Number of MCMC iterations run with fixed indicator matrix (specified #' in \code{dedic.start}) at beginning of MCMC sampling. #' @param R.delay #' Number of MCMC iterations run with fixed correlation matrix (specified #' in \code{dedic.start}) at beginning of MCMC sampling. #' @param alpha.start #' Starting values for the factor loadings. Numeric vector of length #' equal to the number of manifest variables. If missing, sampled from a #' Normal distribution with zero mean and variance \code{A0}. #' @param dedic.start #' Starting values for the indicators. Vector of integers of length equal #' to the number of manifest variables. Each element takes a value among #' 0, 1, ..., \code{Kmax}. If missing, random allocation of the manifest #' variables to the maximum number of factors \code{Kmax}, with a minimum #' of \code{Nid} manifest variables loading on each factor. #' @param sigma.start #' Starting values for the idiosyncratic variances. Numeric vector of #' length equal to the number of manifest variables. Sampled from prior #' if missing. #' @param beta.start #' Starting values for the regression coefficients. Numeric vector of #' length equal to the total number of regression coefficients, #' concatenated for all the manifest variables. Sampled from prior if #' missing. #' @param R.start #' Starting values for the correlation matrix of the latent factors. #' Numeric matrix with \code{Kmax} rows and columns, and unit diagonal #' elements. If missing, identity matrix is used. #' @param verbose #' If \code{TRUE}, display information on the progress of the function. #' #' @details \strong{Model specification.} The model is specified as follows, for #' each observation \eqn{i = 1, ..., N}: #' \deqn{Y^*_i = \beta X_i + \alpha \theta_i + \epsilon_i}{ #' Y*_i = \beta X_i + \alpha \theta_i + \epsilon_i} #' \deqn{\theta_i \sim \mathcal{N}(0, R)}{\theta_i ~ N(0, R)} #' \deqn{\epsilon_i \sim \mathcal{N}(0, \Sigma)}{\epsilon_i ~ N(0, \Sigma)} #' \deqn{\Sigma = diag(\sigma^2_1, ..., \sigma^2_M)} #' where \eqn{Y^*_i}{Y*_i} is the \eqn{M}-vector containing the latent #' variables underlying the corresponding \eqn{M} manifest variables #' \eqn{Y_i}, which can be continuous such that #' \eqn{Y_{im} = Y^*_{im}}{Y_im = Y*_im}, or binary with #' \eqn{Y_{im} = 1[Y^*_{im} > 0]}{Y_im = 1[Y*_im > 0]}, for \eqn{m = 1, ..., M}. #' The \eqn{K}-vector \eqn{\theta_i} contains the latent factors, and #' \eqn{\alpha} is the \eqn{(M \times K)}{(M*K)}-matrix of factor loadings. #' The \eqn{M}-vector \eqn{\epsilon_i} is the vector of error terms. #' Covariates can be included in the \eqn{Q}-vector \eqn{X_i} and are related to #' the manifest variables through the \eqn{(M \times Q)}{(M*Q)}-matrix of #' regression coefficients \eqn{\beta}. Intercept terms are automatically #' included, but can be omitted in some or all equations using the usual syntax #' for R formulae (e.g., 'Y1 ~ X1 - 1' specifies that that Y1 is regressed on X1 #' and no intercept is included in the corresponding equation). #' #' The number of latent factors \eqn{K} is specified as \code{Kmax}. However, #' during MCMC sampling the stochastic search process on the matrix \eqn{\alpha} #' may produce zero columns, thereby reducing the number of active factors. #' #' The covariance matrix \eqn{R} of the latent factors is assumed to be a #' correlation matrix for identification. #' #' Each row of the factor loading matrix \eqn{\alpha} contains at most one #' nonzero element (dedicated factor model). The allocation of the manifest #' variables to the latent factors is indicated by the binary matrix #' \eqn{\Delta} with same dimensions as \eqn{\alpha}, such that each row #' \eqn{\Delta_m} indicates which factor loading is different from zero, e.g.: #' \deqn{\Delta_m = (0, .., 0, 1, 0, ..., 0) \equiv e_k}{ #' \Delta_m = (0, .., 0, 1, 0, ..., 0) = e_k} #' indicates that variable \eqn{m} loads on the \eqn{k}th factor, where #' \eqn{e_k} is a \eqn{K}-vector that contains only zeros, besides its \eqn{k}th #' element that equals 1. #' #' \strong{Identification.} The function verifies that the maximum number of #' latent factors \code{Kmax} does not exceed the Ledermann bound. It also #' checks that \code{Kmax} is consistent with the identification restriction #' specified with \code{Nid} (enough variables should be available to load on #' the factors when \code{Kmax} is reached). The default value for \code{Kmax} #' is the minimum between the Ledermann bound and the maximum number of factors #' that can be loaded by \code{Nid} variables. The user is free to select the #' level of identification, see CFSHP section 2.2 (non-identified models are #' allowed with \code{Nid = 1}). #' #' Note that identification is achieved only with respect to the scale of the #' latent factors. Non-identifiability problems may affect the posterior sample #' because of column switching and sign switching of the factor loadings. #' These issues can be addressed \emph{a posteriori} with the functions #' \code{\link{post.column.switch}} and \code{\link{post.sign.switch}}. #' #' \strong{Prior specification.} #' The indicators are assumed to have the following probabilities, #' for \eqn{k = 1, ..., K}: #' \deqn{Prob(\Delta_m = e_k \mid \tau_k) = \tau_k}{ #' Prob(\Delta_m = e_k | \tau_k) = \tau_k} #' \deqn{\tau = (\tau_0, \tau_1, ..., \tau_K)} #' If \code{indp.tau0 = FALSE}, the probabilities are specified as: #' \deqn{\tau = [\tau_0, (1-\tau_0)\tau^*_1, ..., (1-\tau_0)\tau^*_K]}{ #' \tau = [\tau_0, (1-\tau_0)\tau*_1, ..., (1-\tau_0)\tau*_K]} #' \deqn{\tau_0 \sim \mathcal{B}eta(\kappa_0, \xi_0)}{ #' \tau_0 ~ Beta(\kappa_0, \xi_0)} #' \deqn{\tau^* = (\tau^*_1, ..., \tau^*_K) \sim \mathcal{D}ir(\kappa)}{ #' \tau* = (\tau*_1, ..., \tau*_K) ~ Dir(\kappa)} #' with \eqn{\kappa_0} = \code{kappa0}, \eqn{\xi_0} = \code{xi0} and #' \eqn{\kappa} = \code{kappa}. #' Alternatively, if \code{indp.tau0 = TRUE}, the probabilities are specified #' as: #' \deqn{\tau_m = [\tau_{0m}, (1-\tau_{0m})\tau^*_1, ..., #' (1-\tau_{0m})\tau^*_K]}{ #' \tau_m = [\tau_0m, (1-\tau_0m)\tau*_1, ..., (1-\tau_0m)\tau*_K]} #' \deqn{\tau_{0m} \sim \mathcal{B}eta(\kappa_0, \xi_0)}{ #' \tau_0m ~ Beta(\kappa_0, \xi_0)} #' for each manifest variable \eqn{m = 1, ..., M}. #' #' A normal-inverse-Gamma prior distribution is assumed on the nonzero factor #' loadings and on the idiosyncratic variances: #' \deqn{\sigma^2_m \sim \mathcal{I}nv-\mathcal{G}amma(c_{0m}, C_{0m})}{ #' \sigma^2_m ~ Inv-Gamma(c0_m, C0_m)} #' \deqn{\alpha_m^\Delta \mid \sigma^2_m \sim \mathcal{N}(0, A_{0m}\sigma^2_m)}{ #' \alpha_m^\Delta | \sigma^2_m ~ N(0, A0_m * \sigma^2_m)} #' where \eqn{\alpha_m^\Delta} denotes the only nonzero loading in the \eqn{m}th #' row of \eqn{\alpha}. #' #' For the regression coefficients, a multivariate Normal prior distribution is #' assumed on each row \eqn{m = 1, ..., M} of \eqn{\beta}: #' \deqn{\beta_m \sim \mathcal{N}(0, B_0 I_Q)}{\beta_m ~ N(0, B_0 I_Q)} #' The covariates can be different across manifest variables, implying zero #' restrictions on the matrix \eqn{\beta}. To specify covariates, use a list #' of formulas as \code{model} (see example below). Intercept terms can be #' introduced using #' #' To sample the correlation matrix \eqn{R} of the latent factors, marginal data #' augmentation is implemented (van Dyk and Meng, 2001), see CFSHP section 2.2. #' Using the transformation \eqn{\Omega = \Lambda^{1/2} R \Lambda^{1/2}}, the #' parameters \eqn{\Lambda = diag(\lambda_1, ..., \lambda_K)} are used as #' \emph{working parameters}. These parameters correspond to the variances of #' the latent factors in an expanded version of the model where the factors do #' not have unit variances. Two prior distributions can be specified on the #' covariance matrix \eqn{\Omega} in the expanded model: #' \itemize{ #' \item If \code{HW.prior = FALSE}, inverse-Wishart distribution: #' \deqn{\Omega \sim \mathcal{I}nv-\mathcal{W}ishart(\nu_0, diag(S_0))}{ #' \Omega ~ Inv-Wishart(\nu_0, diag(S0))} #' with \eqn{\nu_0} = \code{nu0} and \eqn{S_0} = \code{S0}. #' \item If \code{HW.prior = TRUE}, Huang-Wand (2013) prior: #' \deqn{\Omega \sim \mathcal{I}nv-\mathcal{W}ishart(\nu_0, W), \qquad #' W = diag(w_1, ..., w_K)}{ #' \Omega ~ Inv-Wishart(nu0, W), W = diag(w_1, ..., w_K)} #' \deqn{w_k \sim \mathcal{G}amma\left(\frac{1}{2}, #' \frac{1}{2\nu^*S_{0k}}\right)}{w_k ~ Gamma(1/2, 1/(2\nu*S0_k))} #' with \eqn{\nu^*}{\nu*} = \code{nu0} - \code{Kmax} + 1, and the shape and #' rate parameters are specified such that the mean of the gamma distribution #' is equal to \eqn{\nu^* S_{0k}}{\nu* S0_k}, for each \eqn{k = 1, ..., K}. #' } #' #' \strong{Missing values.} Missing values (\code{NA}) are allowed in the #' manifest variables. They are drawn from their corresponding conditional #' distributions during MCMC sampling. Control variables with missing values #' can be passed to the function. However, all the observations with at least #' one missing value in the covariates are discarded from the sample (a warning #' message is issued in that case). #' #' @return The function returns an object of class '\code{befa}' containing the #' MCMC draws of the model parameters saved in the following matrices (each #' matrix has '\code{iter}' rows): #' \itemize{ #' \item \code{alpha}: Factor loadings. #' \item \code{sigma}: Idiosyncratic variances. #' \item \code{R}: Correlation matrix of the latent factors (off-diagonal #' elements only). #' \item \code{beta}: regression coefficients (if any). #' \item \code{dedic}: indicators (integers indicating on which factors the #' manifest variable load). #' } #' The returned object also contains: #' \itemize{ #' \item \code{nfac}: Vector of number of 'active' factors across MCMC #' iterations (i.e., factors loaded by at least \code{Nid} manifest #' variables). #' \item \code{MHacc}: Logical vector indicating accepted proposals of #' Metropolis-Hastings algorithm. #' } #' The parameters \code{Kmax} and \code{Nid} are saved as object attributes, as #' well as the function call and the number of mcmc iterations (\code{burnin} #' and \code{iter}), and two logical variables indicating if the returned object #' has been post processed to address the column switching problem #' (\code{post.column.switch}) and the sign switching problem #' (\code{post.sign.switch}). #' #' @author Rémi Piatek \email{remi.piatek@@gmail.com} #' #' @references G. Conti, S. Frühwirth-Schnatter, J.J. Heckman, R. Piatek (2014): #' ``Bayesian Exploratory Factor Analysis'', \emph{Journal of Econometrics}, #' 183(1), pages 31-57, \doi{10.1016/j.jeconom.2014.06.008}. #' #' @references A. Huang, M.P. Wand (2013): #' ``Simple Marginally Noninformative Prior Distributions for Covariance #' Matrices'', \emph{Bayesian Analysis}, 8(2), pages 439-452, #' \doi{10.1214/13-BA815}. #' #' @references D.A. van Dyk, X.-L. Meng (2001): #' ``The Art of Data Augmentation'', #' \emph{Journal of Computational and Graphical Statistics}, 10(1), pages 1-50, #' \doi{10.1198/10618600152418584}. #' #' @seealso \code{\link{post.column.switch}} and \code{\link{post.sign.switch}} #' for column switching and sign switching of the factor loading matrix and of #' the correlation matrix of the latent factors to restore identification #' \emph{a posteriori}. #' #' @seealso \code{\link{summary.befa}} and \code{\link{plot.befa}} to summarize #' and plot the posterior results. #' #' @seealso \code{\link{simul.R.prior}} and \code{\link{simul.nfac.prior}} to #' simulate the prior distribution of the correlation matrix of the factors and #' the prior distribution of the indicator matrix, respectively. This is useful #' to perform prior sensitivity analysis and to understand the role of the #' corresponding parameters in the factor search. #' #' @examples #' #### model without covariates #' #' set.seed(6) #' #' # generate fake data with 15 manifest variables and 3 factors #' N <- 100 # number of observations #' Y <- simul.dedic.facmod(N, dedic = rep(1:3, each = 5)) #' #' # run MCMC sampler #' # notice: 1000 MCMC iterations for illustration purposes only, #' # increase this number to obtain reliable posterior results! #' mcmc <- befa(Y, Kmax = 5, iter = 1000) #' #' # post process MCMC draws to restore identification #' mcmc <- post.column.switch(mcmc) #' mcmc <- post.sign.switch(mcmc) #' \donttest{ #' summary(mcmc) # summarize posterior results #' plot(mcmc) # plot posterior results #' #' # summarize highest posterior probability (HPP) model #' summary(mcmc, what = 'hppm') #' #' #### model with covariates #' #' # generate covariates and regression coefficients #' Xcov <- cbind(1, matrix(rnorm(4*N), ncol = 4)) #' colnames(Xcov) <- c('(Intercept)', paste0('X', 1:4)) #' beta <- rbind(rnorm(15), rnorm(15), diag(3) %x% t(rnorm(5))) #' #' # add covariates to previous model #' Y <- Y + Xcov %*% beta #' #' # specify model #' model <- c('~ X1', # X1 covariate in all equations #' paste0('Y', 1:5, ' ~ X2'), # X2 covariate for Y1-Y5 only #' paste0('Y', 6:10, ' ~ X3'), # X3 covariate for Y6-Y10 only #' paste0('Y', 11:15, ' ~ X4')) # X4 covariate for Y11-Y15 only #' model <- lapply(model, as.formula) # make list of formulas #' #' # run MCMC sampler, post process and summarize #' mcmc <- befa(model, data = data.frame(Y, Xcov), Kmax = 5, iter = 1000) #' mcmc <- post.column.switch(mcmc) #' mcmc <- post.sign.switch(mcmc) #' mcmc.sum <- summary(mcmc) #' mcmc.sum #' #' # compare posterior mean of regression coefficients to true values #' beta.comp <- cbind(beta[beta != 0], mcmc.sum$beta[, 'mean']) #' colnames(beta.comp) <- c('true', 'mcmc') #' print(beta.comp, digits = 3) #' } #' #' @export befa #' @import checkmate #' @importFrom stats rnorm runif #' @useDynLib BayesFM, .registration = TRUE, .fixes = "F_" befa <- function(model, data, burnin = 1000, iter = 10000, Nid = 3, Kmax, A0 = 10, B0 = 10, c0 = 2, C0 = 1, HW.prior = TRUE, nu0 = Kmax + 1, S0 = 1, kappa0 = 2, xi0 = 1, kappa = 1/Kmax, indp.tau0 = TRUE, rnd.step = TRUE, n.step = 5, search.delay = min(burnin, 10), R.delay = min(burnin, 100), dedic.start, alpha.start, sigma.start, beta.start, R.start, verbose = TRUE) { checkArgs <- makeAssertCollection() ############################################################################## ## data and model specification if (missing(data)) data <- parent.frame() else assertDataFrame(data) if (is.matrix(model)) model <- as.data.frame(model) if (is.data.frame(model)) { assertDataFrame(model, types = c('double', 'logical'), all.missing = FALSE) Ytype <- sapply(model, typeof) Yobs <- as.matrix(model) Xobs <- nX <- 0 YXloc <- FALSE } else if (is.list(model) & all(sapply(model, is.formula))) { tmp <- extract.data(model, data) if (!is.null(tmp$errmsg)) { for (w in tmp$errmsg) checkArgs$push(w) } else { for (w in tmp$warnmsg) warning(w, immediate. = TRUE) Yobs <- tmp$Yobs Ytype <- tmp$Ytype Xobs <- tmp$Xobs Xlab <- colnames(Xobs) YXloc <- tmp$YXloc nX <- ncol(Xobs) } } else { checkArgs$push('Y should be a matrix, a data frame or a list of formulas.') } # if any errors, report and stop reportAssertions(checkArgs) # check manifest variables are either continuous or dichotomous Ycat <- rep(0, length(Ytype)) Ycat[Ytype == 'logical'] <- 2 Yind <- Ytype %in% c('double', 'numeric', 'logical') if (any(!Yind)) { checkArgs$push(paste('following variables not continuous nor dichotomous:', paste0(Ylab[!Yind], collapse = ', '))) } Ylab <- colnames(Yobs) nobs <- nrow(Yobs) nvar <- ncol(Yobs) nbeta <- sum(YXloc) Ymiss <- is.na(Yobs) Yobs[Ymiss] <- -99999 # flag for NA (not used in Fortran subroutine) ############################################################################## ## number of latent factors and identification restrictions # minimum number of dedicated variables per factor assertInt(Nid, lower = 1, upper = nvar, add = checkArgs) # check maximum number of latent factors and Ledermann bound Ledermann.bound <- 0.5 * (2 * nvar + 1 - sqrt(8 * nvar + 1)) if (missing(Kmax)) { Kmax <- floor(min(nvar/Nid, Ledermann.bound)) } else { assertInt(Kmax, lower = 1, upper = nvar, add = checkArgs) } if (Kmax > Ledermann.bound) { warning("Check identification! (Kmax exceeds Ledermann bound)", immediate. = TRUE) } # check consistency of Nid and Kmax if (Kmax > floor(nvar/Nid)) { msg <- paste("Too many latent factors specified given identification", "restriction. Check arguments Nid and Kmax.") checkArgs$push(msg) } # throw warning in case of single-factor model if (Kmax == 1) { checkArgs$push("Single-factor model not allowed.") } reportAssertions(checkArgs) ############################################################################## ## prior parameters # function checking prior parameter values check.prior <- function(x, n, min, name) { if (length(x) == 1) x <- rep(x, n) assertNumeric(x, len = n, lower = min, finite = TRUE, any.missing = FALSE, .var.name = name, add = checkArgs) return(x) } tiny <- 10^-9 A0 <- check.prior(A0, nvar, tiny, "A0") B0 <- check.prior(B0, nvar, tiny, "B0") c0 <- check.prior(c0, nvar, tiny, "c0") C0 <- check.prior(C0, nvar, tiny, "C0") S0 <- check.prior(S0, Kmax, tiny, "S0") nu0 <- check.prior(nu0, 1, Kmax, "nu0") xi0 <- check.prior(xi0, 1, tiny, "xi0") kappa <- check.prior(kappa, Kmax, tiny, "kappa") kappa0 <- check.prior(kappa0, 1, tiny, "kappa0") # use Huang-Wand (2013) prior? assertFlag(HW.prior, add = checkArgs) # use specific tau0 parameters for each manifest variable? [see CFSHP, p.36] assertFlag(indp.tau0, add = checkArgs) # if any errors, stop here reportAssertions(checkArgs) # prior values for Fortran subroutine prior.idiovar <- cbind(c0, C0) prior.loading <- 1/A0 # precision passed to Fortran subroutine prior.beta <- 1/B0 # precision passed to Fortran subroutine prior.dedic <- c(indp.tau0, 1/A0, c0, C0, xi0, kappa0, kappa) prior.facdist <- c(HW.prior, nu0, S0) ############################################################################## ## starting values ### idiosyncratic variances if (missing(sigma.start)) { sigma.start <- 1/rgamma(nvar, shape = c0, rate = C0) } else { assertNumeric(sigma.start, len = nvar, lower = tiny, any.missing = FALSE, add = checkArgs) } sigma.start[Ycat > 0] <- 1 # fix variance to 1 for binary variables ### factor loadings if (missing(alpha.start)) { alpha.start <- rnorm(nvar, mean = 0, sd = sqrt(A0)) } else { assertNumeric(alpha.start, len = nvar, any.missing = FALSE, add = checkArgs) } ### regression coefficients if (missing(beta.start)) { if (nbeta > 0) { beta.start <- rnorm(nbeta, mean = 0, sd = rep(sqrt(B0), rowSums(YXloc))) } else { beta.start <- double() } } assertNumeric(beta.start, len = nbeta, any.missing = FALSE, add = checkArgs) # prepare matrix to be passed to Fortran subroutine beta.start.1 <- matrix(-99999, nX, nvar) if (length(beta.start) == nbeta) { beta.start.1[t(YXloc)] <- beta.start beta.start.1 <- t(beta.start.1) } ### correlation matrix of latent factors if (missing(R.start)) { R.start <- diag(Kmax) } # check matrix is a correlation matrix, positive semi-definite, and invertible assertMatrix(R.start, mode = "double", nrows = Kmax, ncols = Kmax, any.missing = FALSE, add = checkArgs) if (!all(diag(R.start) == 1)) { checkArgs$push("R.start should be a correlation matrix.") } if (!is.pos.semidefinite.matrix(R.start)) { checkArgs$push("R.start should be a positive semi-definite matrix.") } if (!is.invertible.matrix(R.start)) { checkArgs$push("R.start is not invertible (singular matrix).") } ### indicators - default: maximum number of factors, random allocation if (missing(dedic.start)) { dedic.start <- rep(0, nvar) ind <- matrix(sample(Nid * Kmax), ncol = Kmax) for (k in 1:Kmax) dedic.start[ind[, k]] <- k dedic.start[dedic.start == 0] <- sample(Kmax, nvar - Nid * Kmax, replace = TRUE) } assertIntegerish(dedic.start, len = nvar, lower = 0, upper = Kmax, any.missing = FALSE, add = checkArgs) # check identification constraint if (any(table(dedic.start[dedic.start != 0]) < Nid)) { checkArgs$push("dedic.start does not correspond to an identified model.") } ### latent factors start.factor <- replicate(Kmax, rnorm(nobs)) ############################################################################## ## MCMC tuning assertCount(iter, positive = TRUE, add = checkArgs) assertCount(burnin, positive = FALSE, add = checkArgs) assertInt(search.delay, lower = 0, upper = burnin + iter) assertInt(R.delay, lower = 0, upper = burnin + iter) assertFlag(rnd.step, add = checkArgs) if (rnd.step) { assertNumber(n.step, lower = 1.1, add = checkArgs) n.step <- n.step - 1 # so that number of steps ~ 1 + Poisson(n.step-1) } else { assertCount(n.step, positive = TRUE, add = checkArgs) } ############################################################################## ## if any errors in arguments, report and stop execution assertFlag(verbose, add = checkArgs) reportAssertions(checkArgs) ############################################################################## ## MCMC sampling # total number of model parameters npar <- c(nvar, nvar, Kmax*(Kmax - 1)/2, nbeta) npar.all <- sum(npar) # seed for RNG in Fortran subroutine seed <- round(runif(1) * 10^9) # call Fortran subroutine if (verbose) cat("starting MCMC sampling...\n") mcmc <- .Fortran(F_befa, as.integer(nvar), as.integer(nobs), as.integer(Kmax), as.integer(Nid), as.double(Yobs), as.integer(Ycat), as.logical(Ymiss), as.integer(nX), as.double(Xobs), as.logical(YXloc), as.integer(burnin + iter), as.integer(burnin), as.integer(search.delay), as.integer(R.delay), as.logical(rnd.step), as.double(n.step), as.integer(seed), as.double(cbind(prior.loading, prior.idiovar)), as.double(prior.beta), as.double(prior.dedic), as.double(prior.facdist), as.double(cbind(alpha.start, sigma.start)), as.double(beta.start.1), as.integer(dedic.start), as.double(start.factor), as.double(R.start), as.logical(verbose), as.integer(npar.all), MCMCdraws = double(iter * npar.all), MCMCdedic = integer(iter * nvar), MHacc = logical(iter)) if (verbose) cat("done with sampling!\n") ############################################################################## ## label MCMC draws and return output # extract MCMC draws par.mcmc <- split(mcmc$MCMCdraws, rep(1:4, times = iter * npar)) par.mcmc <- lapply(par.mcmc, matrix, nrow = iter) # label parameters names(par.mcmc)[1:3] <- c("alpha", "sigma", "R") colnames(par.mcmc$R) <- paste("R", rep(1:(Kmax-1), times = (Kmax-1):1), unlist(mapply(seq, 2:Kmax, Kmax)), sep = ":") colnames(par.mcmc$alpha) <- paste0("alpha:", Ylab) colnames(par.mcmc$sigma) <- paste0("sigma:", Ylab) iter.lab <- burnin + 1:iter rownames(par.mcmc$alpha) <- iter.lab rownames(par.mcmc$sigma) <- iter.lab rownames(par.mcmc$R) <- iter.lab if (nbeta > 0) { names(par.mcmc)[4] <- "beta" beta.lab <- c() for (i in 1:nvar) { if (!any(YXloc[i, ])) next beta.lab <- c(beta.lab, paste(Ylab[i], Xlab[YXloc[i, ]], sep = ":")) } colnames(par.mcmc$beta) <- beta.lab rownames(par.mcmc$beta) <- iter.lab } # indicators dedic.mcmc <- as.integer(mcmc$MCMCdedic) dedic.mcmc <- matrix(dedic.mcmc, nrow = iter, ncol = nvar) colnames(dedic.mcmc) <- paste0("dedic:", Ylab) rownames(dedic.mcmc) <- iter.lab # number of active latent factors across MCMC iterations nfac.mcmc <- apply(dedic.mcmc, 1, count.unique.nonzero) # prepare and return output output <- par.mcmc output$dedic <- dedic.mcmc output$nfac <- nfac.mcmc output$MHacc <- mcmc$MHacc attr(output, "call") <- match.call() attr(output, "title") <- "BEFA posterior sample" attr(output, "Kmax") <- Kmax attr(output, "Nid") <- Nid attr(output, "iter") <- iter attr(output, "burnin") <- burnin attr(output, "post.column.switch") <- FALSE attr(output, "post.sign.switch") <- FALSE class(output) <- "befa" return(output) } BayesFM/R/plot.simul.nfac.prior.R0000644000176200001440000000121714142560501016231 0ustar liggesusers#' @export #' @importFrom ggplot2 ggplot aes_string geom_bar labs theme element_blank plot.simul.nfac.prior <- function(x, ...) { nfac <- summary(x)$nfac dat <- data.frame(freq = unlist(nfac), nfac = c(as.integer(sapply(nfac, names))), lab = rep(names(nfac), sapply(nfac, length))) ggplot(dat, aes_string(x = 'nfac', y = 'freq')) + geom_bar(aes_string(fill = 'lab'), position = 'dodge', stat = 'identity') + labs(x = 'number of factors', y = 'prior probability') + theme(legend.position = 'bottom', legend.direction = 'horizontal', legend.title = element_blank()) } BayesFM/R/post.sign.switch.R0000644000176200001440000001223714142560501015313 0ustar liggesusers#' #' Perform sign switchting on posterior MCMC sample #' #' This function performs a sign switch on the MCMC draws to restore the #' consistency of the signs of the factors loadings and of the correlations of #' the latent factors \emph{a posteriori}. #' #' @param mcmc #' Object of class '\code{befa}'. #' @param benchmark #' Vector of integers of length equal to the maximum number of latent #' factors. Each element indicates which factor loading is used as a #' benchmark for the sign switch. If \code{NULL}, the factor loadings #' with the highest posterior probabilities of being different from zero #' in each column of the factor loading matrix are used as benchmarks. #' @param benchmark.threshold #' Minimum posterior probability for a factor loading to be considered #' as a benchmark. #' #' @details The signs of the factor loadings, as well as of the corresponding #' correlations of the latent factors, are switched for each MCMC iteration such #' that the factor loadings defined as \code{benchmark}s are positive. The sign #' switch can only be performed if \code{\link{post.column.switch}} has been run #' before. See section 4.3 (p.42) of CFSHP for more details. #' #' If a latent factor has no benchmarks, or if its benchmark is equal to zero at #' some MCMC iteration, then no sign switch is performed on the corresponding #' loadings and correlations for this particular factor or MCMC iteration. #' #' Note that in complicated models where the sampler visits several models with #' different numbers of latent factors, it may not be relevant to use the #' default value of \code{benchmark}, as the posterior probabilities that the #' factor loadings are different from zero would be computed across models. #' Instead, the user might consider finding the highest posterior probability #' model first, and use its top elements in each column of the factor loading #' matrix as benchmarks to perform the sign switch. #' #' @return This function returns the same '\code{befa}' object, where the signs #' of the factor loadings and of the factor correlations have been switched #' appropriately to restore the identification of the factor model with respect #' to sign switching. #' #' @author Rémi Piatek \email{remi.piatek@@gmail.com} #' #' @references #' G. Conti, S. Frühwirth-Schnatter, J.J. Heckman, #' R. Piatek (2014): ``Bayesian Exploratory Factor Analysis'', #' \emph{Journal of Econometrics}, 183(1), pages 31-57, #' \doi{10.1016/j.jeconom.2014.06.008}. #' #' @seealso \code{\link{post.column.switch}} for column switching of the factor #' loading matrix and of the correlation matrix of the latent factors to restore #' identification \emph{a posteriori}. #' #' @examples #' set.seed(6) #' Y <- simul.dedic.facmod(N = 100, dedic = rep(1:3, each = 5)) #' mcmc <- befa(Y, Kmax = 5, iter = 1000) #' mcmc <- post.column.switch(mcmc) #' #' # factor loadings corresponding to variables 1, 6, 11, 12 and 13 are #' # used as benchmarks: #' mcmc1 <- post.sign.switch(mcmc, benchmark = c(1, 6, 11, 12, 13)) #' #' # factor loadings with the highest posterior probability of being different #' # from zero in each column are used as benchmark: #' mcmc2 <- post.sign.switch(mcmc) #' #' @export post.sign.switch #' @import checkmate post.sign.switch <- function(mcmc, benchmark = NULL, benchmark.threshold = 0.5) { assertClass(mcmc, classes = "befa") if (attr(mcmc, "post.sign.switch")) { warning("sign switching already performed, nothing done.") return(mcmc) } if (!attr(mcmc, "post.column.switch")) { stop("post.column.switch should be run first.") } assertNumber(benchmark.threshold, lower = 0, upper = 1) Kmax <- attr(mcmc, "Kmax") nvar <- ncol(mcmc$dedic) iter <- nrow(mcmc$dedic) R.npar <- Kmax * (Kmax - 1)/2 # factor loadings used as benchmarks if (is.null(benchmark)) { alpha.post.prob <- matrix(0, Kmax, nvar) for (k in 1:Kmax) { alpha.post.prob[k, ] <- colMeans(mcmc$dedic == k) } benchmark <- max.col(alpha.post.prob, ties.method = "first") for (k in 1:Kmax) { if (alpha.post.prob[k, benchmark[k]] < benchmark.threshold) { benchmark[k] <- NA # not a benchmark if post prob < threshold } } } else { assertIntegerish(benchmark, lower = 0, upper = nvar, any.missing = FALSE, len = Kmax) } # index matrix used to reconstruct matrix from lower triangular elements R.mat <- diag(Kmax) * (R.npar + 1) R.mat[lower.tri(R.mat)] <- 1:R.npar R.mat[upper.tri(R.mat)] <- t(R.mat)[upper.tri(R.mat)] for (i in 1:iter) { # switch signs of factor loadings dedic <- mcmc$dedic[i, ] switch <- sign(mcmc$alpha[i, benchmark]) switch[is.na(switch)] <- 1 # no sign switch for factors with no benchmark switch.meas <- rep(0, nvar) for (j in 1:nvar) { if (dedic[j] == 0) next switch.meas[j] <- switch[dedic[j]] } mcmc$alpha[i, ] <- mcmc$alpha[i, ] * switch.meas # switch signs of rows and columns of correlation matrix R <- c(mcmc$R[i, ], 1) R <- matrix(R[R.mat], nrow = Kmax) R <- diag(switch) %*% R %*% diag(switch) mcmc$R[i, ] <- R[lower.tri(R)] } attr(mcmc, "post.sign.switch") <- TRUE return(mcmc) } BayesFM/R/print.summary.simul.nfac.prior.R0000644000176200001440000000036114142560501020102 0ustar liggesusers#' @export print.summary.simul.nfac.prior <- function(x, ...) { cat('prior probabilities of numbers of factors:\n') out <- cbind(do.call(rbind, x$nfac), acc = unlist(x$acc)) out <- round(out, digits = 3) print(out, print.gap = 3) } BayesFM/R/zzz.R0000644000176200001440000000077214631161175012734 0ustar liggesusers.onAttach <- function(libname, pkgname) { if (interactive() || getOption("verbose")) { msg <- sprintf(paste( "###", "### Package %s (%s) loaded", "###", "### Please report any bugs, and send suggestions or feedback", "### to %s", "###", sep = "\n"), pkgname, utils::packageDescription(pkgname)$Version, utils::maintainer(pkgname)) packageStartupMessage(msg) } } .onUnload <- function(libpath) { library.dynam.unload("BayesFM", libpath) }BayesFM/R/summary.simul.R.prior.R0000644000176200001440000000210514142560501016237 0ustar liggesusers#' @export #' @import checkmate #' @importFrom stats median sd quantile summary.simul.R.prior <- function(object, ...) { args <- list(...) if (is.null(args$probs)) { probs <- c(.05, .1, .25, .75, .9, .95) } else { probs <- args$probs } assertNumeric(probs, lower = 0, upper = 1, any.missing = FALSE, min.len = 1) sum.prior <- function(x, FUN) { val <- lapply(x, function(z) apply(z, 3, FUN)) stat <- lapply(val, function(z) return(c(mean = mean(z), median = median(z), sd = sd(z), min = min(z), max = max(z)))) quant <- lapply(val, quantile, probs) res <- list(stat = do.call(rbind, stat), quant = do.call(rbind, quant)) res <- lapply(res, round, digits = 3) return(res) } out <- list(maxcor = sum.prior(object, get.maxcor), mineig = sum.prior(object, get.mineig)) class(out) <- 'summary.simul.R.prior' return(out) } BayesFM/R/print.simul.R.prior.R0000644000176200001440000000073114142560501015701 0ustar liggesusers#' @export print.simul.R.prior <- function(x, ...) { cat('sample from prior distribution of factor correlation matrix\n') cat('\ncall:\n ') print(attr(x, 'call')) cat('\nKmax =', attr(x, 'Kmax'), '\n') cat('\nparameter values:\n ') cat(names(x), sep = '\n ') cat('\nnrep =', attr(x, 'nrep'), '\n\n') cat('use summary() and plot() functions to summarize and plot prior density', 'of maximum correlation and/or of minimum eigenvalue', sep = '\n') } BayesFM/R/plot.befa.R0000644000176200001440000001657014145716517013762 0ustar liggesusers#' #' Plot object of class 'befa' #' #' This function makes different plots that are useful to assess the posterior #' results: a trace plot of the number of latent factors (also showing #' Metropolis-Hastings acceptance across MCMC replications), a histogram #' of the posterior probabilities of the number of factors, heatmaps for the #' inficator probabilities, the factor loading matrix, and the correlation #' matrix of the latent factors. #' #' @inheritParams summary.befa #' @param x Object of class 'befa'. #' #' @details This function makes graphs based on the summary results returned by #' \code{\link{summary.befa}}. It therefore accepts the same optional arguments #' as this function. #' #' @return No return value, called for side effects (plots the posterior results #' returned by \code{\link{summary.befa}}). #' #' @author Rémi Piatek \email{remi.piatek@@gmail.com} #' #' @seealso \code{\link{summary.befa}} to summarize posterior results. #' #' @examples #' set.seed(6) #' #' # generate fake data with 15 manifest variables and 3 factors #' Y <- simul.dedic.facmod(N = 100, dedic = rep(1:3, each = 5)) #' #' # run MCMC sampler and post process output #' # notice: 1000 MCMC iterations for illustration purposes only, #' # increase this number to obtain reliable posterior results! #' mcmc <- befa(Y, Kmax = 5, iter = 1000) #' mcmc <- post.column.switch(mcmc) #' mcmc <- post.sign.switch(mcmc) #' #' # plot results for highest posterior probability model #' plot(mcmc, what = 'hppm') #' #' @export #' @importFrom ggplot2 ggplot aes_string theme labs element_text #' @importFrom ggplot2 geom_line geom_tile geom_text geom_rug geom_bar #' @importFrom ggplot2 scale_fill_gradient2 guide_colorbar guides unit plot.befa <- function(x, ...) { args <- list(...) show.val <- ifelse(is.null(args$show.val), TRUE, args$show.val) what <- ifelse(is.null(args$what), 'maxp', args$what) assertFlag(show.val) if (!what %in% c('maxp', 'hppm')) stop('plot.befa() only implemented for what = "maxp" and what = "hppm"') Kmax <- attr(x, 'Kmax') ############################################################################## ### trace of number of factors dat <- data.frame(nfac = factor(x$nfac, levels = 0:Kmax), iter = as.numeric(names(x$nfac)), MHacc = as.numeric(x$MHacc)) p.nfac <- ggplot(dat, aes_string(x = 'iter', y = 'nfac')) + geom_line(colour = 'steelblue') p.nfac <- p.nfac + labs(title = paste0('trace plot of number of factors\n', '(accepted Metropolis-Hastings draws at bottom)'), x = 'MCMC iterations', y = 'number of factors') # add Metropolis-Hastings acceptance p.nfac <- p.nfac + geom_rug(aes_string(y = 'MHacc'), sides = 'b', colour = 'darkcyan') # posterior probabilities of number of factors nft <- table(factor(x$nfac, levels = 0:Kmax)) dat <- data.frame(nfac = as.factor(0:Kmax), freq = as.numeric(nft / length(x$nfac))) p.hnfac <- ggplot(dat, aes_string(x = 'nfac')) + geom_bar(aes_string(weight = 'freq'), fill = 'steelblue') + labs(title = 'posterior probabilities of number of factors', x = 'number of factors', y = 'frequencies') ############################################################################## # summarize and plot x <- summary(x, ...) if (what == 'hppm') { alpha <- x$alpha$m1 dedic <- x$alpha$m1$dedic R <- x$R$m1 } else { alpha <- x$alpha dedic <- x$alpha$dedic R <- x$R } nvar <- length(dedic) ### matrix of indicator probabilities if (what != 'hppm') { # skip for HPP model pind <- matrix(NA, nvar, Kmax) rownames(pind) <- sapply(strsplit(rownames(alpha), ':'), '[', 2) colnames(pind) <- paste0('f', 1:Kmax) for (i in 1:nvar) pind[i, dedic[i]] <- alpha$prob[i] # which factors are loaded by at least one measurement? acti <- apply(!is.na(pind), 2, any) # heatmap for active factors only p.indic <- make.heatmap(pind[, acti], title = 'indicator probabilities of being nonzero', xlab = 'latent factors (active factors only)', ylab = 'manifest variables', show.val) } ### matrix of factor loadings # construct matrix from factor loadings and indicators # (remove the 'alpha:' part from variable names to simplify plot) alpha.post <- matrix(NA, nvar, Kmax) rownames(alpha.post) <- sapply(strsplit(rownames(alpha), ':'), '[', 2) colnames(alpha.post) <- paste0('f', 1:Kmax) for (i in 1:nvar) alpha.post[i, dedic[i]] <- alpha$mean[i] # which factors are loaded by at least one measurement? acti <- !apply(is.na(alpha.post), 2, all) # heatmap for active factors only p.alpha <- make.heatmap(alpha.post[, acti], title = 'factor loading matrix', xlab = 'latent factors (active factors only)', ylab = 'manifest variables', show.val) ### correlation matrix of the factors # construct matrix from lower diagonal elements Rmat <- .5 * diag(Kmax) Rmat[lower.tri(Rmat)] <- R$mean Rmat <- Rmat + t(Rmat) rownames(Rmat) <- colnames(Rmat) <- paste0('f', 1:Kmax) # heatmap for active factors only p.Rmat <- make.heatmap(Rmat[acti, acti], title = 'correlation matrix of the factors', xlab = 'latent factors (active factors only)', ylab = '', show.val) ############################################################################## print(p.nfac) invisible(readline(prompt = "Press to show next graph...")) print(p.hnfac) invisible(readline(prompt = "Press to show next graph...")) if (what != 'hppm') { print(p.indic) invisible(readline(prompt = "Press to show next graph...")) } print(p.alpha) invisible(readline(prompt = "Press to show next graph...")) print(p.Rmat) } ################################################################################ make.heatmap <- function(x, title, xlab, ylab, show.val) { # prepare data xcol <- colnames(x) xrow <- rownames(x) dat <- data.frame(xvar = factor(rep(xcol, each = nrow(x)), levels = xcol), yvar = factor(rep(xrow, ncol(x)), levels = rev(xrow)), val = c(round(x, digits = 2))) # make heatmap p <- ggplot(dat, aes_string(x = 'xvar', y = 'yvar')) + geom_tile(aes_string(fill = 'val')) + scale_fill_gradient2(low = 'steelblue', mid = 'white', high = 'red', na.value = NA) # add title and labels p <- p + labs(title = title, x = xlab, y = ylab, fill = 'posterior\nmean') # adjust font sizes # p <- p + theme(axis.title = element_text(size=12), # axis.text = element_text(size=12), # plot.title = element_text(size=16), # legend.text = element_text(size=10)) # legend p <- p + guides(fill = guide_colorbar(barheight = unit(6, 'cm'))) # add values to heatmap? if (show.val) p <- p + geom_text(aes_string(label = 'val'), colour = 'white', na.rm = TRUE) return(p) } BayesFM/R/print.summary.befa.R0000644000176200001440000000544414142560501015615 0ustar liggesusers#' @export print.summary.befa <- function(x, ...) { cat('BEFA - Bayesian Exploratory Factor Analysis', 'Summary of posterior results\n', sep = '\n') args <- list(...) digits <- args$digits if (is.null(digits)) digits <- 3 cat('Maximum number of factors (Kmax) =', attr(x, 'Kmax'), '\n') cat('Identification restriction (Nid) =', attr(x, 'Nid'), '\n\n') cat('MCMC iterations =', attr(x, 'iter'), '\n') cat('burn-in period =', attr(x, 'burnin'), '\n\n') cat('Metropolis-Hastings acceptance rate =', round(x$MHacc, digits = 3)) cat('\n\n') what <- attr(x, 'what') hpd.prob <- attr(x, 'hpd.prob') if (what == 'hppm') { cat('-----------------------------------------------------------------', 'Indicator matrix\n', 'Dedicated structures visited by the sampler, with corresponding ', 'posterior probabilities and number of factors (K)\n', sep = '\n') cat(paste0('prob(', colnames(x$hppm$dedic), ') = ', sprintf('%.3f', x$hppm$prob), ', K = ', x$hppm$nfac), sep = '\n') cat('\n') print(x$hppm$dedic, print.gap = 3) cat('\n') } else { cat('Posterior frequency of number of latent factors:\n') freq <- sprintf('%3.2f%%', 100*x$nfac) nf <- sprintf('%2i', as.integer(names(x$nfac))) cat(paste(' K =', nf, ' ', freq), sep='\n') cat('\n') } # print MCMC summary results for model parameters cat('-----------------------------------------------------------------', 'Model parameters\n', sep = '\n') print.mcmc <- function(z, title) { res <- round(z, digits = digits) collab <- c('mean', 'sd', sprintf(paste0('[%', digits, '.0f%%'), 100*hpd.prob), sprintf(paste0('%', -(digits+1), 's]'), 'hpd')) if (ncol(z) == 5) collab <- c('dedic', collab) if (ncol(z) == 6) collab <- c('dedic', 'prob', collab) colnames(res) <- collab if (!missing(title)) cat(title, ':\n\n', sep='') print(as.matrix(res), print.gap = 3, na.print = ' ') cat('\n') } print.mcmc.all <- function(alpha, sigma, R, beta) { print.mcmc(alpha, title = 'Factor loadings') print.mcmc(sigma, title = 'Idiosyncratic variances') print.mcmc(R, title = 'Factor correlation matrix') if (!is.null(beta)) print.mcmc(beta, title = 'Regression coefficients') } if (what == 'hppm') { for (i in seq_along(x$hppm$prob)) { cat('-----------------------------------------------------------------\n') cat('Highest posterior probability model ', i, '\n\n', 'prob = ', round(x$hppm$prob[i], digits = 3), '\n', ' K = ', x$hppm$nfac[i], '\n\n', sep = '') print.mcmc.all(x$alpha[[i]], x$sigma[[i]], x$R[[i]], x$beta[[i]]) } } else { print.mcmc.all(x$alpha, x$sigma, x$R, x$beta) } } BayesFM/R/summary.simul.nfac.prior.R0000644000176200001440000000057114142560501016752 0ustar liggesusers#' @export summary.simul.nfac.prior <- function(object, ...) { Kmax <- attr(object, 'Kmax') comp.freq <- function(x) table(factor(x, levels = 1:Kmax))/length(x) acc <- lapply(object, '[[', 'acc') nfac <- lapply(object, '[[', 'nfac') nfac <- lapply(nfac, comp.freq) out <- list(nfac = nfac, acc = acc) class(out) <- 'summary.simul.nfac.prior' return(out) } BayesFM/R/print.simul.nfac.prior.R0000644000176200001440000000101314142560501016401 0ustar liggesusers#' @export print.simul.nfac.prior <- function(x, ...) { cat('sample from prior distribution of number of latent factors\n') cat('\ncall:\n ') print(attr(x, 'call')) cat('\n') cat('nvar =', attr(x, 'nvar'), '\n') cat('Kmax =', attr(x, 'Kmax'), '\n') cat('Nid =', attr(x, 'Nid'), '\n') cat('kappa =', attr(x, 'kappa'), '\n') cat('nrep =', attr(x, 'nrep'), '\n\n') cat('use summary() and plot() functions to summarize and plot', 'prior distribution of number of latent factors', sep = '\n') } BayesFM/R/utils.R0000644000176200001440000000261114142560501013222 0ustar liggesusers ### check if object is a formula is.formula <- function(x) return(class(x) == "formula") ### check if matrix is positive semidefinite is.pos.semidefinite.matrix <- function(x) { if (!is.matrix(x)) return(FALSE) if (!isSymmetric(x, tol = 10^-9)) return(FALSE) return(all(eigen(x, only.values = TRUE)$values >= 0)) } ### check if matrix can be inverted is.invertible.matrix <- function(x) { return(class(try(solve(x), silent = TRUE))[1L] == "matrix") } ### relabel indicators for dedicated factor model ### example: ### > d <- c(6, 6, 6, 2, 2, 2, 0, 0, 4, 4, 4) ### > relabel(d) [1] 1 1 1 2 2 2 0 0 3 3 3 relabel.dedic <- function(d) { u <- unique(d[d != 0]) t <- rep(0, max(d)) t[u] <- 1:length(u) d[d != 0] <- t[d] return(d) } ### count number of unique nonzero elements in x count.unique.nonzero <- function(x) return(length(unique(x[x != 0]))) ### convert matrix to list mat2list <- function(x, byrow = FALSE) { if (byrow) { y <- split(x, c(row(x))) names(y) <- rownames(x) } else { y <- split(x, c(col(x))) names(y) <- colnames(x) } return(y) } ### get maximum correlation (in absolute value) from correlation matrix get.maxcor <- function(x) max(abs(x[lower.tri(x)])) ### get minimum eigenvalue of symmetric matrix get.mineig <- function(x) min(eigen(x, symmetric = TRUE, only.values = TRUE)$values) BayesFM/R/simul.R.prior.R0000644000176200001440000000714214142560501014551 0ustar liggesusers#' #' Simulate prior distribution of factor correlation matrix #' #' This function produces a sample of correlation matrices drawn from their #' prior distribution induced in the identified version of the factor model, #' given the prior distribution specified on the corresponding covariance #' matrices of the factors in the expanded model. #' #' @inheritParams befa #' @param Kmax Maximum number of latent factors. #' @param nrep Number of Monte Carlo replications. #' #' @details Covariance matrices are sampled from the prior distribution in the #' expanded model, and transformed to produce the corresponding correlation #' matrices. See section 2.3.5 of CFSHP (p.36-37), as well as the details of #' the function \code{\link{befa}}. #' #' To compare several prior specifications, different values of the parameters #' \code{nu0} and \code{S0} can be specified. The function then simulates for #' each pair of these parameters. \code{nu0} and \code{S0} should therefore be #' scalars or vectors of same length. #' #' @return A list of length equal to the number of pairs of parameters #' \code{nu0} and \code{S0}, where each element of the list is an array of #' dimension (\code{Kmax}, \code{Kmax}, \code{nrep}) that contains the #' correlation matrices of the latent factors drawn from the prior. #' #' @author Rémi Piatek \email{remi.piatek@@gmail.com} #' #' @references G. Conti, S. Frühwirth-Schnatter, J.J. Heckman, R. Piatek (2014): #' ``Bayesian Exploratory Factor Analysis'', \emph{Journal of Econometrics}, #' 183(1), pages 31-57, \doi{10.1016/j.jeconom.2014.06.008}. #' #' @examples #' # partial reproduction of figure 1 in CFSHP (p.38) #' # note: use larger number of replications nrep to increase smoothness #' Kmax <- 10 #' Rsim <- simul.R.prior(Kmax, nu0 = Kmax + c(1, 2, 5), S0 = .5, nrep = 1000) #' summary(Rsim) #' plot(Rsim) #' #' @export simul.R.prior #' @import checkmate #' @importFrom stats rWishart rgamma simul.R.prior <- function(Kmax, nu0 = Kmax + 1, S0 = 1, HW.prior = TRUE, nrep = 10^5, verbose = TRUE) { # sanity checks checkArgs <- makeAssertCollection() assertInt(Kmax, lower = 1, add = checkArgs) assertNumeric(nu0, lower = Kmax, finite = TRUE, any.missing = FALSE, min.len = 1, add = checkArgs) assertNumeric(S0, lower = 0.000001, finite = TRUE, any.missing = FALSE, min.len = 1, add = checkArgs) if (length(nu0) == 1) nu0 <- rep(nu0, length(S0)) if (length(S0) == 1) S0 <- rep(S0, length(nu0)) if (length(nu0) != length(S0)) checkArgs$push('nu0 and S0 must be of same length') assertFlag(HW.prior, add = checkArgs) assertCount(nrep, positive = TRUE, add = checkArgs) assertFlag(verbose, add = checkArgs) reportAssertions(checkArgs) Rmat <- list() par <- unique(cbind(nu0, S0)) for (i in 1:nrow(par)) { nu0i <- par[i, 1] S0i <- par[i, 2] cat('simulating prior for nu0 =', nu0i, 'and S0 =', S0i, '\n') omg <- rWishart(nrep, df = nu0i, Sigma = diag(Kmax)) if (HW.prior) { nus <- nu0i - Kmax + 1 Sk <- replicate(Kmax, rgamma(nrep, shape = .5, rate = 1/(2 * nus * S0i))) Sk <- sqrt(1/Sk) omg <- lapply(seq(nrep), function(x) diag(Sk[x,]) %*% solve(omg[,,x]) %*% diag(Sk[x,])) } else { S0d <- sqrt(1/S0i) * diag(Kmax) omg <- lapply(seq(nrep), function(x) S0d %*% solve(omg[,,x]) %*% S0d) } omg <- lapply(omg, cov2cor) lab <- paste0('nu0 = ', nu0i, ', S0 = ', S0i) Rmat[[lab]] <- simplify2array(omg) } attr(Rmat, 'call') <- match.call() attr(Rmat, 'Kmax') <- Kmax attr(Rmat, 'nrep') <- nrep class(Rmat) <- 'simul.R.prior' return(Rmat) } BayesFM/R/print.summary.simul.R.prior.R0000644000176200001440000000067114142560501017400 0ustar liggesusers#' @export print.summary.simul.R.prior <- function(x, ...) { cat('prior distribution of correlation matrix of latent factors\n\n') cat('maximum correlation (in absolute value):\n\n') print(x$maxcor$stat, print.gap = 3) cat('\n') print(x$maxcor$quant, print.gap = 3) cat('\n') cat('minimum eigenvalue of correlation matrix:\n\n') print(x$mineig$stat, print.gap = 3) cat('\n') print(x$mineig$quant, print.gap = 3) } BayesFM/R/print.befa.R0000644000176200001440000000062214631161175014121 0ustar liggesusers#' @export print.befa <- function(x, ...) { if (!inherits(x, 'befa')) stop('object passed to print.befa should be of class befa') cat('BEFA output - Bayesian Exploratory Factor Analysis\n\n') cat('call:\n ') print(attr(x, 'call')) cat('\n') cat('posterior column switch:', attr(x, "post.column.switch"), '\n') cat('posterior sign switch: ', attr(x, "post.sign.switch"), '\n\n') } BayesFM/R/plot.simul.R.prior.R0000644000176200001440000000305114142560501015521 0ustar liggesusers#' @export #' @importFrom ggplot2 ggplot aes_string geom_density theme labs element_blank #' @importFrom ggplot2 ggplot_gtable ggplot_build #' @importFrom gridExtra grid.arrange arrangeGrob plot.simul.R.prior <- function(x, ...) { if (!is.list(x)) x <- as.list(x) nsim <- length(x) # function making individual plot plot.dens <- function(Rsim, FUN, xlab) { val <- lapply(Rsim, function(z) apply(z, 3, FUN)) val <- do.call(cbind, val) dat <- data.frame(val = c(val), lab = rep(colnames(val), each = nrow(val))) # make plot p <- ggplot(dat, aes_string(x = 'val', color = 'lab')) + geom_density(kernel = 'gaussian') + labs(x = xlab, y = 'prior density') + theme(legend.position = 'bottom', legend.direction = 'horizontal', legend.title = element_blank()) return(p) } # make plots plots <- list() plots$maxcor <- plot.dens(x, FUN = get.maxcor, xlab = 'max(|R|)') plots$mineig <- plot.dens(x, FUN = get.mineig, xlab = 'min(eigen(R))') # get common legend legend <- ggplot_gtable(ggplot_build(plots[[1]])) legid <- which(sapply(legend$grobs, function(p) p$name) == 'guide-box') legend <- legend$grobs[[legid]] # make plot grid.arrange(arrangeGrob(plots[[1]] + theme(legend.position = 'none'), plots[[2]] + theme(legend.position = 'none'), nrow = 1), legend, nrow = 2, heights = c(10, 1), top = 'correlation matrix of the latent factors') } BayesFM/R/simul.dedic.facmod.R0000644000176200001440000001740714142560501015523 0ustar liggesusers#' #' Generate synthetic data from a dedicated factor model #' #' This function simulates data from a dedicated factor model. The parameters of #' the model are either passed by the user or simulated by the function. #' #' @param N #' Number of observations in data set. #' @param dedic #' Vector of indicators. The number of manifest variables is equal to the #' length of this vector, and the number of factors is equal to the #' number of unique nonzero elements. Each integer element indicates on #' which latent factor the corresponding variable loads uniquely. #' @param alpha #' Vector of factor loadings, should be of same length as \code{dedic}. #' If missing, values are simulated (see details below). #' @param sigma #' Idiosyncratic variances, should be of same length as \code{dedic}. #' If missing, values are simulated (see details below). #' @param R #' Covariance matrix of the latent factors. #' If missing, values are simulated (see details below). #' @param R.corr #' If TRUE, covariance matrix \code{R} is rescaled to be a correlation #' matrix. #' @param max.corr #' Maximum correlation allowed between the latent factors. #' @param R.max.trial #' Maximum number of trials allowed to sample from the truncated #' distribution of the covariance matrix of the latent factors #' (accept/reject sampling scheme, to make sure \code{max.corr} is not #' exceeded). #' #' @details The function simulates data from the following dedicated factor #' model, for \eqn{i = 1, ..., N}: #' \deqn{Y_i = \alpha \theta_i + \epsilon_i} #' \deqn{\theta_i \sim \mathcal{N}(0, R)}{\theta_i ~ N(0, R)} #' \deqn{\epsilon_i \sim \mathcal{N}(0, \Sigma)}{\epsilon_i ~ N(0, \Sigma)} #' where the \eqn{K}-vector \eqn{\theta_i} contains the latent factors, and #' \eqn{\alpha} is the \eqn{(M \times K)}{(M*K)}-matrix of factor loadings. Each #' row \eqn{m} of \eqn{\alpha} contains only zeros, besides its element #' indicated by the \eqn{m}th element of \code{dedic} that is equal to the #' \eqn{m}th element of \code{alpha} (denoted \eqn{\alpha_m^\Delta} below). #' The \eqn{M}-vector \eqn{\epsilon_i} is the vector of error terms, with #' \eqn{\Sigma = diag(}\code{sigma}\eqn{)}. \eqn{M} is equal to the length of #' the vector \code{dedic}, and \eqn{K} is equal to the maximum value of this #' vector. #' #' Only \code{N} and \code{dedic} are required, all the other parameters can be #' missing, completely or partially. Missing values (\code{NA}) are #' independently sampled from the following distributions, for each manifest #' variable \eqn{m = 1, ..., M}: #' #' Factor loadings: #' \deqn{\alpha_m^\Delta = (-1)^{\phi_m}\sqrt{a_m}}{ #' \alpha_m^\Delta = (-1)^\phi_m\sqrt(a_m)} #' \deqn{\phi_m \sim \mathcal{B}er(0.5)}{\phi_m ~ Ber(0.5)} #' \deqn{a_m \sim \mathcal{U}nif (0.04, 0.64)}{a_m ~ Unif (0.04, 0.64)} #' #' Idiosyncratic variances: #' \deqn{\sigma^2_m \sim \mathcal{U}nif (0.2, 0.8)}{ #' \sigma^2_m ~ Unif (0.2, 0.8)} #' #' For the variables that do not load on any factors (i.e., for which the #' corresponding elements of \code{dedic} are equal to 0), it is specified that #' \eqn{\alpha_m^\Delta = 0} and \eqn{\sigma^2_m = 1}. #' #' Covariance matrix of the latent factors: #' \deqn{\Omega \sim \mathcal{I}nv-\mathcal{W}ishart(K+5, I_K)}{ #' \Omega ~ Inv-Wishart(K+5, I_K)} #' which is rescaled to be a correlation matrix if \code{R.corr = TRUE}: #' \deqn{R = \Lambda^{-1/2} \Omega \Lambda^{-1/2}}{ #' R = \Lambda^-1/2 \Omega \Lambda^-1/2} #' \deqn{\Lambda = diag(\Omega)} #' #' Note that the distribution of the covariance matrix is truncated such that #' all the off-diagonal elements of the implied correlation matrix \eqn{R} are #' below \code{max.corr} in absolute value. The truncation is also applied if #' the covariance matrix is used instead of the correlation matrix (i.e., if #' \code{R.corr = FALSE}). #' #' The distributions and the corresponding default values used to simulate the #' model parameters are specified as in the Monte Carlo study of CFSHP, see #' section 4.1 (p.43). #' #' @return The function returns a data frame with \code{N} observations #' simulated from the corresponding dedicated factor model. #' The parameters used to generate the data are saved as attributes: #' \code{dedic}, \code{alpha}, \code{sigma} and \code{R}. #' #' @author Rémi Piatek \email{remi.piatek@@gmail.com} #' #' @references #' G. Conti, S. Frühwirth-Schnatter, J.J. Heckman, #' R. Piatek (2014): ``Bayesian Exploratory Factor Analysis'', #' \emph{Journal of Econometrics}, 183(1), pages 31-57, #' \doi{10.1016/j.jeconom.2014.06.008}. #' #' @examples #' # generate 1000 observations from model with 4 factors and 20 variables #' # (5 variables loading on each factor) #' dat <- simul.dedic.facmod(N = 1000, dedic = rep(1:4, each = 5)) #' #' # generate data set with 5000 observations from the following model: #' dedic <- rep(1:3, each = 4) # 3 factors and 12 manifest variables #' alpha <- rep(c(1, NA, NA, NA), 3) # set first loading to 1 for each factor, #' # sample remaining loadings from default #' sigma <- rep(0.5, 12) # idiosyncratic variances all set to 0.5 #' R <- toeplitz(c(1, .6, .3)) # Toeplitz matrix #' dat <- simul.dedic.facmod(N = 5000, dedic, alpha, sigma, R) #' #' @export simul.dedic.facmod #' @import checkmate #' @importFrom stats rWishart rnorm runif cov2cor simul.dedic.facmod <- function(N, dedic, alpha, sigma, R, R.corr = TRUE, max.corr = 0.85, R.max.trial = 1000) { # sanity checks for N and dedic, relabel appropriately assertInt(N, lower = 1) assertIntegerish(dedic, lower = 0, any.missing = FALSE, min.len = 3) dedic <- relabel.dedic(dedic) nvar <- length(dedic) nfac <- max(dedic) # factor loading matrix if (missing(alpha)) { alpha <- rep(NA, nvar) } assertNumeric(alpha, finite = TRUE, len = nvar) nna <- sum(is.na(alpha)) if (nna > 0) { alpha[is.na(alpha)] <- sample(c(-1, 1), nna, replace = TRUE) * sqrt(runif(nna, min = 0.04, max = 0.64)) } alpha.mat <- matrix(0, nvar, nfac) for (i in 1:nvar) { if (dedic[i] > 0) alpha.mat[i, dedic[i]] <- alpha[i] } # error terms if (missing(sigma)) sigma <- rep(NA, nvar) assertNumeric(sigma, lower = 0.001, finite = TRUE, len = nvar) nna <- sum(is.na(sigma)) if (nna > 0) sigma[is.na(sigma)] <- runif(nna, min = 0.2, max = 0.8) sigma[dedic == 0] <- 1 eps <- matrix(rnorm(N * nvar), N, nvar) %*% diag(sqrt(sigma)) # latent factors assertLogical(R.corr, len = 1, any.missing = FALSE) assertNumber(max.corr, lower = 0, upper = 1) assertInt(R.max.trial, lower = 1, upper = 10^6) if (missing(R)) { for (i in 1:R.max.trial) { Omega <- rWishart(n = 1, df = nfac + 5, Sigma = diag(nfac)) R <- cov2cor(Omega[, , 1]) rho <- max(abs(R[lower.tri(R)])) if (rho <= max.corr) break } if (rho > max.corr) stop("R.max.trial exceeded, could not sample R") if (!R.corr) R <- Omega } else { if (!is.pos.semidefinite.matrix(R)) stop("R is not positive semidefinite.") if (R.corr & !all(diag(R) == 1)) stop("R is not a correlation matrix") } theta <- matrix(rnorm(N * nfac), N, nfac) %*% chol(R) # manifest variables Y <- theta %*% t(alpha.mat) + eps colnames(Y) <- paste0("Y", 1:nvar) rownames(Y) <- 1:N # label parameters names(dedic) <- paste0("Y", 1:nvar) names(alpha) <- paste0("alpha:", 1:nvar) names(sigma) <- paste0("sigma:", 1:nvar) rownames(R) <- colnames(R) <- paste0("R:", 1:nfac) # return simulated data output <- as.data.frame(Y) attr(output, "dedic") <- dedic attr(output, "alpha") <- alpha attr(output, "sigma") <- sigma attr(output, "R") <- R return(output) } BayesFM/R/extract.data.R0000644000176200001440000000532414142560501014450 0ustar liggesusers#' @importFrom stats complete.cases cor terms extract.data <- function(model, data) { errmsg <- warnmsg <- NULL # get equation terms neq <- length(model) all.terms <- lapply(model, terms) # which equations have a manifest variable? resp <- sapply(all.terms, attr, 'response') resp <- as.logical(resp) # manifest variables allY <- sapply(lapply(model, all.vars), '[', 1) Ylab <- unique(allY[resp]) nY <- length(Ylab) allY[!resp] <- NA # intercept terms const <- sapply(all.terms, attr, 'intercept') const <- as.logical(const) # covariates allX <- lapply(all.terms, attr, 'term.labels') Xlab <- unique(unlist(allX)) Xlab <- c('(Intercept)', Xlab) nX <- length(Xlab) YXloc <- matrix(FALSE, nY, nX, dimnames = list(Ylab, Xlab)) for (i in 1:neq) { if (is.na(allY[i])) { YXloc[, unlist(allX[i])] <- TRUE YXloc[, '(Intercept)'] <- const[i] } else { YXloc[allY[i], unlist(allX[i])] <- TRUE YXloc[allY[i], '(Intercept)'] <- const[i] } } # check that all variables are in data frame YXlab <- unique(unlist(c(Ylab, Xlab))) YXlab <- YXlab[YXlab != '(Intercept)'] # no error message for intercept term indat <- YXlab %in% names(data) if (any(!indat)) { errmsg <- paste('following variables not in data:\n ', paste(YXlab[!indat], collapse = ', ')) return(list(errmsg)) } YXdata <- data[YXlab] nobs <- nrow(YXdata) YXdata[["(Intercept)"]] <- 1 # add vector of ones for intercept terms # type of manifest variables Ytype <- sapply(YXdata[Ylab], typeof) # discard missing values in covariates nomiss <- complete.cases(YXdata[Xlab]) YXdata <- YXdata[nomiss, ] if (!all(nomiss)) { warnmsg <- paste(sum(!nomiss), 'observations discarded because of NAs', 'in at least one covariate') nobs <- nobs - sum(!nomiss) } # check for multicollinearity in covariates specified in each equation Xcor <- cor(data[Xlab[Xlab != '(Intercept)']]) # exclude intercept for (i in 1:nY) { Xcori <- Xcor[YXloc[i, -1], YXloc[i, -1]] Xcori <- Xcori[lower.tri(Xcori)] if (any(abs(Xcori - 1) < 1e-12)) { errmsg <- c(errmsg, paste('perfect multicollinearity between covariates', 'of manifest variable', Ylab[i])) } else if (any(abs(Xcori) > 0.95)) { warnmsg <- c(warnmsg, paste('possible multicollinearity problem between', 'covariates of manifest variable', Ylab[i])) } } # return return(list(Ytype = Ytype, Yobs = as.matrix(YXdata[Ylab]), Xobs = as.matrix(YXdata[Xlab]), YXloc = YXloc, errmsg = errmsg, warnmsg = warnmsg)) } BayesFM/src/0000755000176200001440000000000014631253270012332 5ustar liggesusersBayesFM/src/indicators_dedic.f900000644000176200001440000002300414631253115016136 0ustar liggesusersmodule indicators_dedic_class use global use probability, only : runif implicit none !----------------------------------------------------------------------------- type :: ratio_marglik logical :: is_categorical ! TRUE = categorical, FALSE = continuous integer :: nfac real(r8) :: alpha_prec0 real(r8) :: prec_scale0 real(r8) :: prec_shape end type ratio_marglik !----------------------------------------------------------------------------- type :: param_tau logical :: use_alt ! TRUE = use alternative parametrization integer :: nmeas integer :: nfac real(r8) :: xi0 real(r8) :: kappa0_xi0 real(r8), allocatable :: kappa0(:) real(r8) :: skappa0 real(r8), allocatable :: atau(:,:) real(r8), allocatable :: btau(:) real(r8), allocatable :: stau(:) end type param_tau !----------------------------------------------------------------------------- type :: indic_dedic integer :: nmeas integer :: nobs integer :: nfac integer, allocatable :: group(:) integer, allocatable :: ngroup(:) logical, allocatable :: active(:) ! TRUE for active factors integer :: K1 ! number of active factors integer :: K2 ! number of inactive factors type(ratio_marglik), allocatable :: mlik(:) type(param_tau) :: ltau ! back up integer, allocatable :: group_bak(:) integer, allocatable :: ngroup_bak(:) end type indic_dedic contains !----------------------------------------------------------------------------- subroutine init_ratio_marglik(this, is_categorical, nobs, nfac, prior) implicit none type(ratio_marglik), intent(inout) :: this logical, intent(in) :: is_categorical integer, intent(in) :: nobs, nfac real(r8), intent(in) :: prior(3) this%is_categorical = is_categorical this%nfac = nfac this%alpha_prec0 = prior(1) if(.not. this%is_categorical) then this%prec_scale0 = prior(3) this%prec_shape = prior(2) + .5_r8*dble(nobs) end if end subroutine init_ratio_marglik !----------------------------------------------------------------------------- function get_ratio_marglik(this, Y2, fac2, Yfac2) result(lmlik) implicit none type(ratio_marglik), intent(inout) :: this real(r8), intent(in) :: Y2, fac2(this%nfac), Yfac2(this%nfac) real(r8) :: Pm(this%nfac), Qm(this%nfac), Rm(this%nfac) real(r8) :: CNn, lmlik(0:this%nfac, 0:this%nfac) if(this%is_categorical) then Pm = 1._r8 + fac2/this%alpha_prec0 Qm = .5_r8*Yfac2/(this%alpha_prec0+fac2) Rm = -.5_r8*log(Pm) + Qm lmlik(0, 1:) = Rm else Pm = 1._r8 + fac2/this%alpha_prec0 Qm = .5_r8*Yfac2/(this%alpha_prec0+fac2) CNn = this%prec_scale0 + .5_r8*Y2 Rm = -.5_r8*log(Pm) - this%prec_shape*log(CNn - Qm) lmlik(0, 1:) = Rm + this%prec_shape*log(CNn) end if lmlik(0,0) = 0._r8 lmlik(1:, 0) = -lmlik(0, 1:) lmlik(1:,1:) = spread(Rm, dim=1, ncopies=this%nfac) & - spread(Rm, dim=2, ncopies=this%nfac) end function get_ratio_marglik !----------------------------------------------------------------------------- subroutine init_param_tau(this, use_alt, nmeas, nfac, prior) implicit none type(param_tau), intent(out) :: this logical, intent(in) :: use_alt integer, intent(in) :: nmeas, nfac real(r8), intent(in) :: prior(0:nfac+1) integer :: j, k this%use_alt = use_alt this%nmeas = nmeas this%nfac = nfac allocate(this%kappa0(0:this%nfac)) this%xi0 = prior(0) this%kappa0 = prior(1:nfac+1) this%skappa0 = sum(this%kappa0(1:)) if(this%use_alt) then this%kappa0_xi0 = log(this%kappa0(0)) - log(this%xi0) end if ! tables to avoid recomputing log function at each MCMC iteration allocate(this%atau(0:nmeas, 0:nfac)) allocate(this%btau(0:nmeas)) allocate(this%stau(0:nmeas)) do j = 0, nmeas do k = 0, nfac this%atau(j,k) = log(dble(j) + this%kappa0(k)) end do end do do j = 0, nmeas this%btau(j) = log(dble(j) + this%xi0) this%stau(j) = log(dble(j) + this%skappa0) end do end subroutine init_param_tau !----------------------------------------------------------------------------- function get_param_tau(this, kold, ngroup) result(ltau) implicit none type(param_tau), intent(inout) :: this integer, intent(in) :: kold, ngroup(this%nfac) real(r8) :: ltau(0:this%nfac, 0:this%nfac) real(r8) :: lngk(this%nfac) integer :: ng(this%nfac) integer :: k, sng ng = ngroup if(kold > 0) ng(kold) = ng(kold) - 1 sng = sum(ng) do k = 1, this%nfac lngk(k) = this%atau(ng(k), k) end do ltau(0, 0) = 0._r8 ltau(1:, 1:) = spread(lngk, dim=1, ncopies=this%nfac) & - spread(lngk, dim=2, ncopies=this%nfac) if(this%use_alt) then ltau(1:, 0) = this%stau(sng) - lngk + this%kappa0_xi0 else ltau(1:, 0) = this%atau(this%nmeas-sng-1, 0) & + this%stau(sng) & - this%btau(sng) & - lngk end if ltau(0, 1:) = -ltau(1:, 0) end function get_param_tau !----------------------------------------------------------------------------- subroutine init_indic_dedic(this, nobs, nmeas, nfac, Ycat, prior, start) implicit none type(indic_dedic), intent(out) :: this integer, intent(in) :: nobs integer, intent(in) :: nmeas integer, intent(in) :: nfac integer, intent(in) :: Ycat(nmeas) real(r8), intent(in) :: prior(0:3*nmeas+nfac+2) integer, intent(in) :: start(nmeas) integer :: j, k real(r8) :: prior_marglik(nmeas, 3) allocate(this%group(nmeas)) allocate(this%ngroup(nfac)) allocate(this%active(nfac)) allocate(this%group_bak(nmeas)) allocate(this%ngroup_bak(nfac)) this%nmeas = nmeas this%nobs = nobs this%nfac = nfac this%group = start this%group_bak = start do k = 1, this%nfac this%ngroup(k) = count(this%group == k) end do this%ngroup_bak = this%ngroup this%active = this%ngroup > 0 this%K1 = count(this%active) this%K2 = nfac - this%K1 prior_marglik = reshape(prior(1:3*nmeas), shape=[nmeas,3]) allocate(this%mlik(nmeas)) do j = 1, nmeas call init_ratio_marglik(this%mlik(j), Ycat(j) > 0, nobs, nfac, & prior_marglik(j,:)) end do if(int(prior(0)) == 0) then call init_param_tau(this%ltau, .false., nmeas, nfac, prior(3*nmeas+1:)) else call init_param_tau(this%ltau, .true., nmeas, nfac, prior(3*nmeas+1:)) end if end subroutine init_indic_dedic !----------------------------------------------------------------------------- subroutine update_indic_dedic(this, Yaux, Fac) implicit none type(indic_dedic), intent(inout) :: this real(r8), intent(in) :: Yaux(this%nobs, this%nmeas) real(r8), intent(in) :: Fac(this%nobs, this%nfac) real(r8) :: Fac2(this%nfac) real(r8) :: FacYXb2(this%nfac, this%nmeas) real(r8) :: YXb2(this%nmeas) real(r8) :: prob_sub(0:this%nfac, 0:this%nfac) real(r8) :: prob(0:this%nfac) real(r8) :: sprob, e integer :: j, k, kold ! cross-products used to compute posterior log odds Fac2 = sum(Fac**2, dim=1) YXb2 = sum(Yaux**2, dim=1) FacYXb2 = matmul(transpose(Fac), Yaux)**2 do j = 1, this%nmeas ! compute posterior probabilities kold = this%group(j) prob_sub = get_ratio_marglik(this%mlik(j), YXb2(j), Fac2, FacYXb2(:,j)) & + get_param_tau(this%ltau, kold, this%ngroup) prob = 1._r8/sum(exp(prob_sub), dim=2) ! sample indicator e = runif() sprob = 0._r8 do k = 0, this%nfac sprob = sprob + prob(k) if(e <= sprob) then this%group(j) = k if(kold > 0) this%ngroup(kold) = this%ngroup(kold) - 1 if(k > 0) this%ngroup(k) = this%ngroup(k) + 1 exit end if end do end do ! update indicators for active factors this%active = this%ngroup > 0 this%K1 = count(this%active) this%K2 = this%nfac - this%K1 end subroutine update_indic_dedic !----------------------------------------------------------------------------- subroutine backup_indic_dedic(this) implicit none type(indic_dedic), intent(inout) :: this this%group_bak = this%group this%ngroup_bak = this%ngroup end subroutine backup_indic_dedic !----------------------------------------------------------------------------- subroutine restore_indic_dedic(this) implicit none type(indic_dedic), intent(inout) :: this this%group = this%group_bak this%ngroup = this%ngroup_bak end subroutine restore_indic_dedic end module indicators_dedic_class BayesFM/src/BayesFM-win.def0000644000176200001440000000005413742567211015077 0ustar liggesusersLIBRARY BayesFM.dll EXPORTS R_init_BayesFM BayesFM/src/factor_normal_block.f900000644000176200001440000001473614631253115016663 0ustar liggesusersmodule factor_normal_block_class use global use indicators_dedic_class use covmat_block_invwishart_class use probability, only : rnorm use matrix, only : matinv, chol implicit none type :: factor_normal_block integer :: nobs integer :: nmeas integer :: nfac real(r8), allocatable :: theta(:,:) integer, allocatable :: indi(:) integer, allocatable :: mi(:) ! back up real(r8), allocatable :: theta_bak(:,:) end type factor_normal_block contains !----------------------------------------------------------------------------- subroutine init_factor_normal_block(this, nobs, nmeas, nfac, start) implicit none type(factor_normal_block), intent(out) :: this integer, intent(in) :: nobs integer, intent(in) :: nmeas integer, intent(in) :: nfac real(r8), intent(in) :: start(nobs,nfac) integer :: i this%nobs = nobs this%nmeas = nmeas this%nfac = nfac allocate(this%theta(nobs, nfac)) allocate(this%theta_bak(nobs, nfac)) this%theta = start this%theta_bak = start allocate(this%indi(nfac)) allocate(this%mi(nmeas)) this%indi = (/(i, i=1, this%nfac)/) this%mi = (/(i, i=1, this%nmeas)/) end subroutine init_factor_normal_block !----------------------------------------------------------------------------- subroutine update_factor_normal_block_acti(this, Y, alpha, dedic, idioprec, fdist) implicit none type(factor_normal_block), intent(inout) :: this real(r8), intent(in) :: Y(this%nobs,this%nmeas) real(r8), intent(in) :: idioprec(this%nmeas) real(r8), intent(in) :: alpha(this%nmeas) type(indic_dedic), intent(in) :: dedic type(covmat_block_invwishart), intent(in) :: fdist logical :: acti(this%nfac) integer :: actind(dedic%K1) real(r8) :: mean_post(this%nobs,dedic%K1) real(r8) :: var_post(dedic%K1,dedic%K1) integer :: i, k if(dedic%K1 == 0) return ! no active factors to sample acti = dedic%active actind = pack(this%indi, acti) ! compute posterior moments for active factors var_post = matinv(fdist%var(actind,actind)) do k = 1, dedic%K1 var_post(k,k) = var_post(k,k) & + sum(idioprec*(alpha**2), mask=(dedic%group==actind(k))) mean_post(:,k) = matmul(Y(:, pack(this%mi, dedic%group==actind(k))), & pack(idioprec*alpha, dedic%group==actind(k))) end do var_post = matinv(var_post) ! sample active thiss factors do k = 1, this%nfac if(.not.acti(k)) cycle do i = 1, this%nobs this%theta(i,k) = rnorm() end do end do this%theta(:,actind) = matmul(mean_post, var_post) & + matmul(this%theta(:,actind), & transpose(chol(var_post))) end subroutine update_factor_normal_block_acti !----------------------------------------------------------------------------- subroutine update_factor_normal_block_inacti(this, fdist, dedic) implicit none type(factor_normal_block), intent(inout) :: this type(covmat_block_invwishart), intent(in) :: fdist type(indic_dedic), intent(in) :: dedic integer :: actind(dedic%K1) integer :: inactind(dedic%K2) integer :: i, k if(dedic%K2 == 0) return ! no inactive factors to sample actind = pack(this%indi, dedic%active) inactind = pack(this%indi, .not.dedic%active) do k = 1, dedic%K2 do i = 1, this%nobs this%theta(i, inactind(k)) = rnorm() end do end do if(dedic%K1 == 0) then this%theta = matmul(this%theta, transpose(fdist%L221)) else this%theta(:,inactind) = matmul(this%theta(:,inactind), & transpose(fdist%L221)) & + matmul(this%theta(:,actind), fdist%G1112) end if end subroutine update_factor_normal_block_inacti !----------------------------------------------------------------------------- subroutine update_factor_normal_block(this, Y, alpha, dedic, idioprec, fdist) implicit none type(factor_normal_block), intent(inout) :: this real(r8), intent(in) :: Y(this%nobs, this%nmeas) real(r8), intent(in) :: idioprec(this%nmeas) real(r8), intent(in) :: alpha(this%nmeas) integer, intent(in) :: dedic(this%nmeas) type(covmat_block_invwishart), intent(in) :: fdist real(r8) :: ap2(this%nmeas) real(r8) :: ing(this%nmeas, this%nfac) real(r8) :: mean_post(this%nobs, this%nfac) real(r8) :: var_post(this%nfac, this%nfac) integer :: i, j, k ! posterior covariance matrix var_post = fdist%prec ap2 = idioprec * (alpha**2) do k = 1, this%nfac var_post(k,k) = var_post(k,k) + sum(ap2, dedic==k) end do var_post = matinv(var_post) ! posterior mean do j = 1, this%nmeas if(dedic(j) == 0) then ing(j,:) = 0._r8 else do k = 1, this%nfac ing(j,k) = var_post(dedic(j), k) * alpha(j) * idioprec(j) end do end if end do mean_post = matmul(Y, ing) ! sample factors do k = 1, this%nfac do i = 1, this%nobs this%theta(i,k) = rnorm() end do end do this%theta = mean_post + matmul(this%theta, transpose(chol(var_post))) end subroutine update_factor_normal_block !----------------------------------------------------------------------------- subroutine backup_factor_normal_block(this) implicit none type(factor_normal_block), intent(inout) :: this this%theta_bak = this%theta end subroutine backup_factor_normal_block !----------------------------------------------------------------------------- subroutine restore_factor_normal_block(this) implicit none type(factor_normal_block), intent(inout):: this this%theta = this%theta_bak end subroutine restore_factor_normal_block end module factor_normal_block_class BayesFM/src/factor_normal.f900000644000176200001440000000607714631253115015510 0ustar liggesusersmodule factor_normal_class use global use covmat_block_invwishart_class use probability, only : rnorm use matrix, only : matinv, chol implicit none type :: factor_normal integer :: nobs integer :: nmeas integer :: nfac real(r8), allocatable :: theta(:,:) ! back up real(r8), allocatable :: theta_bak(:,:) end type factor_normal contains !----------------------------------------------------------------------------- subroutine init_factor_normal(this, nobs, nmeas, nfac, start) implicit none type(factor_normal), intent(out) :: this integer, intent(in) :: nobs integer, intent(in) :: nmeas integer, intent(in) :: nfac real(r8), intent(in) :: start(nobs,nfac) this%nobs = nobs this%nmeas = nmeas this%nfac = nfac allocate(this%theta(nobs, nfac)) allocate(this%theta_bak(nobs, nfac)) this%theta = start this%theta_bak = start end subroutine init_factor_normal !----------------------------------------------------------------------------- subroutine update_factor_normal(this, Y, alpha, dedic, idioprec, fdist) implicit none type(factor_normal), intent(inout) :: this real(r8), intent(in) :: Y(this%nobs, this%nmeas) real(r8), intent(in) :: idioprec(this%nmeas) real(r8), intent(in) :: alpha(this%nmeas) integer, intent(in) :: dedic(this%nmeas) type(covmat_block_invwishart), intent(in) :: fdist real(r8) :: ap2(this%nmeas) real(r8) :: ing(this%nmeas, this%nfac) real(r8) :: mean_post(this%nobs, this%nfac) real(r8) :: var_post(this%nfac, this%nfac) integer :: i, j, k ! posterior covariance matrix var_post = fdist%prec ap2 = idioprec * (alpha**2) do k = 1, this%nfac var_post(k,k) = var_post(k,k) + sum(ap2, dedic==k) end do var_post = matinv(var_post) ! posterior mean do j = 1, this%nmeas if(dedic(j) == 0) then ing(j,:) = 0._r8 else do k = 1, this%nfac ing(j,k) = var_post(dedic(j), k) * alpha(j) * idioprec(j) end do end if end do mean_post = matmul(Y, ing) ! sample factors do k = 1, this%nfac do i = 1, this%nobs this%theta(i,k) = rnorm() end do end do this%theta = mean_post + matmul(this%theta, transpose(chol(var_post))) end subroutine update_factor_normal !----------------------------------------------------------------------------- subroutine backup_factor_normal(this) implicit none type(factor_normal), intent(inout):: this this%theta_bak = this%theta end subroutine backup_factor_normal !----------------------------------------------------------------------------- subroutine restore_factor_normal(this) implicit none type(factor_normal), intent(inout):: this this%theta = this%theta_bak end subroutine restore_factor_normal end module factor_normal_class BayesFM/src/loading_idioprec.f900000644000176200001440000000711114631253115016143 0ustar liggesusersmodule loading_idioprec_class use global use probability, only : rnorm, rgamma implicit none type :: loading_idioprec logical :: is_categorical ! FALSE if continuous case, TRUE if categorical real(r8) :: alpha ! factor loading real(r8) :: alpha_mu0 ! prior: real(r8) :: alpha_prec0 ! alpha ~ N(alpha_mu0, sig2/alpha_prec0) real(r8) :: var ! idiosyncratic variance real(r8) :: prec ! idiosyncratic precision real(r8) :: prec_a0 ! prior: real(r8) :: prec_b0 ! sig2 ~ IGamma(prec_a0, prec_b0) real(r8) :: prec_a_post ! posterior shape for prec ! back up values real(r8) :: alpha_bak real(r8) :: var_bak real(r8) :: prec_bak end type loading_idioprec contains !----------------------------------------------------------------------------- subroutine init_loading_idioprec(this, nobs, is_categorical, prior, start) implicit none type(loading_idioprec), intent(out) :: this integer, intent(in) :: nobs logical, intent(in) :: is_categorical real(r8), intent(in) :: prior(3) real(r8), intent(in) :: start(2) this%is_categorical = is_categorical this%alpha_mu0 = 0._r8 this%alpha_prec0 = prior(1) this%prec_a0 = prior(2) this%prec_b0 = prior(3) this%prec_a_post = this%prec_a0 + .5_r8*nobs this%alpha = start(1) this%var = start(2) this%prec = 1._r8/this%var this%alpha_bak = this%alpha this%var_bak = this%var this%prec_bak = this%prec end subroutine init_loading_idioprec !----------------------------------------------------------------------------- subroutine update_loading_idioprec(this, Yaux, dedic, fac) implicit none type(loading_idioprec), intent(inout) :: this real(r8), intent(in) :: Yaux(:) integer, intent(in) :: dedic real(r8), intent(in) :: fac(:,:) real(r8) :: aN, AAN, prec_b_post !----- 'null model' if(dedic == 0) then if(this%is_categorical) return ! nothing to do in categorical case ! sample idiosyncratic precision in continuous case prec_b_post = this%prec_b0 + .5_r8*sum(Yaux**2) this%prec = rgamma(this%prec_a_post, 1._r8/prec_b_post) this%var = 1._r8/this%prec !----- general case else aN = dot_product(Yaux, fac(:, dedic)) AAN = 1._r8/(sum(fac(:, dedic)**2) + this%alpha_prec0) if(.not.this%is_categorical) then ! sample precision in continuous case prec_b_post = this%prec_b0 + .5_r8*(sum(Yaux**2) - AAN*(aN**2)) this%prec = rgamma(this%prec_a_post, 1._r8/prec_b_post) this%var = 1._r8/this%prec end if this%alpha = rnorm(AAn*aN, AAN*this%var) end if end subroutine update_loading_idioprec !----------------------------------------------------------------------------- subroutine backup_loading_idioprec(this) implicit none type(loading_idioprec), intent(inout) :: this this%alpha_bak = this%alpha this%var_bak = this%var this%prec_bak = this%prec end subroutine backup_loading_idioprec !----------------------------------------------------------------------------- subroutine restore_loading_idioprec(this) implicit none type(loading_idioprec), intent(inout) :: this this%alpha = this%alpha_bak this%var = this%var_bak this%prec = this%prec_bak end subroutine restore_loading_idioprec end module loading_idioprec_class BayesFM/src/covmat_block_invwishart.f900000644000176200001440000001627314631253115017602 0ustar liggesusersmodule covmat_block_invwishart_class use global use indicators_dedic_class use matrix, only : crossprod, matinv, chol use probability, only : rnorm, rgamma, rinvwishart implicit none type :: covmat_block_invwishart logical :: use_HuangWand integer :: nfac integer :: npar real(r8), allocatable :: prec(:,:) real(r8), allocatable :: var(:,:) logical, allocatable :: var_mask(:,:) ! mask for lower triangular elements real(r8) :: nu0 ! prior in expanded model: real(r8), allocatable :: S0(:) ! var ~ IWish(nu0, diag(S0)) real(r8) :: df_post real(r8), allocatable :: L221(:,:) ! ingredients used to sample real(r8), allocatable :: G1112(:,:) ! inactive factors later integer, allocatable :: ind(:) ! Huang-Wand real(r8), allocatable :: A2k(:) real(r8) :: nus real(r8) :: Rmat_b_shape ! back up real(r8), allocatable :: var_bak(:,:) real(r8), allocatable :: prec_bak(:,:) end type covmat_block_invwishart contains !----------------------------------------------------------------------------- subroutine init_covmat_block_invwishart(this, nobs, nfac, use_HuangWand, & prior, start) implicit none type(covmat_block_invwishart), intent(out) :: this integer, intent(in) :: nobs integer, intent(in) :: nfac logical, intent(in) :: use_HuangWand real(r8), intent(in) :: prior(1:nfac+1) real(r8), intent(in) :: start(nfac, nfac) integer :: i, j this%use_HuangWand = use_HuangWand allocate(this%prec(nfac, nfac)) allocate(this%var(nfac, nfac)) allocate(this%var_mask(nfac, nfac)) allocate(this%S0(nfac)) allocate(this%var_bak(nfac, nfac)) allocate(this%prec_bak(nfac, nfac)) this%nfac = nfac this%npar = nfac*(nfac-1)/2 ! mask for lower triangular elements this%var_mask = .false. do i = 1, nfac do j = 1, nfac if(j < i) then this%var_mask(i,j) = .true. end if end do end do ! starting values this%var = start this%prec = matinv(this%var) this%var_bak = start this%prec_bak = this%prec ! prior this%nu0 = prior(1) this%S0 = prior(2:) this%df_post = this%nu0 + dble(nobs) ! additional parameters for Huang-wand prior if(this%use_HuangWand) then allocate(this%A2k(nfac)) this%A2k = prior(2:) this%nus = this%nu0 - this%nfac + 1._r8 this%Rmat_b_shape = .5_r8*(this%nu0 + 1._r8) end if ! factor indicators 1, ..., nfac allocate(this%ind(nfac)) this%ind = (/ (i, i=1, nfac) /) end subroutine init_covmat_block_invwishart !----------------------------------------------------------------------------- subroutine update_covmat_block_invwishart(this, fac, dedic) implicit none type(covmat_block_invwishart), intent(inout) :: this real(r8), dimension(:,:), intent(in) :: fac type(indic_dedic), intent(in) :: dedic integer, dimension(:), allocatable :: acti, inacti real(r8), dimension(:,:), allocatable :: S_post, G221, G12 real(r8) :: df real(r8) :: Rmat_b_rate integer :: K1, K2, k, l K1 = dedic%K1 ! active factors K2 = dedic%K2 ! inactive factors !----- update scale parameters for Huang-Wand prior if(this%use_HuangWand) then do k = 1, this%nfac Rmat_b_rate = .5_r8*(this%prec(k,k) + 1._r8/(this%nus*this%A2k(k))) this%S0(k) = rgamma(this%Rmat_b_shape, 1._r8/Rmat_b_rate) end do end if !----- sample submatrix for active factors if(K1 > 0) then if(allocated(acti)) deallocate(acti) if(allocated(S_post)) deallocate(S_post) allocate(acti(K1)) allocate(S_post(K1, K1)) acti = pack(this%ind, dedic%active) S_post = crossprod(fac(:,acti)) do k = 1, K1 S_post(k,k) = S_post(k,k) + this%S0(acti(k)) end do df = this%df_post - dble(K2) this%var(acti,acti) = rinvwishart(df, S_post) end if !----- sample remaining block corresponding to inactive factors if(K1 == 0) then ! only inactive factors, sample matrix from prior if(allocated(this%L221)) deallocate(this%L221) if(allocated(S_post)) deallocate(S_post) allocate(this%L221(K2,K2)) allocate(S_post(K2,K2)) S_post = 0._r8 do k = 1, K2 S_post(k,k) = this%S0(k) end do this%var = rinvwishart(this%nu0, S_post) this%L221 = chol(this%var) else if(K2 > 0) then if(allocated(this%L221)) deallocate(this%L221) if(allocated(this%G1112)) deallocate(this%G1112) if(allocated(inacti)) deallocate(inacti) if(allocated(S_post)) deallocate(S_post) if(allocated(G221)) deallocate(G221) if(allocated(G12)) deallocate(G12) allocate(this%L221(K2,K2)) allocate(this%G1112(K1,K2)) allocate(inacti(K2)) allocate(S_post(K2,K2)) allocate(G221(K2,K2)) allocate(G12(K1,K2)) inacti = pack(this%ind, mask=.not.dedic%active) S_post = 0._r8 do k = 1, K2 S_post(k,k) = this%S0(inacti(k)) end do G221 = rinvwishart(this%nu0, S_post) ! G221 = Omega_22.1 this%L221 = chol(G221) do k = 1, K1 ! G1112 = inv(Omega_11) * Omega_12 do l = 1, K2 this%G1112(k,l) = rnorm() end do end do this%G1112 = matmul(this%G1112, transpose(this%L221)) do k = 1, K1 this%G1112(k,:) = this%G1112(k,:)/sqrt(this%S0(acti(k))) end do G12 = matmul(this%var(acti,acti), this%G1112) ! G12 = Omega_12 this%var(acti, inacti) = G12 this%var(inacti, acti) = transpose(G12) this%var(inacti, inacti) = G221 + matmul(transpose(G12), this%G1112) end if this%prec = matinv(this%var) end subroutine update_covmat_block_invwishart !----------------------------------------------------------------------------- function get_covmat_block_invwishart(this) result(par) implicit none type(covmat_block_invwishart) :: this real(r8) :: par(this%npar) par = pack(this%var, this%var_mask) end function get_covmat_block_invwishart !----------------------------------------------------------------------------- subroutine backup_covmat_block_invwishart(this) implicit none type(covmat_block_invwishart), intent(inout) :: this this%var_bak = this%var this%prec_bak = this%prec end subroutine backup_covmat_block_invwishart !----------------------------------------------------------------------------- subroutine restore_covmat_block_invwishart(this) implicit none type(covmat_block_invwishart), intent(inout) :: this this%var = this%var_bak this%prec = this%prec_bak end subroutine restore_covmat_block_invwishart end module covmat_block_invwishart_class BayesFM/src/matrix.f900000644000176200001440000001503314631253115014156 0ustar liggesusersmodule matrix use global implicit none private public :: trace public :: chol public :: det public :: matinv public :: solvl public :: solvu public :: crossprod public :: outerprod interface outerprod module procedure outerprod1 module procedure outerprod2 end interface outerprod contains !----------------------------------------------------------------------------- ! returns the trace of the matrix A real(r8) function trace(A) result(t) implicit none real(r8), intent(in) :: A(:,:) integer :: i, n n = size(A, 1) if(n /= size(A, 2)) then call rexit('### ERROR: trace only for square matrices') end if t = 0._r8 do i = 1, n t = t + A(i,i) end do end function trace !----------------------------------------------------------------------------- ! Cholesky decomposition of a positive-definite symmetric matrix A: ! A = L * L' ! Input: ! A positive-definite symmetric matrix to be decomposed ! (only upper triangular part of A is used) ! Output: ! Achol Cholesky factor L is returned function chol(A) result(Achol) implicit none real(r8), intent(in) :: A(:,:) real(r8) :: Achol(size(A,1), size(A,2)) real(r8) :: p(size(A,1)) real(r8) :: asum integer :: i, j, n n = size(A,1) if(n .ne. size(A,2)) then call rexit('*** ERROR: matrix is not square (chol) ***') end if Achol = A do i = 1, n asum = Achol(i,i) - sum(Achol(i,1:i-1)**2) if(asum <= 0.0_r8) call rexit('*** ERROR: chol failed') p(i) = sqrt(asum) Achol(i,i) = p(i) Achol(i+1:n,i) = (Achol(i,i+1:n) - matmul(Achol(i+1:n,1:i-1), & Achol(i,1:i-1))) / p(i) end do do i = 1, n do j = 1, n if(i < j) then Achol(i,j) = 0._r8 end if end do end do end function chol !------------------------------------------------------------------------------ ! solves the set of linear equations R * x = b ! where R is a triangular matrix that is either upper triangular (solvu) ! or lower triangular (solvl) function solvu(U, b) result(x) ! U is upper triangular implicit none real(r8), intent(in) :: U(:,:) real(r8), intent(in) :: b(:) real(r8) :: x(size(b)) integer :: i, n ! check diagonal elements are not zero n = size(b) do i = 1, n if(abs(U(i,i)) > 0._r8) cycle call rexit('*** ERROR: zero diagonal element(s) (solvu) ***') end do ! solve equations x(n) = b(n) / U(n,n) do i = n-1, 1, -1 x(i) = ( b(i) - dot_product(U(i,i+1:n), x(i+1:n)) ) / U(i,i) end do end function solvu function solvl(L, b) result(x) ! L is lower triangular implicit none real(r8), intent(in) :: L(:,:) real(r8), intent(in) :: b(:) real(r8) :: x(size(b)) integer :: i, n ! check diagonal elements are not zero n = size(b) do i = 1, n if(abs(L(i,i)) > 0._r8) cycle call rexit('*** ERROR: zero diagonal element(s) (solvl) ***') end do ! solve equations x(1) = b(1) / L(1,1) do i = 2, n x(i) = ( b(i) - dot_product(L(i,1:i-1), x(1:i-1)) ) / L(i,i) end do end function solvl !----------------------------------------------------------------------------- ! computes the inverse of the matrix A using the LU decomposition ! depends on LAPACK ! see http://fortranwiki.org/fortran/show/Matrix+inversion function matinv(A) result(Ainv) real(r8), intent(in) :: A(:,:) real(r8) :: Ainv(size(A,1), size(A,2)) real(r8) :: work(size(A,1)) integer :: piv(size(A,1)) integer :: n, info ! external LAPACK procedures external DGETRF external DGETRI ! check matrix is square n = size(A,1) if(n .ne. size(A,2)) then call rexit('*** ERROR: matrix is not square (matinv) ***') end if ! compute LU factorization with LAPACK subroutine DGETRF ! using partial pivoting with interchange rows Ainv = A call DGETRF(n, n, Ainv, n, piv, info) if(info /= 0) then call rexit('*** ERROR: singular matrix (matinv) ***') end if ! compute the inverse of the matrix using LAPACK subroutine DGETRI, ! using LU factorization computed by DGETRF call DGETRI(n, Ainv, n, piv, work, n, info) if(info /= 0) then call rexit('*** ERROR: matrix inversion failed (matinv) ***') end if end function matinv !----------------------------------------------------------------------------- ! computes the determinant of the matrix A using the LU decomposition real(r8) function det(A) implicit none real(r8), intent(in) :: A(:,:) real(r8) :: Ain(size(A,1), size(A,2)) integer :: piv(size(A,1)) integer :: i, n, info ! external LAPACK procedures external DGETRF ! check matrix is square n = size(A,1) if(n .ne. size(A,2)) then call rexit('*** ERROR: matrix is not square (matinv) ***') end if ! DGETRF computes an LU factorization of a general M-by-N matrix A ! using partial pivoting with row interchanges. Ain = A call DGETRF(n, n, Ain, n, piv, info) if(info /= 0) then call rexit('*** ERROR: LU decomposition failed (det) ***') end if ! compute determinant det = 1._r8 do i = 1, n if(piv(i) /= i) then det = -det * Ain(i,i) else det = det * Ain(i,i) end if end do end function det !----------------------------------------------------------------------------- ! returns the cross-product A' * A of the matrix A function crossprod(A) result(AA) implicit none real(r8), intent(in) :: A(:,:) real(r8) :: AA(size(A,2), size(A,2)) integer :: i, j, n n = size(A,2) do j = 1, n ! i <= j do i = 1, j AA(i,j) = dot_product(A(:,i), A(:,j)) AA(j,i) = AA(i,j) end do end do end function crossprod !----------------------------------------------------------------------------- ! compute outer product p = a * a' or p = a * b' function outerprod1(a) result(p) real(r8), intent(in) :: a(:) real(r8) :: p(size(a), size(a)) p = spread(a, dim=2, ncopies=size(a)) p = p * transpose(p) end function outerprod1 function outerprod2(a, b) result(p) real(r8), intent(in) :: a(:) real(r8), intent(in) :: b(:) real(r8) :: p(size(a), size(b)) p = spread(a, dim=2, ncopies=size(b)) * & spread(b, dim=1, ncopies=size(a)) end function outerprod2 end module matrix BayesFM/src/befa.f900000644000176200001440000002525114631253115013552 0ustar liggesuserssubroutine befa & (nmeas, nobs, kmax, nid, Yobs, Ycat, Ymiss, nX, Xobs, Xloc, iter, burnin, & search_delay, Rmat_delay, step_rnd, step_lambda, seed, prior_loadprec, & prior_beta, prior_dedic, prior_facdist, start_loadprec, start_beta, & start_dedic, start_factor, start_facdist, verbose, npar, MCMCdraws, & MCMCdedic, MHacc) use global use probability, only : set_seed, rpoisson use measurement_class use loading_idioprec_class use covariates_class use indicators_dedic_class use factor_normal_block_class use covmat_block_invwishart_class use mda_class use mcmc_progress_class implicit none !----- input integer, intent(in) :: nmeas integer, intent(in) :: nobs integer, intent(in) :: kmax integer, intent(in) :: nid real(r8), intent(in) :: Yobs(nobs,nmeas) integer, intent(in) :: Ycat(nmeas) logical, intent(in) :: Ymiss(nobs,nmeas) integer, intent(in) :: nX real(r8), intent(in) :: Xobs(nobs,nX) logical, intent(in) :: Xloc(nmeas,nX) integer, intent(in) :: iter integer, intent(in) :: burnin integer, intent(in) :: search_delay integer, intent(in) :: Rmat_delay logical, intent(in) :: step_rnd real(r8), intent(in) :: step_lambda integer, intent(in) :: seed real(r8), intent(in) :: prior_loadprec(nmeas,3) real(r8), intent(in) :: prior_beta(nmeas) real(r8), intent(in) :: prior_dedic(0:3*nmeas+kmax+2) real(r8), intent(in) :: prior_facdist(0:kmax+1) real(r8), intent(in) :: start_loadprec(nmeas,2) real(r8), intent(in) :: start_beta(nmeas,nX) integer, intent(in) :: start_dedic(nmeas) real(r8), intent(in) :: start_factor(nobs,kmax) real(r8), intent(in) :: start_facdist(kmax,kmax) logical, intent(in) :: verbose !----- output integer, intent(in) :: npar real(r8), intent(out) :: MCMCdraws(burnin+1:iter,npar) integer, intent(out) :: MCMCdedic(burnin+1:iter,nmeas) logical, intent(out) :: MHacc(burnin+1:iter) !----- model ingredients type(measurement) :: Ylat(nmeas) type(covariates) :: Xcov(nmeas) type(loading_idioprec) :: alpha_prec(nmeas) type(indic_dedic) :: dedic type(factor_normal_block) :: factors type(covmat_block_invwishart) :: facdist type(workpar) :: mda logical :: norestr integer :: i, ii, j, k, step type(mcmc_progress) :: mcmc_prog call init_mcmc_progress(mcmc_prog, burnin, iter, verbose) !============================================================================= ! initialization call set_seed(seed) do j = 1, nmeas ! latent variables underlying measurements call init_measurement(Ylat(j), nobs, Ycat(j) > 0, Yobs(:,j), Ymiss(:,j)) ! slope parameters for covariates call init_covariates(Xcov(j), nobs, nX, Xobs, prior_beta(j), & start_beta(j,:), Xloc(j,:)) ! factor loadings and idiosyncratic precisions call init_loading_idioprec(alpha_prec(j), nobs, Ycat(j) > 0, & prior_loadprec(j,:), start_loadprec(j,:)) end do ! indicators call init_indic_dedic(dedic, nobs, nmeas, kmax, Ycat, prior_dedic, & start_dedic) where(dedic%group == 0) alpha_prec%alpha = 0._r8 ! latent factors call init_factor_normal_block(factors, nobs, nmeas, kmax, start_factor) if(int(prior_facdist(0)) == 0) then call init_covmat_block_invwishart(facdist, nobs, kmax, .false., & prior_facdist(1:), start_facdist) else call init_covmat_block_invwishart(facdist, nobs, kmax, .true., & prior_facdist(1:), start_facdist) end if ! working parameters for MDA call init_workpar(mda, kmax, nmeas, nobs) norestr = nid==1 step = int(step_lambda) MHacc = .false. !============================================================================= ! MCMC sampling do i = 1, iter if(i <= search_delay) then call gibbs_sweep_forward(search=.false., sample_Rmat = i>Rmat_delay) if(i == search_delay) call backup_draws() ! backup before starting search else if(norestr) then call gibbs_sweep_forward(search=.true., sample_Rmat = i>Rmat_delay) else ! number of intermediate steps in expanded model if(step_rnd) step = 1 + rpoisson(step_lambda) ! intermediate steps forward do ii = 1, step call gibbs_sweep_forward(search=.true., sample_Rmat = i>Rmat_delay) end do ! intermediate steps backward do ii = 1, step call gibbs_sweep_backward(sample_Rmat = i>Rmat_delay) end do ! M-H step: check identification restrictions if(any(dedic%ngroup0)) then ! model is not identified, restore previous draws call restore_draws() else ! model is identified, back up current draws for next iteration call backup_draws() if(i > burnin) MHacc(i) = .true. end if end if ! save current draws after burn-in if(i > burnin) then MCMCdedic(i,:) = dedic%group MCMCdraws(i,:) = [ alpha_prec%alpha, & alpha_prec%var, & get_covmat_block_invwishart(facdist), & get_all_covariates(Xcov) ] end if ! show MCMC progress call show_mcmc_progress(mcmc_prog, i) end do contains !============================================================================= subroutine gibbs_sweep_forward(search, sample_Rmat) implicit none logical, intent(in) :: search, sample_Rmat real(r8) :: Yaux(nobs, nmeas) do j = 1, nmeas Yaux(:,j) = Ylat(j)%Y - Xcov(j)%Xbeta end do ! sample indicators if(search) then call update_indic_dedic(dedic, Yaux, factors%theta) where(dedic%group == 0) alpha_prec%alpha = 0._r8 end if do j = 1, nmeas k = dedic%group(j) ! sample factor loading and idiosyncratic precision call update_loading_idioprec(alpha_prec(j), Yaux(:,j), k, factors%theta) ! sample slope parameters for covariates Yaux(:,j) = Ylat(j)%Y if(k > 0) Yaux(:,j) = Yaux(:,j) - alpha_prec(j)%alpha*factors%theta(:,k) call update_covariates(Xcov(j), Yaux(:,j), alpha_prec(j)%prec) ! sample latent variable underlying measurement if(Ycat(j)>0 .or. any(Ymiss(:,j))) then Yaux(:,j) = Xcov(j)%Xbeta if(k > 0) Yaux(:,j) = Yaux(:,j) + alpha_prec(j)%alpha*factors%theta(:,k) call update_measurement(Ylat(j), Yaux(:,j), alpha_prec(j)%prec) end if end do if(sample_Rmat) then ! MDA: expand model call expand_workpar(mda, dedic%group, alpha_prec%alpha, facdist) ! sample active factors do j = 1, nmeas Yaux(:,j) = Ylat(j)%Y - Xcov(j)%Xbeta end do call update_factor_normal_block_acti & (factors, Yaux, alpha_prec%alpha, dedic, alpha_prec%prec, facdist) ! sample factor covariance matrix call update_covmat_block_invwishart(facdist, factors%theta, dedic) ! sample inactive factors call update_factor_normal_block_inacti(factors, facdist, dedic) ! MDA: transform back to identified model call transform_back_workpar(mda, dedic%group, alpha_prec%alpha, facdist, & factors%theta) else do j = 1, nmeas Yaux(:,j) = Ylat(j)%Y - Xcov(j)%Xbeta end do call update_factor_normal_block(factors, Yaux, alpha_prec%alpha, & dedic%group, alpha_prec%prec, facdist) end if end subroutine gibbs_sweep_forward !============================================================================= subroutine gibbs_sweep_backward(sample_Rmat) implicit none logical, intent(in) :: sample_Rmat real(r8) :: Yaux(nobs, nmeas) if(sample_Rmat) then ! MDA: expand model call expand_workpar(mda, dedic%group, alpha_prec%alpha, facdist) ! sample active factors do j = 1, nmeas Yaux(:,j) = Ylat(j)%Y - Xcov(j)%Xbeta end do call update_factor_normal_block_acti & (factors, Yaux, alpha_prec%alpha, dedic, alpha_prec%prec, facdist) ! sample factor covariance matrix call update_covmat_block_invwishart(facdist, factors%theta, dedic) ! sample inactive factors call update_factor_normal_block_inacti(factors, facdist, dedic) ! MDA: transform back to identified model call transform_back_workpar(mda, dedic%group, alpha_prec%alpha, facdist, & factors%theta) else do j = 1, nmeas Yaux(:,j) = Ylat(j)%Y - Xcov(j)%Xbeta end do call update_factor_normal_block(factors, Yaux, alpha_prec%alpha, & dedic%group, alpha_prec%prec, facdist) end if do j = 1, nmeas k = dedic%group(j) ! sample latent variable underlying measurement if(Ycat(j)>0 .or. any(Ymiss(:,j))) then Yaux(:,j) = Xcov(j)%Xbeta if(k > 0) Yaux(:,j) = Yaux(:,j) + alpha_prec(j)%alpha*factors%theta(:,k) call update_measurement(Ylat(j), Yaux(:,j), alpha_prec(j)%prec) end if ! sample slope parameters for covariates Yaux(:,j) = Ylat(j)%Y if(k > 0) Yaux(:,j) = Yaux(:,j) - alpha_prec(j)%alpha*factors%theta(:,k) call update_covariates(Xcov(j), Yaux(:,j), alpha_prec(j)%prec) end do ! sample indicators do j = 1, nmeas Yaux(:,j) = Ylat(j)%Y - Xcov(j)%Xbeta end do call update_indic_dedic(dedic, Yaux, factors%theta) where(dedic%group == 0) alpha_prec%alpha = 0._r8 ! sample factor loading and idiosyncratic precision do j = 1, nmeas call update_loading_idioprec(alpha_prec(j), Yaux(:,j), dedic%group(j), & factors%theta) end do end subroutine gibbs_sweep_backward !============================================================================= subroutine backup_draws() implicit none integer :: j call backup_indic_dedic(dedic) call backup_factor_normal_block(factors) call backup_covmat_block_invwishart(facdist) do j = 1, nmeas call backup_loading_idioprec(alpha_prec(j)) call backup_covariates(Xcov(j)) call backup_measurement(Ylat(j)) end do end subroutine backup_draws !============================================================================= subroutine restore_draws() implicit none integer :: j call restore_indic_dedic(dedic) call restore_factor_normal_block(factors) call restore_covmat_block_invwishart(facdist) do j = 1, nmeas call restore_loading_idioprec(alpha_prec(j)) call restore_covariates(Xcov(j)) call restore_measurement(Ylat(j)) end do end subroutine restore_draws end subroutine befa BayesFM/src/mda.f900000644000176200001440000000650514631253115013417 0ustar liggesusersmodule mda_class use global use covmat_block_invwishart_class use probability, only : rgamma, rinvgamma implicit none type :: workpar integer :: nfac integer :: nmeas integer :: nobs real(r8), allocatable :: D(:) end type workpar contains !----------------------------------------------------------------------------- subroutine init_workpar(this, nfac, nmeas, nobs) implicit none type(workpar), intent(out) :: this integer, intent(in) :: nfac integer, intent(in) :: nmeas integer, intent(in) :: nobs allocate(this%D(nfac)) this%nfac = nfac this%nmeas = nmeas this%nobs = nobs end subroutine init_workpar !----------------------------------------------------------------------------- subroutine expand_workpar(this, dedic, alpha, covmat) implicit none type(workpar), intent(inout) :: this integer, intent(in) :: dedic(this%nmeas) real(r8), intent(inout) :: alpha(this%nmeas) type(covmat_block_invwishart), intent(inout) :: covmat integer :: k, l if(covmat%use_HuangWand) then ! sample scale parameters from prior for Huang-Wand prior do k = 1, this%nfac covmat%S0(k) = rgamma(.5_r8, 2._r8*covmat%nus*covmat%A2k(k)) end do end if ! sample working parameters from conditional prior do k = 1, this%nfac this%D(k) = rinvgamma(.5_r8*covmat%nu0, & .5_r8*covmat%S0(k)*covmat%prec(k,k)) end do this%D = sqrt(this%D) ! transform model parameters ! (note: factors not tansformed, as they are updated right in the next step) do k = 1, this%nfac where(dedic == k) alpha = alpha / this%D(k) end do do l = 1, this%nfac ! k <= l do k = 1, l covmat%var(k,l) = covmat%var(k,l) * this%D(k) * this%D(l) covmat%prec(k,l) = covmat%prec(k,l) / this%D(k) / this%D(l) covmat%var(l,k) = covmat%var(k,l) covmat%prec(l,k) = covmat%prec(k,l) end do end do end subroutine expand_workpar !----------------------------------------------------------------------------- subroutine transform_back_workpar(this, dedic, alpha, covmat, fac) implicit none type(workpar), intent(inout) :: this integer, intent(in) :: dedic(this%nmeas) real(r8), intent(inout) :: alpha(this%nmeas) type(covmat_block_invwishart), intent(inout) :: covmat real(r8), intent(inout) :: fac(this%nobs,this%nfac) integer :: k, l ! retrieve updated working parameters do k = 1, this%nfac this%D(k) = sqrt(covmat%var(k,k)) end do ! transform back do k = 1, this%nfac fac(:,k) = fac(:,k) / this%D(k) where(dedic == k) alpha = alpha * this%D(k) end do do l = 1, this%nfac ! k <= l do k = 1, l covmat%var(k,l) = covmat%var(k,l) / this%D(k) / this%D(l) covmat%prec(k,l) = covmat%prec(k,l) * this%D(k) * this%D(l) covmat%var(l,k) = covmat%var(k,l) covmat%prec(l,k) = covmat%prec(k,l) end do end do end subroutine transform_back_workpar end module mda_class BayesFM/src/init.c0000644000176200001440000000174213742567211013452 0ustar liggesusers#include "BayesFM.h" #include // for NULL #include #include static R_NativePrimitiveArgType befa_t[] = { INTSXP, INTSXP, INTSXP, INTSXP, REALSXP, INTSXP, LGLSXP, INTSXP, REALSXP, LGLSXP, INTSXP, INTSXP, INTSXP, INTSXP, LGLSXP, REALSXP, INTSXP, REALSXP, REALSXP, REALSXP, REALSXP, REALSXP, REALSXP, INTSXP, REALSXP, REALSXP, LGLSXP, INTSXP, REALSXP, INTSXP, LGLSXP }; static R_NativePrimitiveArgType simnfacprior_t[] = { INTSXP, INTSXP, INTSXP, REALSXP, INTSXP, INTSXP, INTSXP, LGLSXP }; static const R_FortranMethodDef ForMethods[] = { {"befa", (DL_FUNC) &F77_NAME(befa), 31, befa_t }, {"simnfacprior", (DL_FUNC) &F77_NAME(simnfacprior), 8, simnfacprior_t}, {NULL, NULL, 0} }; void attribute_visible R_init_BayesFM(DllInfo *dll) { R_registerRoutines(dll, NULL, NULL, ForMethods, NULL); R_useDynamicSymbols(dll, FALSE); R_forceSymbols(dll, TRUE); } BayesFM/src/mcmc_progress.f900000644000176200001440000000330414631253115015513 0ustar liggesusersmodule mcmc_progress_class implicit none type :: mcmc_progress logical :: verbose integer :: burnin integer :: i integer :: steps(20) character(6) :: perct(20) end type mcmc_progress contains !----------------------------------------------------------------------------- subroutine init_mcmc_progress(this, burnin, iter, verbose) implicit none type(mcmc_progress), intent(out) :: this integer, intent(in) :: iter, burnin logical, intent(in) :: verbose integer :: i this%verbose = verbose this%burnin = burnin this%i = 1 this%steps = (/(i, i=iter/20, iter, iter/20)/) this%steps(20) = iter ! make sure "100%" displayed after last iteration this%perct = [" 5%", " 10%", " 15%", " 20%", " 25%", " 30%", & " 35%", " 40%", " 45%", " 50%", " 55%", " 60%", & " 65%", " 70%", " 75%", " 80%", " 85%", " 90%", & " 95%", " 100%"] end subroutine init_mcmc_progress !----------------------------------------------------------------------------- subroutine show_mcmc_progress(this, rep) implicit none type(mcmc_progress), intent(inout) :: this integer, intent(in) :: rep if(modulo(rep, 100) == 0) call rchkusr() if(this%verbose) then if(rep == this%burnin) then call intpr("done with burn-in period", 24, 0, 0) end if if(rep == this%steps(this%i)) then call intpr(this%perct(this%i), 6, 0, 0) this%i = this%i+1 end if end if end subroutine show_mcmc_progress end module mcmc_progress_class BayesFM/src/BayesFM.h0000644000176200001440000000173513742567211014004 0ustar liggesusers#include #include void F77_NAME(befa)( SEXP *nmeas, SEXP *nobs, SEXP *kmax, SEXP *nid, SEXP *Yobs, SEXP *Ycat, SEXP *Ymiss, SEXP *nX, SEXP *Xobs, SEXP *Xloc, SEXP *iter, SEXP *burnin, SEXP *search_delay, SEXP *Rmat_delay, SEXP *step_rnd, SEXP *step_lambda, SEXP *seed, SEXP *prior_loadprec, SEXP *prior_beta, SEXP *prior_dedic, SEXP *prior_facdist, SEXP *start_loadprec, SEXP *start_beta, SEXP *start_dedic, SEXP *start_factor, SEXP *start_facdist, SEXP *verbose, SEXP *npar, SEXP *MCMCdraws, SEXP *MCMCdedic, SEXP *MHacc); void F77_NAME(simnfacprior)( SEXP *nmeas, SEXP *Kmax, SEXP *Nid, SEXP *kappa, SEXP *nrep, SEXP *seed, SEXP *nfac, SEXP *restrid); BayesFM/src/Makevars0000644000176200001440000000213313742567211014032 0ustar liggesusersPKG_LIBS = $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS) OBJECTS = init.o befa.o covariates.o covmat_block_invwishart.o factor_normal_block.o factor_normal.o global.o indicators_dedic.o loading_idioprec.o matrix.o mcmc_progress.o mda.o measurement.o probability.o simul_nfac_prior.o all: $(SHLIB) befa.o : covariates.o befa.o factor_normal_block.o factor_normal.o mda.o : covmat_block_invwishart.o befa.o : factor_normal_block.o factor_normal_block.o : factor_normal.o befa.o covariates.o covmat_block_invwishart.o factor_normal_block.o factor_normal.o indicators_dedic.o loading_idioprec.o matrix.o mda.o measurement.o probability.o simul_nfac_prior.o : global.o befa.o covmat_block_invwishart.o factor_normal_block.o : indicators_dedic.o befa.o : loading_idioprec.o covariates.o covmat_block_invwishart.o factor_normal_block.o factor_normal.o probability.o : matrix.o befa.o : mcmc_progress.o befa.o : mda.o befa.o : measurement.o befa.o covariates.o covmat_block_invwishart.o factor_normal_block.o factor_normal.o indicators_dedic.o loading_idioprec.o mda.o measurement.o simul_nfac_prior.o : probability.o BayesFM/src/covariates.f900000644000176200001440000000771614631253115015023 0ustar liggesusersmodule covariates_class use global use probability, only : rnorm use matrix, only : chol, solvl, solvu implicit none type :: covariates integer :: nobs integer :: npar real(r8), allocatable :: beta(:) real(r8), allocatable :: X(:,:) real(r8), allocatable :: XX(:,:) real(r8), allocatable :: Xbeta(:) real(r8) :: prec0 ! back up real(r8), allocatable :: beta_bak(:) real(r8), allocatable :: Xbeta_bak(:) end type covariates contains !----------------------------------------------------------------------------- subroutine init_covariates(this, nobs, npar, X, prior, start, mask) implicit none type(covariates), intent(out) :: this integer, intent(in) :: nobs integer, intent(in) :: npar real(r8), intent(in) :: X(nobs, npar) real(r8), intent(in) :: prior real(r8), intent(in) :: start(npar) logical, intent(in), optional :: mask(npar) integer :: i this%nobs = nobs if(present(mask)) then this%npar = count(mask) else this%npar = npar end if allocate(this%Xbeta(nobs)) this%Xbeta = 0._r8 if(this%npar == 0) return ! nothing more to allocate if no this allocate(this%beta(this%npar)) allocate(this%X(nobs, this%npar)) allocate(this%XX(this%npar, this%npar)) allocate(this%beta_bak(this%npar)) allocate(this%Xbeta_bak(nobs)) if(present(mask)) then do i = 1, nobs this%X(i,:) = pack(X(i,:), mask) end do this%beta = pack(start, mask) else this%X = X this%beta = start end if this%XX = matmul(transpose(this%X), this%X) this%Xbeta = matmul(this%X, this%beta) this%prec0 = prior this%beta_bak = this%beta this%Xbeta_bak = this%Xbeta end subroutine init_covariates !----------------------------------------------------------------------------- subroutine update_covariates(this, Y, prec) implicit none type(covariates), intent(inout) :: this real(r8), dimension(this%nobs), intent(in) :: Y real(r8), intent(in) :: prec real(r8), dimension(this%npar, this%npar) :: beta_B, beta_L real(r8), dimension(this%npar) :: beta_m, beta_z, beta_e integer :: i if(this%npar == 0) return beta_m = prec * matmul(transpose(this%X), Y) beta_B = prec * this%XX do i = 1, this%npar beta_B(i,i) = beta_B(i,i) + this%prec0 end do beta_L = chol(beta_B) beta_z = solvl(beta_L, beta_m) do i = 1, this%npar beta_e(i) = rnorm() end do this%beta = solvu(transpose(beta_L), beta_e + beta_z) this%Xbeta = matmul(this%X, this%beta) end subroutine update_covariates !----------------------------------------------------------------------------- subroutine backup_covariates(this) implicit none type(covariates), intent(inout) :: this if(this%npar == 0) return this%beta_bak = this%beta this%Xbeta_bak = this%Xbeta end subroutine backup_covariates !----------------------------------------------------------------------------- subroutine restore_covariates(this) implicit none type(covariates), intent(inout) :: this if(this%npar == 0) return this%beta = this%beta_bak this%Xbeta = this%Xbeta_bak end subroutine restore_covariates !----------------------------------------------------------------------------- function get_all_covariates(X) result(par) implicit none type(covariates) :: X(:) real(r8) :: par(sum(X%npar)) integer :: i, j i = 0 do j = 1, size(X) if(X(j)%npar == 0) cycle par(i+1:i+X(j)%npar) = X(j)%beta i = i + X(j)%npar end do end function get_all_covariates end module covariates_class BayesFM/src/measurement.f900000644000176200001440000000702514631253115015201 0ustar liggesusersmodule measurement_class use global use probability, only : rnorm, rtnorm implicit none type :: measurement logical :: is_binary ! TRUE = binary, FALSE = continuous integer :: nobs real(r8), allocatable :: Y(:) logical, allocatable :: Ybin(:) logical, allocatable :: Ymiss(:) ! back up real(r8), allocatable :: Y_bak(:) end type measurement contains !----------------------------------------------------------------------------- subroutine init_measurement(this, nobs, is_binary, Y, Ymiss) implicit none type(measurement), intent(out) :: this integer, intent(in) :: nobs logical, intent(in) :: is_binary real(r8), intent(in) :: Y(nobs) logical, intent(in), optional :: Ymiss(nobs) integer :: i this%is_binary = is_binary this%nobs = nobs allocate(this%Y(nobs)) if(present(Ymiss)) then if(any(Ymiss)) then allocate(this%Ymiss(nobs)) this%Ymiss = Ymiss end if end if if(this%is_binary) then allocate(this%Ybin(nobs)) allocate(this%Y_bak(nobs)) this%Ybin = int(Y) == 1 do i = 1, nobs this%Y(i) = abs(rnorm()) end do if(allocated(this%Ymiss)) then do i = 1, nobs if(.not.this%Ymiss(i) .and. .not.this%Ybin(i)) then this%Y(i) = -this%Y(i) end if end do else do i = 1, nobs if(.not.this%Ybin(i)) then this%Y(i) = -this%Y(i) end if end do end if else this%Y = Y if(allocated(this%Ymiss)) then allocate(this%Y_bak(nobs)) do i = 1, nobs if(.not.this%Ymiss(i)) cycle this%Y(i) = rnorm() end do end if end if if(allocated(this%Y_bak)) this%Y_bak = this%Y end subroutine init_measurement !----------------------------------------------------------------------------- subroutine update_measurement(this, mean, var) implicit none type(measurement), intent(inout) :: this real(r8), intent(in) :: mean(this%nobs) real(r8), intent(in) :: var integer :: i if(this%is_binary) then if(allocated(this%Ymiss)) then do i = 1, this%nobs if(this%Ymiss(i)) then this%Y(i) = rnorm(mean(i), var) else this%Y(i) = rtnorm(mean(i), var, 0._r8, this%Ybin(i)) end if end do else do i = 1, this%nobs this%Y(i) = rtnorm(mean(i), var, 0._r8, this%Ybin(i)) end do end if else if(.not.allocated(this%Ymiss)) return do i = 1, this%nobs if(this%Ymiss(i)) then this%Y(i) = rnorm(mean(i), var) end if end do end if end subroutine update_measurement !----------------------------------------------------------------------------- subroutine backup_measurement(this) implicit none type(measurement), intent(inout) :: this if(allocated(this%Y_bak)) then this%Y_bak = this%Y end if end subroutine backup_measurement !----------------------------------------------------------------------------- subroutine restore_measurement(this) implicit none type(measurement), intent(inout) :: this if(allocated(this%Y_bak)) then this%Y = this%Y_bak end if end subroutine restore_measurement end module measurement_class BayesFM/src/simul_nfac_prior.f900000644000176200001440000000224014631161175016205 0ustar liggesuserssubroutine simnfacprior(nmeas, Kmax, Nid, kappa, nrep, seed, nfac, restrid) use global use probability, only : set_seed, rdirich, runif implicit none integer, intent(in) :: nmeas integer, intent(in) :: Kmax integer, intent(in) :: Nid real(r8), intent(in) :: kappa(Kmax) integer, intent(in) :: nrep integer, intent(in) :: seed integer, intent(out) :: nfac(nrep) logical, intent(out) :: restrid(nrep) real(r8) :: prob(Kmax) integer :: dedic(nmeas) integer :: ndedic(Kmax) real(r8) :: e, csum logical :: checkid integer :: i, j, k checkid = Nid > 1 restrid = .true. call set_seed(seed) do i = 1, nrep ! sample indicator probabilities prob = rdirich(kappa) ! sample indicators ndedic = 0 do j = 1, nmeas e = runif() csum = 0._r8 do k = 1, Kmax csum = csum + prob(k) if(e <= csum) exit end do dedic(j) = k ndedic(k) = ndedic(k) + 1 end do ! count number of factors nfac(i) = count(ndedic > 0) ! check identification restriction if(checkid) restrid(i) = all(ndedic >= Nid .or. ndedic == 0) end do end subroutine simnfacprior BayesFM/src/global.f900000644000176200001440000000043114631161175014112 0ustar liggesusersmodule global use, intrinsic :: iso_fortran_env implicit none ! Fortran kinds for single and double precisions integer, parameter :: i4 = INT32 integer, parameter :: i8 = INT64 integer, parameter :: r4 = REAL32 integer, parameter :: r8 = REAL64 end module global BayesFM/src/probability.f900000644000176200001440000002612514631161175015202 0ustar liggesusersmodule probability use global use matrix, only : chol, matinv implicit none private public :: set_seed public :: runif public :: rexpon public :: rnorm public :: rtnorm public :: rgamma public :: rinvgamma public :: rdirich public :: rwishart public :: rinvwishart public :: rpoisson real(r8), parameter :: pi = 3.141592653589793238462643383276_r8 real(r8), parameter :: half = .5_r8 real(r8), parameter :: third = 1._r8/3._r8 !----- variables for 64-bit Mersenne Twister algorithm integer(i8), parameter :: nn = 312_i8 integer(i8), parameter :: mm = 156_i8 integer(i8), parameter :: matx_a = -5403634167711393303_i8 integer(i8), parameter :: um = -2147483648_i8 ! most significant 33 bits integer(i8), parameter :: lm = 2147483647_i8 ! least significant 31 bits real(r8), parameter :: pi253_1 = 1._r8/(2._r8**53 - 1._r8) integer(i8) :: mt(nn) ! array for the state vector integer :: mti = nn+1 ! mti==nn+1 means mt(nn) is not initialized interface runif module procedure runif_01 module procedure runif_ab end interface runif interface rnorm module procedure rnorm_01 module procedure rnorm_mu_var end interface rnorm contains !----------------------------------------------------------------------------- ! 64-bit Mersenne Twister algorithm ! ! Fortran translation from C-program for MT19937-64 (2004/9/29 version) ! originally coded by Takuji Nishimura and Makoto Matsumoto ! see http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/emt64.html ! translation by Rémi Piatek, University of Copenhagen !----- initializes mt(nn) with a seed subroutine set_seed(seed) implicit none integer, intent(in) :: seed integer :: i mt(1) = int(seed, kind=i8) do i = 1, nn-1 mt(i+1) = 6364136223846793005_i8 * ieor(mt(i), ishft(mt(i), -62)) + i end do mti = nn end subroutine set_seed !----- generates a random number on [-2^63, 2^63-1]-interval integer(r8) function genrand64_int64() implicit none integer(i8) :: mag01(0:1) = (/0_i8, matx_a/) integer(i8) :: x integer :: i if(mti >= nn) then ! generate nn words at one time ! if set_seed() has not been called, a default initial seed is used if(mti == nn+1) call set_seed(5489) do i = 1, nn-mm x = ior(iand(mt(i),um), iand(mt(i+1), lm)) mt(i) = ieor(ieor(mt(i+mm), ishft(x, -1)), mag01(iand(x, 1_i8))) end do do i = nn-mm+1, nn-1 x = ior(iand(mt(i), um), iand(mt(i+1), lm)) mt(i) = ieor(ieor(mt(i+mm-nn), ishft(x, -1)), mag01(iand(x, 1_i8))) end do x = ior(iand(mt(nn), um), iand(mt(1), lm)) mt(nn) = ieor(ieor(mt(mm), ishft(x, -1)), mag01(iand(x, 1_i8))) mti = 0 end if mti = mti + 1 x = mt(mti) x = ieor(x, iand(ishft(x,-29), 6148914691236517205_i8)) x = ieor(x, iand(ishft(x, 17), 8202884508482404352_i8)) x = ieor(x, iand(ishft(x, 37), -2270628950310912_i8)) x = ieor(x, ishft(x, -43)) genrand64_int64 = x end function genrand64_int64 !----------------------------------------------------------------------------- ! generates random number from uniform distribution (genrand64_real1) real(r8) function runif_01() implicit none runif_01 = real(ishft(genrand64_int64(), -11), kind=r8) * pi253_1 end function runif_01 real(r8) function runif_ab(a, b) implicit none real(r8), intent(in) :: a, b if(b <= a) call rexit('*** ERROR: a should be < b (runif) ***') runif_ab = runif_01() * (b-a) + a end function runif_ab !----------------------------------------------------------------------------- ! generates random number from exponential distribution ! with scale parameter b such that mean = b and variance = b^2 real(r8) function rexpon(b) implicit none real(r8), intent(in) :: b if(b <= 0._r8) then call rexit('*** ERROR: rate parameter should be > 0 (rexpon) ***') end if rexpon = -log(runif()) / b end function rexpon !----------------------------------------------------------------------------- ! generates random number from normal distribution ! ! source: ! Joseph L. Leva ! ``A Fast Normal Random Number Generator'' ! ACM Transactions on Mathematical Software ! Vol. 18, No. 4, December 1992, pages 449-453 real(r8) function rnorm_01() implicit none real(r8) :: u, v, x, y, q do u = runif() v = 1.7156_r8*(runif() - 0.5_r8) x = u - 0.449871_r8 y = abs(v) + 0.386595_r8 q = x**2 + y*(0.19600_r8*y - 0.25472_r8*x) if(q < 0.27597_r8) exit if(q > 0.27846_r8) cycle if(v**2 <= -4._r8*(u**2)*log(u)) exit ! rarely evaluated end do rnorm_01 = v/u end function rnorm_01 real(r8) function rnorm_mu_var(mu, var) implicit none real(r8), intent(in) :: mu, var if(var <= 0._r8) then call rexit('*** ERROR: var should be positive (rnorm) ***') end if rnorm_mu_var = mu + sqrt(var)*rnorm_01() end function rnorm_mu_var !----------------------------------------------------------------------------- ! generates random number from truncated normal distribution ! with mean mu and standard deviation sd with truncation ! (a, +infty) if left = true ! (-infty, a) if left = false ! ! source: ! John Geweke (1991) ! ``Efficient Simulation from the Multivariate Normaland Student-t ! Distributions Subject to Linear Constraintsand the Evaluation ! of Constraint Probabilities'' ! Computing Science and Statistics: ! Proceedings of the 23rd Symposium on the Interface ! Ed. E. Keramidas and S. Kaufman, pages 571-578 ! Fairfax Station, VA: InterfaceFoundation of North America. real(r8) function rtnorm(mu, var, a, left) implicit none real(r8), intent(in) :: mu, var, a logical, intent(in) :: left real(r8) :: sd, c, u, z if(var <= 0._r8) then call rexit('*** ERROR: var should be positive (rtnorm) ***') end if sd = sqrt(var) c = (a - mu)/sd if(.not.left) c = -c if(c <= .45_r8) then ! normal rejection sampling do z = rnorm() if(z > c) exit end do else ! exponential rejection sampling do z = rexpon(c) u = runif() if(u < exp(-.5_r8*(z**2))) exit end do z = z + c end if if(left) then rtnorm = mu + z*sd else rtnorm = mu - z*sd end if end function rtnorm !----------------------------------------------------------------------------- ! generates random number from gamma distribution ! with shape parameter a and scale parameter b ! such that mean=a*b and var=a*b^2 ! ! source: ! George Marsaglia and Wai Wan Tsang ! ``A Simple Method for Generating Gamma Variables'' ! ACM Transactions on Mathematical Software ! Vol. 26, No. 3, September 2000, pages 363-372 real(r8) function rgamma(a, b) implicit none real(r8), intent(in) :: a, b real(r8) :: a1, c, d, u, v, x if(a <= 0._r8) call rexit('*** ERROR: a should be positive (rgamma) ***') if(b <= 0._r8) call rexit('*** ERROR: b should be positive (rgamma) ***') a1 = a if(a < 1._r8) a1 = a + 1._r8 d = a1 - third c = 1._r8/sqrt(9._r8*d) do do x = rnorm() v = (1._r8 + c*x) if(v > 0._r8) exit end do v = v**3 u = runif() if(u < 1._r8 - 0.0331_r8*(x**4)) exit if(log(u) < .5_r8*(x**2) + d*(1._r8-v+log(v))) exit end do rgamma = d*v*b ! case where a < 1 (see note p.371) if(a < 1._r8) then do u = runif() if(u > 0._r8) then ! cycle if u = 0 rgamma = rgamma * u**(1._r8/a) exit end if end do end if end function rgamma !----------------------------------------------------------------------------- ! generates random number from inverse-gamma distribution ! with shape parameter a and rate parameter b real(r8) function rinvgamma(a, b) implicit none real(r8), intent(in) :: a, b if(a <= 0._r8) call rexit('*** ERROR: a should be positive (rinvgamma) ***') if(b <= 0._r8) call rexit('*** ERROR: b should be positive (rinvgamma) ***') rinvgamma = 1._r8/rgamma(a, 1._r8/b) end function rinvgamma !----------------------------------------------------------------------------- ! generates vector from Dirichlet distribution ! with concentration parameters alpha function rdirich(alpha) implicit none real(r8), intent(in) :: alpha(:) real(r8) :: rdirich(size(alpha)) integer :: i if(any(alpha <= 0._r8)) then call rexit('*** ERROR: alpha should be strictly positive (rdirich) ***') end if do i = 1, size(alpha) rdirich(i) = rgamma(alpha(i), 1._r8) end do rdirich = rdirich / sum(rdirich) end function rdirich !----------------------------------------------------------------------------- ! generates random matrix from Wishart distribution ! with df degrees of freedom and scale matrix S: ! ! X ~ Wishart(df, S) ! p(X) \propto |X|^{(df-p-1)/2} exp{ -tr(X * S^-1)/2 } ! ! reference: ! A. K. Gupta & D. K. Nagar (2000) ! ``Matrix Variate Distributions'' ! Chapman & Hall/CRC ! Monographs and Surveys in Pure and Applied Mathematics, No. 104 ! Theorems 3.3.1 and 3.3.4, pp.90-91 function rwishart(df, S) implicit none real(r8), intent(in) :: df, S(:,:) real(r8), dimension(size(S,1),size(S,2)) :: rwishart, B, BB, L integer :: i, j, p p = size(S,1) if(df < dble(p)) then call rexit('*** ERROR: degrees of freedom should be > p-1 (rwishart) ***') end if B = 0._r8 do i = 1, p do j = 1, i if (i == j) then B(i,i) = sqrt(rgamma(.5_r8*(df-dble(i)+1._r8), 2._r8)) else B(i,j) = rnorm() end if end do end do BB = matmul(B, transpose(B)) L = chol(S) rwishart = matmul(L, matmul(BB, transpose(L))) end function rwishart !----------------------------------------------------------------------------- ! generates random matrix from inverse-Wishart distribution ! ! X ~ inv-Wishart(df, W) ! p(X) \propto |X|^{-(df+p+1)/2} exp{ -tr(W * X^-1)/2 } function rinvwishart(df, W) implicit none real(r8), intent(in) :: df, W(:,:) real(r8) :: rinvwishart(size(W,1), size(W,1)) rinvwishart = matinv(rwishart(df, matinv(W))) end function rinvwishart !----------------------------------------------------------------------------- ! generates random number from Poisson distribution integer function rpoisson(b) implicit none real(r8), intent(in) :: b real(r8) :: em, t real(r8), save :: g, oldb=-1._r8 if(b <= 0._r8) then call rexit('*** ERROR: b should be > 0 (rpoisson) ***') end if ! Knuth's algorithm if(abs(b - oldb) > 0._r8) then oldb = b g = exp(-b) end if em = -1._r8 t = 1._r8 do em = em + 1._r8 t = t * runif() if(t <= g) exit end do rpoisson = int(em) end function rpoisson end module probability BayesFM/NAMESPACE0000644000176200001440000000307614145717327013000 0ustar liggesusers# Generated by roxygen2: do not edit by hand S3method(plot,befa) S3method(plot,simul.R.prior) S3method(plot,simul.nfac.prior) S3method(print,befa) S3method(print,simul.R.prior) S3method(print,simul.nfac.prior) S3method(print,summary.befa) S3method(print,summary.simul.R.prior) S3method(print,summary.simul.nfac.prior) S3method(summary,befa) S3method(summary,simul.R.prior) S3method(summary,simul.nfac.prior) export(befa) export(post.column.switch) export(post.sign.switch) export(simul.R.prior) export(simul.dedic.facmod) export(simul.nfac.prior) import(checkmate) importFrom(coda,HPDinterval) importFrom(coda,as.mcmc) importFrom(ggplot2,aes_string) importFrom(ggplot2,element_blank) importFrom(ggplot2,element_text) importFrom(ggplot2,geom_bar) importFrom(ggplot2,geom_density) importFrom(ggplot2,geom_line) importFrom(ggplot2,geom_rug) importFrom(ggplot2,geom_text) importFrom(ggplot2,geom_tile) importFrom(ggplot2,ggplot) importFrom(ggplot2,ggplot_build) importFrom(ggplot2,ggplot_gtable) importFrom(ggplot2,guide_colorbar) importFrom(ggplot2,guides) importFrom(ggplot2,labs) importFrom(ggplot2,scale_fill_gradient2) importFrom(ggplot2,theme) importFrom(ggplot2,unit) importFrom(gridExtra,arrangeGrob) importFrom(gridExtra,grid.arrange) importFrom(plyr,count) importFrom(stats,complete.cases) importFrom(stats,cor) importFrom(stats,cov2cor) importFrom(stats,median) importFrom(stats,quantile) importFrom(stats,rWishart) importFrom(stats,rgamma) importFrom(stats,rnorm) importFrom(stats,runif) importFrom(stats,sd) importFrom(stats,terms) useDynLib(BayesFM, .registration = TRUE, .fixes = "F_") BayesFM/NEWS.md0000644000176200001440000000404514631253115012642 0ustar liggesusers# Changes in version 0.1.7 - Refactored Fortran code: Removed polymorphism to allow compilation with flang versions 17 and 18. # Changes in version 0.1.6 - Changed extension of Fortran files (.f95 -> .f90) to accommodate Intel Fortran compiler. # Changes in version 0.1.5 - Added missing AC_OUTPUT to configure.ac to remove warning on CRAN. - Minor # Changes to documentation (now using \doi{} for references). # Changes in version 0.1.4 - Updated maintainer's email address. # Changes in version 0.1.3 - Fixed error occurring when "class(matrix(...))" returns a vector of length two. # Changes in version 0.1.2 - Patched "configure.ac" file to solve compilation problems on some platforms. - Fortran native routines now registered and symbol search disabled. - README file added to provide information about installation requirements. - Added empty "configure.win" file for Windows users. # Changes in version 0.1.1 - Added simul.R.prior() and simul.nfac.prior() functions to simulate the prior distributions of the number of latent factors, and of the correlation matrix of the factors. - Improved plot() generic function for "befa" object to show more posterior results, such as heatmaps for indicator posterior probabilities, factor loadings and correlation matrix of the latent factors. - Now using ggplot2 package for nice-looking graphs. - Added "configure" script to address cross-compilation problems. - Minor improvements to documentation. # Changes in version 0.1.0 - Fixed dependencies in Fortran code (Makevars file) and added gfortran as system requirement in DESCRIPTION file to solve cross-compilation problems. - Added print(), summary() and plot() functions to "befa" object. - Removed HPPmodel(), as highest posterior probability models can now be summarized with generic function summary(). - Renamed two arguments passed to befa() function for consistency (loading.start -> alpha.start, idiovar.start -> sigma.start). - Removed deprecated cleanup file. - Added NEWS file. # Changes in version 0.0.2 - First version released on CRAN. BayesFM/configure.ac0000644000176200001440000000306314631156450014035 0ustar liggesusersAC_PREREQ(2.69) AC_INIT([DESCRIPTION]) AC_PROG_GREP AC_PROG_SED : ${R_HOME=`R RHOME`} if test -z "${R_HOME}"; then echo "could not determine R_HOME" exit 1 fi FC=`"${R_HOME}/bin/R" CMD config FC` if test -z "${FC}"; then AC_MSG_WARN(R could not find a Fortran compiler. Now trying to detect one.) AC_PROG_FC fi AC_MSG_CHECKING(for Fortran compiler) case "${FC}" in *gfortran*) dnl check if GNU Fortran is actually used GNU_FORTRAN=`${FC} --version | ${GREP} 'GNU Fortran'` if test -z "${GNU_FORTRAN}"; then AC_MSG_RESULT(no) AC_MSG_ERROR(Fortran compiler (${FC}) does not seem to be GNU Fortran.) fi dnl minimum version of GNU Fortran that supports code MINI_GFORTRAN_VERSION="4.6.3" dnl check version of GNU Fortran FC_VERSION=`echo "__GNUC__.__GNUC_MINOR__.__GNUC_PATCHLEVEL__" | \ ${FC} -E -P - | ${SED} -e 's/ //g'` AC_MSG_RESULT(gfortran ${FC_VERSION}) AS_VERSION_COMPARE(${FC_VERSION}, ${MINI_GFORTRAN_VERSION}, [AC_MSG_ERROR([this version of GNU Fortran cannot be used to compile this package. Please try to upgrade gfortran (>= ${MINI_GFORTRAN_VERSION}) or to use a different Fortran compiler.])], [], []) ;; *g95*) AC_MSG_RESULT(${FC}) AC_MSG_ERROR([G95 cannot compile the Fortran code contained in this package. Please try to use a different Fortran compiler.]) ;; *) AC_MSG_RESULT(${FC}) AC_MSG_WARN([the Fortran code contained in this package will be compiled with ${FC}. Please contact package maintainer if compilation fails.]) ;; esac AC_OUTPUT BayesFM/README.md0000644000176200001440000000162414147523552013032 0ustar liggesusers# BayesFM: Bayesian Inference for Factor Modeling [![CRAN](https://www.r-pkg.org/badges/version/BayesFM)](https://cran.r-project.org/package=BayesFM) ## Installation This package can be installed in R using: ```{r} install.packages("BayesFM") ``` Alternatively, it can be installed directly from Github: ``` # install.packages("devtools") devtools::install_github("piatek/BayesFM") ``` ### Notes: - This package requires a Fortran compiler and a C compiler. - GNU Fortran version 4.6.3 or later is recommended. - F95 and earlier versions of GNU Fortran may not work because of unsupported Fortran 2003 features used in this package. Windows users: - It is recommended to install [Rtools](https://cran.r-project.org/bin/windows/Rtools/) to compile this package from source, see [R for Windows FAQ](https://cran.r-project.org/bin/windows/base/rw-FAQ.html). BayesFM/build/0000755000176200001440000000000014631253271012643 5ustar liggesusersBayesFM/build/partial.rdb0000644000176200001440000000007414631253271014771 0ustar liggesusers‹‹àb```b`a’Ì ¦0°0 FN Íš—˜›Z d@$þû$¬²7BayesFM/configure0000755000176200001440000022443414631253271013464 0ustar liggesusers#! /bin/sh # Guess values for system-dependent variables and create Makefiles. # Generated by GNU Autoconf 2.69. # # # Copyright (C) 1992-1996, 1998-2012 Free Software Foundation, Inc. # # # This configure script is free software; the Free Software Foundation # gives unlimited permission to copy, distribute and modify it. ## -------------------- ## ## M4sh Initialization. ## ## -------------------- ## # Be more Bourne compatible DUALCASE=1; export DUALCASE # for MKS sh if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then : emulate sh NULLCMD=: # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which # is contrary to our usage. Disable this feature. alias -g '${1+"$@"}'='"$@"' setopt NO_GLOB_SUBST else case `(set -o) 2>/dev/null` in #( *posix*) : set -o posix ;; #( *) : ;; esac fi as_nl=' ' export as_nl # Printing a long string crashes Solaris 7 /usr/bin/printf. as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo # Prefer a ksh shell builtin over an external printf program on Solaris, # but without wasting forks for bash or zsh. if test -z "$BASH_VERSION$ZSH_VERSION" \ && (test "X`print -r -- $as_echo`" = "X$as_echo") 2>/dev/null; then as_echo='print -r --' as_echo_n='print -rn --' elif (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then as_echo='printf %s\n' as_echo_n='printf %s' else if test "X`(/usr/ucb/echo -n -n $as_echo) 2>/dev/null`" = "X-n $as_echo"; then as_echo_body='eval /usr/ucb/echo -n "$1$as_nl"' as_echo_n='/usr/ucb/echo -n' else as_echo_body='eval expr "X$1" : "X\\(.*\\)"' as_echo_n_body='eval arg=$1; case $arg in #( *"$as_nl"*) expr "X$arg" : "X\\(.*\\)$as_nl"; arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;; esac; expr "X$arg" : "X\\(.*\\)" | tr -d "$as_nl" ' export as_echo_n_body as_echo_n='sh -c $as_echo_n_body as_echo' fi export as_echo_body as_echo='sh -c $as_echo_body as_echo' fi # The user is always right. if test "${PATH_SEPARATOR+set}" != set; then PATH_SEPARATOR=: (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || PATH_SEPARATOR=';' } fi # IFS # We need space, tab and new line, in precisely that order. Quoting is # there to prevent editors from complaining about space-tab. # (If _AS_PATH_WALK were called with IFS unset, it would disable word # splitting by setting IFS to empty value.) IFS=" "" $as_nl" # Find who we are. Look in the path if we contain no directory separator. as_myself= case $0 in #(( *[\\/]* ) as_myself=$0 ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break done IFS=$as_save_IFS ;; esac # We did not find ourselves, most probably we were run as `sh COMMAND' # in which case we are not to be found in the path. if test "x$as_myself" = x; then as_myself=$0 fi if test ! -f "$as_myself"; then $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 exit 1 fi # Unset variables that we do not need and which cause bugs (e.g. in # pre-3.0 UWIN ksh). But do not cause bugs in bash 2.01; the "|| exit 1" # suppresses any "Segmentation fault" message there. '((' could # trigger a bug in pdksh 5.2.14. for as_var in BASH_ENV ENV MAIL MAILPATH do eval test x\${$as_var+set} = xset \ && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : done PS1='$ ' PS2='> ' PS4='+ ' # NLS nuisances. LC_ALL=C export LC_ALL LANGUAGE=C export LANGUAGE # CDPATH. (unset CDPATH) >/dev/null 2>&1 && unset CDPATH # Use a proper internal environment variable to ensure we don't fall # into an infinite loop, continuously re-executing ourselves. if test x"${_as_can_reexec}" != xno && test "x$CONFIG_SHELL" != x; then _as_can_reexec=no; export _as_can_reexec; # We cannot yet assume a decent shell, so we have to provide a # neutralization value for shells without unset; and this also # works around shells that cannot unset nonexistent variables. # Preserve -v and -x to the replacement shell. BASH_ENV=/dev/null ENV=/dev/null (unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV case $- in # (((( *v*x* | *x*v* ) as_opts=-vx ;; *v* ) as_opts=-v ;; *x* ) as_opts=-x ;; * ) as_opts= ;; esac exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} # Admittedly, this is quite paranoid, since all the known shells bail # out after a failed `exec'. $as_echo "$0: could not re-execute with $CONFIG_SHELL" >&2 as_fn_exit 255 fi # We don't want this to propagate to other subprocesses. { _as_can_reexec=; unset _as_can_reexec;} if test "x$CONFIG_SHELL" = x; then as_bourne_compatible="if test -n \"\${ZSH_VERSION+set}\" && (emulate sh) >/dev/null 2>&1; then : emulate sh NULLCMD=: # Pre-4.2 versions of Zsh do word splitting on \${1+\"\$@\"}, which # is contrary to our usage. Disable this feature. alias -g '\${1+\"\$@\"}'='\"\$@\"' setopt NO_GLOB_SUBST else case \`(set -o) 2>/dev/null\` in #( *posix*) : set -o posix ;; #( *) : ;; esac fi " as_required="as_fn_return () { (exit \$1); } as_fn_success () { as_fn_return 0; } as_fn_failure () { as_fn_return 1; } as_fn_ret_success () { return 0; } as_fn_ret_failure () { return 1; } exitcode=0 as_fn_success || { exitcode=1; echo as_fn_success failed.; } as_fn_failure && { exitcode=1; echo as_fn_failure succeeded.; } as_fn_ret_success || { exitcode=1; echo as_fn_ret_success failed.; } as_fn_ret_failure && { exitcode=1; echo as_fn_ret_failure succeeded.; } if ( set x; as_fn_ret_success y && test x = \"\$1\" ); then : else exitcode=1; echo positional parameters were not saved. fi test x\$exitcode = x0 || exit 1 test -x / || exit 1" as_suggested=" as_lineno_1=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_1a=\$LINENO as_lineno_2=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_2a=\$LINENO eval 'test \"x\$as_lineno_1'\$as_run'\" != \"x\$as_lineno_2'\$as_run'\" && test \"x\`expr \$as_lineno_1'\$as_run' + 1\`\" = \"x\$as_lineno_2'\$as_run'\"' || exit 1 test \$(( 1 + 1 )) = 2 || exit 1" if (eval "$as_required") 2>/dev/null; then : as_have_required=yes else as_have_required=no fi if test x$as_have_required = xyes && (eval "$as_suggested") 2>/dev/null; then : else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR as_found=false for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. as_found=: case $as_dir in #( /*) for as_base in sh bash ksh sh5; do # Try only shells that exist, to save several forks. as_shell=$as_dir/$as_base if { test -f "$as_shell" || test -f "$as_shell.exe"; } && { $as_echo "$as_bourne_compatible""$as_required" | as_run=a "$as_shell"; } 2>/dev/null; then : CONFIG_SHELL=$as_shell as_have_required=yes if { $as_echo "$as_bourne_compatible""$as_suggested" | as_run=a "$as_shell"; } 2>/dev/null; then : break 2 fi fi done;; esac as_found=false done $as_found || { if { test -f "$SHELL" || test -f "$SHELL.exe"; } && { $as_echo "$as_bourne_compatible""$as_required" | as_run=a "$SHELL"; } 2>/dev/null; then : CONFIG_SHELL=$SHELL as_have_required=yes fi; } IFS=$as_save_IFS if test "x$CONFIG_SHELL" != x; then : export CONFIG_SHELL # We cannot yet assume a decent shell, so we have to provide a # neutralization value for shells without unset; and this also # works around shells that cannot unset nonexistent variables. # Preserve -v and -x to the replacement shell. BASH_ENV=/dev/null ENV=/dev/null (unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV case $- in # (((( *v*x* | *x*v* ) as_opts=-vx ;; *v* ) as_opts=-v ;; *x* ) as_opts=-x ;; * ) as_opts= ;; esac exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} # Admittedly, this is quite paranoid, since all the known shells bail # out after a failed `exec'. $as_echo "$0: could not re-execute with $CONFIG_SHELL" >&2 exit 255 fi if test x$as_have_required = xno; then : $as_echo "$0: This script requires a shell more modern than all" $as_echo "$0: the shells that I found on your system." if test x${ZSH_VERSION+set} = xset ; then $as_echo "$0: In particular, zsh $ZSH_VERSION has bugs and should" $as_echo "$0: be upgraded to zsh 4.3.4 or later." else $as_echo "$0: Please tell bug-autoconf@gnu.org about your system, $0: including any error possibly output before this $0: message. Then install a modern shell, or manually run $0: the script under such a shell if you do have one." fi exit 1 fi fi fi SHELL=${CONFIG_SHELL-/bin/sh} export SHELL # Unset more variables known to interfere with behavior of common tools. CLICOLOR_FORCE= GREP_OPTIONS= unset CLICOLOR_FORCE GREP_OPTIONS ## --------------------- ## ## M4sh Shell Functions. ## ## --------------------- ## # as_fn_unset VAR # --------------- # Portably unset VAR. as_fn_unset () { { eval $1=; unset $1;} } as_unset=as_fn_unset # as_fn_set_status STATUS # ----------------------- # Set $? to STATUS, without forking. as_fn_set_status () { return $1 } # as_fn_set_status # as_fn_exit STATUS # ----------------- # Exit the shell with STATUS, even in a "trap 0" or "set -e" context. as_fn_exit () { set +e as_fn_set_status $1 exit $1 } # as_fn_exit # as_fn_mkdir_p # ------------- # Create "$as_dir" as a directory, including parents if necessary. as_fn_mkdir_p () { case $as_dir in #( -*) as_dir=./$as_dir;; esac test -d "$as_dir" || eval $as_mkdir_p || { as_dirs= while :; do case $as_dir in #( *\'*) as_qdir=`$as_echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( *) as_qdir=$as_dir;; esac as_dirs="'$as_qdir' $as_dirs" as_dir=`$as_dirname -- "$as_dir" || $as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$as_dir" : 'X\(//\)[^/]' \| \ X"$as_dir" : 'X\(//\)$' \| \ X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$as_dir" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` test -d "$as_dir" && break done test -z "$as_dirs" || eval "mkdir $as_dirs" } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" } # as_fn_mkdir_p # as_fn_executable_p FILE # ----------------------- # Test if FILE is an executable regular file. as_fn_executable_p () { test -f "$1" && test -x "$1" } # as_fn_executable_p # as_fn_append VAR VALUE # ---------------------- # Append the text in VALUE to the end of the definition contained in VAR. Take # advantage of any shell optimizations that allow amortized linear growth over # repeated appends, instead of the typical quadratic growth present in naive # implementations. if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null; then : eval 'as_fn_append () { eval $1+=\$2 }' else as_fn_append () { eval $1=\$$1\$2 } fi # as_fn_append # as_fn_arith ARG... # ------------------ # Perform arithmetic evaluation on the ARGs, and store the result in the # global $as_val. Take advantage of shells that can avoid forks. The arguments # must be portable across $(()) and expr. if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null; then : eval 'as_fn_arith () { as_val=$(( $* )) }' else as_fn_arith () { as_val=`expr "$@" || test $? -eq 1` } fi # as_fn_arith # as_fn_error STATUS ERROR [LINENO LOG_FD] # ---------------------------------------- # Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are # provided, also output the error to LOG_FD, referencing LINENO. Then exit the # script with STATUS, using 1 if that was 0. as_fn_error () { as_status=$1; test $as_status -eq 0 && as_status=1 if test "$4"; then as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 fi $as_echo "$as_me: error: $2" >&2 as_fn_exit $as_status } # as_fn_error if expr a : '\(a\)' >/dev/null 2>&1 && test "X`expr 00001 : '.*\(...\)'`" = X001; then as_expr=expr else as_expr=false fi if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then as_basename=basename else as_basename=false fi if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then as_dirname=dirname else as_dirname=false fi as_me=`$as_basename -- "$0" || $as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ X"$0" : 'X\(//\)$' \| \ X"$0" : 'X\(/\)' \| . 2>/dev/null || $as_echo X/"$0" | sed '/^.*\/\([^/][^/]*\)\/*$/{ s//\1/ q } /^X\/\(\/\/\)$/{ s//\1/ q } /^X\/\(\/\).*/{ s//\1/ q } s/.*/./; q'` # Avoid depending upon Character Ranges. as_cr_letters='abcdefghijklmnopqrstuvwxyz' as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' as_cr_Letters=$as_cr_letters$as_cr_LETTERS as_cr_digits='0123456789' as_cr_alnum=$as_cr_Letters$as_cr_digits as_lineno_1=$LINENO as_lineno_1a=$LINENO as_lineno_2=$LINENO as_lineno_2a=$LINENO eval 'test "x$as_lineno_1'$as_run'" != "x$as_lineno_2'$as_run'" && test "x`expr $as_lineno_1'$as_run' + 1`" = "x$as_lineno_2'$as_run'"' || { # Blame Lee E. McMahon (1931-1989) for sed's syntax. :-) sed -n ' p /[$]LINENO/= ' <$as_myself | sed ' s/[$]LINENO.*/&-/ t lineno b :lineno N :loop s/[$]LINENO\([^'$as_cr_alnum'_].*\n\)\(.*\)/\2\1\2/ t loop s/-\n.*// ' >$as_me.lineno && chmod +x "$as_me.lineno" || { $as_echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2; as_fn_exit 1; } # If we had to re-execute with $CONFIG_SHELL, we're ensured to have # already done that, so ensure we don't try to do so again and fall # in an infinite loop. This has already happened in practice. _as_can_reexec=no; export _as_can_reexec # Don't try to exec as it changes $[0], causing all sort of problems # (the dirname of $[0] is not the place where we might find the # original and so on. Autoconf is especially sensitive to this). . "./$as_me.lineno" # Exit status is that of the last command. exit } ECHO_C= ECHO_N= ECHO_T= case `echo -n x` in #((((( -n*) case `echo 'xy\c'` in *c*) ECHO_T=' ';; # ECHO_T is single tab character. xy) ECHO_C='\c';; *) echo `echo ksh88 bug on AIX 6.1` > /dev/null ECHO_T=' ';; esac;; *) ECHO_N='-n';; esac rm -f conf$$ conf$$.exe conf$$.file if test -d conf$$.dir; then rm -f conf$$.dir/conf$$.file else rm -f conf$$.dir mkdir conf$$.dir 2>/dev/null fi if (echo >conf$$.file) 2>/dev/null; then if ln -s conf$$.file conf$$ 2>/dev/null; then as_ln_s='ln -s' # ... but there are two gotchas: # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. # In both cases, we have to default to `cp -pR'. ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || as_ln_s='cp -pR' elif ln conf$$.file conf$$ 2>/dev/null; then as_ln_s=ln else as_ln_s='cp -pR' fi else as_ln_s='cp -pR' fi rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file rmdir conf$$.dir 2>/dev/null if mkdir -p . 2>/dev/null; then as_mkdir_p='mkdir -p "$as_dir"' else test -d ./-p && rmdir ./-p as_mkdir_p=false fi as_test_x='test -x' as_executable_p=as_fn_executable_p # Sed expression to map a string onto a valid CPP name. as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" # Sed expression to map a string onto a valid variable name. as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" as_awk_strverscmp=' # Use only awk features that work with 7th edition Unix awk (1978). # My, what an old awk you have, Mr. Solaris! END { while (length(v1) && length(v2)) { # Set d1 to be the next thing to compare from v1, and likewise for d2. # Normally this is a single character, but if v1 and v2 contain digits, # compare them as integers and fractions as strverscmp does. if (v1 ~ /^[0-9]/ && v2 ~ /^[0-9]/) { # Split v1 and v2 into their leading digit string components d1 and d2, # and advance v1 and v2 past the leading digit strings. for (len1 = 1; substr(v1, len1 + 1) ~ /^[0-9]/; len1++) continue for (len2 = 1; substr(v2, len2 + 1) ~ /^[0-9]/; len2++) continue d1 = substr(v1, 1, len1); v1 = substr(v1, len1 + 1) d2 = substr(v2, 1, len2); v2 = substr(v2, len2 + 1) if (d1 ~ /^0/) { if (d2 ~ /^0/) { # Compare two fractions. while (d1 ~ /^0/ && d2 ~ /^0/) { d1 = substr(d1, 2); len1-- d2 = substr(d2, 2); len2-- } if (len1 != len2 && ! (len1 && len2 && substr(d1, 1, 1) == substr(d2, 1, 1))) { # The two components differ in length, and the common prefix # contains only leading zeros. Consider the longer to be less. d1 = -len1 d2 = -len2 } else { # Otherwise, compare as strings. d1 = "x" d1 d2 = "x" d2 } } else { # A fraction is less than an integer. exit 1 } } else { if (d2 ~ /^0/) { # An integer is greater than a fraction. exit 2 } else { # Compare two integers. d1 += 0 d2 += 0 } } } else { # The normal case, without worrying about digits. d1 = substr(v1, 1, 1); v1 = substr(v1, 2) d2 = substr(v2, 1, 1); v2 = substr(v2, 2) } if (d1 < d2) exit 1 if (d1 > d2) exit 2 } # Beware Solaris /usr/xgp4/bin/awk (at least through Solaris 10), # which mishandles some comparisons of empty strings to integers. if (length(v2)) exit 1 if (length(v1)) exit 2 } ' test -n "$DJDIR" || exec 7<&0 &1 # Name of the host. # hostname on some systems (SVR3.2, old GNU/Linux) returns a bogus exit status, # so uname gets run too. ac_hostname=`(hostname || uname -n) 2>/dev/null | sed 1q` # # Initializations. # ac_default_prefix=/usr/local ac_clean_files= ac_config_libobj_dir=. LIBOBJS= cross_compiling=no subdirs= MFLAGS= MAKEFLAGS= # Identity of this package. PACKAGE_NAME= PACKAGE_TARNAME= PACKAGE_VERSION= PACKAGE_STRING= PACKAGE_BUGREPORT= PACKAGE_URL= ac_unique_file="DESCRIPTION" ac_subst_vars='OBJEXT EXEEXT ac_ct_FC LDFLAGS FCFLAGS FC SED GREP target_alias host_alias build_alias LIBS ECHO_T ECHO_N ECHO_C DEFS mandir localedir libdir psdir pdfdir dvidir htmldir infodir docdir oldincludedir includedir localstatedir sharedstatedir sysconfdir datadir datarootdir libexecdir sbindir bindir program_transform_name prefix exec_prefix PACKAGE_URL PACKAGE_BUGREPORT PACKAGE_STRING PACKAGE_VERSION PACKAGE_TARNAME PACKAGE_NAME PATH_SEPARATOR SHELL' ac_subst_files='' ac_user_opts=' enable_option_checking ' ac_precious_vars='build_alias host_alias target_alias FC FCFLAGS LDFLAGS LIBS' # Initialize some variables set by options. ac_init_help= ac_init_version=false ac_unrecognized_opts= ac_unrecognized_sep= # The variables have the same names as the options, with # dashes changed to underlines. cache_file=/dev/null exec_prefix=NONE no_create= no_recursion= prefix=NONE program_prefix=NONE program_suffix=NONE program_transform_name=s,x,x, silent= site= srcdir= verbose= x_includes=NONE x_libraries=NONE # Installation directory options. # These are left unexpanded so users can "make install exec_prefix=/foo" # and all the variables that are supposed to be based on exec_prefix # by default will actually change. # Use braces instead of parens because sh, perl, etc. also accept them. # (The list follows the same order as the GNU Coding Standards.) bindir='${exec_prefix}/bin' sbindir='${exec_prefix}/sbin' libexecdir='${exec_prefix}/libexec' datarootdir='${prefix}/share' datadir='${datarootdir}' sysconfdir='${prefix}/etc' sharedstatedir='${prefix}/com' localstatedir='${prefix}/var' includedir='${prefix}/include' oldincludedir='/usr/include' docdir='${datarootdir}/doc/${PACKAGE}' infodir='${datarootdir}/info' htmldir='${docdir}' dvidir='${docdir}' pdfdir='${docdir}' psdir='${docdir}' libdir='${exec_prefix}/lib' localedir='${datarootdir}/locale' mandir='${datarootdir}/man' ac_prev= ac_dashdash= for ac_option do # If the previous option needs an argument, assign it. if test -n "$ac_prev"; then eval $ac_prev=\$ac_option ac_prev= continue fi case $ac_option in *=?*) ac_optarg=`expr "X$ac_option" : '[^=]*=\(.*\)'` ;; *=) ac_optarg= ;; *) ac_optarg=yes ;; esac # Accept the important Cygnus configure options, so we can diagnose typos. case $ac_dashdash$ac_option in --) ac_dashdash=yes ;; -bindir | --bindir | --bindi | --bind | --bin | --bi) ac_prev=bindir ;; -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*) bindir=$ac_optarg ;; -build | --build | --buil | --bui | --bu) ac_prev=build_alias ;; -build=* | --build=* | --buil=* | --bui=* | --bu=*) build_alias=$ac_optarg ;; -cache-file | --cache-file | --cache-fil | --cache-fi \ | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c) ac_prev=cache_file ;; -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \ | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*) cache_file=$ac_optarg ;; --config-cache | -C) cache_file=config.cache ;; -datadir | --datadir | --datadi | --datad) ac_prev=datadir ;; -datadir=* | --datadir=* | --datadi=* | --datad=*) datadir=$ac_optarg ;; -datarootdir | --datarootdir | --datarootdi | --datarootd | --dataroot \ | --dataroo | --dataro | --datar) ac_prev=datarootdir ;; -datarootdir=* | --datarootdir=* | --datarootdi=* | --datarootd=* \ | --dataroot=* | --dataroo=* | --dataro=* | --datar=*) datarootdir=$ac_optarg ;; -disable-* | --disable-*) ac_useropt=`expr "x$ac_option" : 'x-*disable-\(.*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error $? "invalid feature name: $ac_useropt" ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "enable_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--disable-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval enable_$ac_useropt=no ;; -docdir | --docdir | --docdi | --doc | --do) ac_prev=docdir ;; -docdir=* | --docdir=* | --docdi=* | --doc=* | --do=*) docdir=$ac_optarg ;; -dvidir | --dvidir | --dvidi | --dvid | --dvi | --dv) ac_prev=dvidir ;; -dvidir=* | --dvidir=* | --dvidi=* | --dvid=* | --dvi=* | --dv=*) dvidir=$ac_optarg ;; -enable-* | --enable-*) ac_useropt=`expr "x$ac_option" : 'x-*enable-\([^=]*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error $? "invalid feature name: $ac_useropt" ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "enable_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--enable-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval enable_$ac_useropt=\$ac_optarg ;; -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \ | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \ | --exec | --exe | --ex) ac_prev=exec_prefix ;; -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \ | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \ | --exec=* | --exe=* | --ex=*) exec_prefix=$ac_optarg ;; -gas | --gas | --ga | --g) # Obsolete; use --with-gas. with_gas=yes ;; -help | --help | --hel | --he | -h) ac_init_help=long ;; -help=r* | --help=r* | --hel=r* | --he=r* | -hr*) ac_init_help=recursive ;; -help=s* | --help=s* | --hel=s* | --he=s* | -hs*) ac_init_help=short ;; -host | --host | --hos | --ho) ac_prev=host_alias ;; -host=* | --host=* | --hos=* | --ho=*) host_alias=$ac_optarg ;; -htmldir | --htmldir | --htmldi | --htmld | --html | --htm | --ht) ac_prev=htmldir ;; -htmldir=* | --htmldir=* | --htmldi=* | --htmld=* | --html=* | --htm=* \ | --ht=*) htmldir=$ac_optarg ;; -includedir | --includedir | --includedi | --included | --include \ | --includ | --inclu | --incl | --inc) ac_prev=includedir ;; -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \ | --includ=* | --inclu=* | --incl=* | --inc=*) includedir=$ac_optarg ;; -infodir | --infodir | --infodi | --infod | --info | --inf) ac_prev=infodir ;; -infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*) infodir=$ac_optarg ;; -libdir | --libdir | --libdi | --libd) ac_prev=libdir ;; -libdir=* | --libdir=* | --libdi=* | --libd=*) libdir=$ac_optarg ;; -libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \ | --libexe | --libex | --libe) ac_prev=libexecdir ;; -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \ | --libexe=* | --libex=* | --libe=*) libexecdir=$ac_optarg ;; -localedir | --localedir | --localedi | --localed | --locale) ac_prev=localedir ;; -localedir=* | --localedir=* | --localedi=* | --localed=* | --locale=*) localedir=$ac_optarg ;; -localstatedir | --localstatedir | --localstatedi | --localstated \ | --localstate | --localstat | --localsta | --localst | --locals) ac_prev=localstatedir ;; -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \ | --localstate=* | --localstat=* | --localsta=* | --localst=* | --locals=*) localstatedir=$ac_optarg ;; -mandir | --mandir | --mandi | --mand | --man | --ma | --m) ac_prev=mandir ;; -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*) mandir=$ac_optarg ;; -nfp | --nfp | --nf) # Obsolete; use --without-fp. with_fp=no ;; -no-create | --no-create | --no-creat | --no-crea | --no-cre \ | --no-cr | --no-c | -n) no_create=yes ;; -no-recursion | --no-recursion | --no-recursio | --no-recursi \ | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) no_recursion=yes ;; -oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \ | --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \ | --oldin | --oldi | --old | --ol | --o) ac_prev=oldincludedir ;; -oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \ | --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \ | --oldin=* | --oldi=* | --old=* | --ol=* | --o=*) oldincludedir=$ac_optarg ;; -prefix | --prefix | --prefi | --pref | --pre | --pr | --p) ac_prev=prefix ;; -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*) prefix=$ac_optarg ;; -program-prefix | --program-prefix | --program-prefi | --program-pref \ | --program-pre | --program-pr | --program-p) ac_prev=program_prefix ;; -program-prefix=* | --program-prefix=* | --program-prefi=* \ | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*) program_prefix=$ac_optarg ;; -program-suffix | --program-suffix | --program-suffi | --program-suff \ | --program-suf | --program-su | --program-s) ac_prev=program_suffix ;; -program-suffix=* | --program-suffix=* | --program-suffi=* \ | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*) program_suffix=$ac_optarg ;; -program-transform-name | --program-transform-name \ | --program-transform-nam | --program-transform-na \ | --program-transform-n | --program-transform- \ | --program-transform | --program-transfor \ | --program-transfo | --program-transf \ | --program-trans | --program-tran \ | --progr-tra | --program-tr | --program-t) ac_prev=program_transform_name ;; -program-transform-name=* | --program-transform-name=* \ | --program-transform-nam=* | --program-transform-na=* \ | --program-transform-n=* | --program-transform-=* \ | --program-transform=* | --program-transfor=* \ | --program-transfo=* | --program-transf=* \ | --program-trans=* | --program-tran=* \ | --progr-tra=* | --program-tr=* | --program-t=*) program_transform_name=$ac_optarg ;; -pdfdir | --pdfdir | --pdfdi | --pdfd | --pdf | --pd) ac_prev=pdfdir ;; -pdfdir=* | --pdfdir=* | --pdfdi=* | --pdfd=* | --pdf=* | --pd=*) pdfdir=$ac_optarg ;; -psdir | --psdir | --psdi | --psd | --ps) ac_prev=psdir ;; -psdir=* | --psdir=* | --psdi=* | --psd=* | --ps=*) psdir=$ac_optarg ;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil) silent=yes ;; -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb) ac_prev=sbindir ;; -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \ | --sbi=* | --sb=*) sbindir=$ac_optarg ;; -sharedstatedir | --sharedstatedir | --sharedstatedi \ | --sharedstated | --sharedstate | --sharedstat | --sharedsta \ | --sharedst | --shareds | --shared | --share | --shar \ | --sha | --sh) ac_prev=sharedstatedir ;; -sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \ | --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \ | --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \ | --sha=* | --sh=*) sharedstatedir=$ac_optarg ;; -site | --site | --sit) ac_prev=site ;; -site=* | --site=* | --sit=*) site=$ac_optarg ;; -srcdir | --srcdir | --srcdi | --srcd | --src | --sr) ac_prev=srcdir ;; -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*) srcdir=$ac_optarg ;; -sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \ | --syscon | --sysco | --sysc | --sys | --sy) ac_prev=sysconfdir ;; -sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \ | --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*) sysconfdir=$ac_optarg ;; -target | --target | --targe | --targ | --tar | --ta | --t) ac_prev=target_alias ;; -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*) target_alias=$ac_optarg ;; -v | -verbose | --verbose | --verbos | --verbo | --verb) verbose=yes ;; -version | --version | --versio | --versi | --vers | -V) ac_init_version=: ;; -with-* | --with-*) ac_useropt=`expr "x$ac_option" : 'x-*with-\([^=]*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error $? "invalid package name: $ac_useropt" ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "with_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--with-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval with_$ac_useropt=\$ac_optarg ;; -without-* | --without-*) ac_useropt=`expr "x$ac_option" : 'x-*without-\(.*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error $? "invalid package name: $ac_useropt" ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "with_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--without-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval with_$ac_useropt=no ;; --x) # Obsolete; use --with-x. with_x=yes ;; -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \ | --x-incl | --x-inc | --x-in | --x-i) ac_prev=x_includes ;; -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \ | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*) x_includes=$ac_optarg ;; -x-libraries | --x-libraries | --x-librarie | --x-librari \ | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l) ac_prev=x_libraries ;; -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \ | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*) x_libraries=$ac_optarg ;; -*) as_fn_error $? "unrecognized option: \`$ac_option' Try \`$0 --help' for more information" ;; *=*) ac_envvar=`expr "x$ac_option" : 'x\([^=]*\)='` # Reject names that are not valid shell variable names. case $ac_envvar in #( '' | [0-9]* | *[!_$as_cr_alnum]* ) as_fn_error $? "invalid variable name: \`$ac_envvar'" ;; esac eval $ac_envvar=\$ac_optarg export $ac_envvar ;; *) # FIXME: should be removed in autoconf 3.0. $as_echo "$as_me: WARNING: you should use --build, --host, --target" >&2 expr "x$ac_option" : ".*[^-._$as_cr_alnum]" >/dev/null && $as_echo "$as_me: WARNING: invalid host type: $ac_option" >&2 : "${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option}" ;; esac done if test -n "$ac_prev"; then ac_option=--`echo $ac_prev | sed 's/_/-/g'` as_fn_error $? "missing argument to $ac_option" fi if test -n "$ac_unrecognized_opts"; then case $enable_option_checking in no) ;; fatal) as_fn_error $? "unrecognized options: $ac_unrecognized_opts" ;; *) $as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2 ;; esac fi # Check all directory arguments for consistency. for ac_var in exec_prefix prefix bindir sbindir libexecdir datarootdir \ datadir sysconfdir sharedstatedir localstatedir includedir \ oldincludedir docdir infodir htmldir dvidir pdfdir psdir \ libdir localedir mandir do eval ac_val=\$$ac_var # Remove trailing slashes. case $ac_val in */ ) ac_val=`expr "X$ac_val" : 'X\(.*[^/]\)' \| "X$ac_val" : 'X\(.*\)'` eval $ac_var=\$ac_val;; esac # Be sure to have absolute directory names. case $ac_val in [\\/$]* | ?:[\\/]* ) continue;; NONE | '' ) case $ac_var in *prefix ) continue;; esac;; esac as_fn_error $? "expected an absolute directory name for --$ac_var: $ac_val" done # There might be people who depend on the old broken behavior: `$host' # used to hold the argument of --host etc. # FIXME: To remove some day. build=$build_alias host=$host_alias target=$target_alias # FIXME: To remove some day. if test "x$host_alias" != x; then if test "x$build_alias" = x; then cross_compiling=maybe elif test "x$build_alias" != "x$host_alias"; then cross_compiling=yes fi fi ac_tool_prefix= test -n "$host_alias" && ac_tool_prefix=$host_alias- test "$silent" = yes && exec 6>/dev/null ac_pwd=`pwd` && test -n "$ac_pwd" && ac_ls_di=`ls -di .` && ac_pwd_ls_di=`cd "$ac_pwd" && ls -di .` || as_fn_error $? "working directory cannot be determined" test "X$ac_ls_di" = "X$ac_pwd_ls_di" || as_fn_error $? "pwd does not report name of working directory" # Find the source files, if location was not specified. if test -z "$srcdir"; then ac_srcdir_defaulted=yes # Try the directory containing this script, then the parent directory. ac_confdir=`$as_dirname -- "$as_myself" || $as_expr X"$as_myself" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$as_myself" : 'X\(//\)[^/]' \| \ X"$as_myself" : 'X\(//\)$' \| \ X"$as_myself" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$as_myself" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` srcdir=$ac_confdir if test ! -r "$srcdir/$ac_unique_file"; then srcdir=.. fi else ac_srcdir_defaulted=no fi if test ! -r "$srcdir/$ac_unique_file"; then test "$ac_srcdir_defaulted" = yes && srcdir="$ac_confdir or .." as_fn_error $? "cannot find sources ($ac_unique_file) in $srcdir" fi ac_msg="sources are in $srcdir, but \`cd $srcdir' does not work" ac_abs_confdir=`( cd "$srcdir" && test -r "./$ac_unique_file" || as_fn_error $? "$ac_msg" pwd)` # When building in place, set srcdir=. if test "$ac_abs_confdir" = "$ac_pwd"; then srcdir=. fi # Remove unnecessary trailing slashes from srcdir. # Double slashes in file names in object file debugging info # mess up M-x gdb in Emacs. case $srcdir in */) srcdir=`expr "X$srcdir" : 'X\(.*[^/]\)' \| "X$srcdir" : 'X\(.*\)'`;; esac for ac_var in $ac_precious_vars; do eval ac_env_${ac_var}_set=\${${ac_var}+set} eval ac_env_${ac_var}_value=\$${ac_var} eval ac_cv_env_${ac_var}_set=\${${ac_var}+set} eval ac_cv_env_${ac_var}_value=\$${ac_var} done # # Report the --help message. # if test "$ac_init_help" = "long"; then # Omit some internal or obsolete options to make the list less imposing. # This message is too long to be a string in the A/UX 3.1 sh. cat <<_ACEOF \`configure' configures this package to adapt to many kinds of systems. Usage: $0 [OPTION]... [VAR=VALUE]... To assign environment variables (e.g., CC, CFLAGS...), specify them as VAR=VALUE. See below for descriptions of some of the useful variables. Defaults for the options are specified in brackets. Configuration: -h, --help display this help and exit --help=short display options specific to this package --help=recursive display the short help of all the included packages -V, --version display version information and exit -q, --quiet, --silent do not print \`checking ...' messages --cache-file=FILE cache test results in FILE [disabled] -C, --config-cache alias for \`--cache-file=config.cache' -n, --no-create do not create output files --srcdir=DIR find the sources in DIR [configure dir or \`..'] Installation directories: --prefix=PREFIX install architecture-independent files in PREFIX [$ac_default_prefix] --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX [PREFIX] By default, \`make install' will install all the files in \`$ac_default_prefix/bin', \`$ac_default_prefix/lib' etc. You can specify an installation prefix other than \`$ac_default_prefix' using \`--prefix', for instance \`--prefix=\$HOME'. For better control, use the options below. Fine tuning of the installation directories: --bindir=DIR user executables [EPREFIX/bin] --sbindir=DIR system admin executables [EPREFIX/sbin] --libexecdir=DIR program executables [EPREFIX/libexec] --sysconfdir=DIR read-only single-machine data [PREFIX/etc] --sharedstatedir=DIR modifiable architecture-independent data [PREFIX/com] --localstatedir=DIR modifiable single-machine data [PREFIX/var] --libdir=DIR object code libraries [EPREFIX/lib] --includedir=DIR C header files [PREFIX/include] --oldincludedir=DIR C header files for non-gcc [/usr/include] --datarootdir=DIR read-only arch.-independent data root [PREFIX/share] --datadir=DIR read-only architecture-independent data [DATAROOTDIR] --infodir=DIR info documentation [DATAROOTDIR/info] --localedir=DIR locale-dependent data [DATAROOTDIR/locale] --mandir=DIR man documentation [DATAROOTDIR/man] --docdir=DIR documentation root [DATAROOTDIR/doc/PACKAGE] --htmldir=DIR html documentation [DOCDIR] --dvidir=DIR dvi documentation [DOCDIR] --pdfdir=DIR pdf documentation [DOCDIR] --psdir=DIR ps documentation [DOCDIR] _ACEOF cat <<\_ACEOF _ACEOF fi if test -n "$ac_init_help"; then cat <<\_ACEOF Some influential environment variables: FC Fortran compiler command FCFLAGS Fortran compiler flags LDFLAGS linker flags, e.g. -L if you have libraries in a nonstandard directory LIBS libraries to pass to the linker, e.g. -l Use these variables to override the choices made by `configure' or to help it to find libraries and programs with nonstandard names/locations. Report bugs to the package provider. _ACEOF ac_status=$? fi if test "$ac_init_help" = "recursive"; then # If there are subdirs, report their specific --help. for ac_dir in : $ac_subdirs_all; do test "x$ac_dir" = x: && continue test -d "$ac_dir" || { cd "$srcdir" && ac_pwd=`pwd` && srcdir=. && test -d "$ac_dir"; } || continue ac_builddir=. case "$ac_dir" in .) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_dir_suffix=/`$as_echo "$ac_dir" | sed 's|^\.[\\/]||'` # A ".." for each directory in $ac_dir_suffix. ac_top_builddir_sub=`$as_echo "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'` case $ac_top_builddir_sub in "") ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_top_build_prefix=$ac_top_builddir_sub/ ;; esac ;; esac ac_abs_top_builddir=$ac_pwd ac_abs_builddir=$ac_pwd$ac_dir_suffix # for backward compatibility: ac_top_builddir=$ac_top_build_prefix case $srcdir in .) # We are building in place. ac_srcdir=. ac_top_srcdir=$ac_top_builddir_sub ac_abs_top_srcdir=$ac_pwd ;; [\\/]* | ?:[\\/]* ) # Absolute name. ac_srcdir=$srcdir$ac_dir_suffix; ac_top_srcdir=$srcdir ac_abs_top_srcdir=$srcdir ;; *) # Relative name. ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix ac_top_srcdir=$ac_top_build_prefix$srcdir ac_abs_top_srcdir=$ac_pwd/$srcdir ;; esac ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix cd "$ac_dir" || { ac_status=$?; continue; } # Check for guested configure. if test -f "$ac_srcdir/configure.gnu"; then echo && $SHELL "$ac_srcdir/configure.gnu" --help=recursive elif test -f "$ac_srcdir/configure"; then echo && $SHELL "$ac_srcdir/configure" --help=recursive else $as_echo "$as_me: WARNING: no configuration information is in $ac_dir" >&2 fi || ac_status=$? cd "$ac_pwd" || { ac_status=$?; break; } done fi test -n "$ac_init_help" && exit $ac_status if $ac_init_version; then cat <<\_ACEOF configure generated by GNU Autoconf 2.69 Copyright (C) 2012 Free Software Foundation, Inc. This configure script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it. _ACEOF exit fi ## ------------------------ ## ## Autoconf initialization. ## ## ------------------------ ## # ac_fn_fc_try_compile LINENO # --------------------------- # Try to compile conftest.$ac_ext, and return whether this succeeded. ac_fn_fc_try_compile () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack rm -f conftest.$ac_objext if { { ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_compile") 2>conftest.err ac_status=$? if test -s conftest.err; then grep -v '^ *+' conftest.err >conftest.er1 cat conftest.er1 >&5 mv -f conftest.er1 conftest.err fi $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } && { test -z "$ac_fc_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then : ac_retval=0 else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_retval=1 fi eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno as_fn_set_status $ac_retval } # ac_fn_fc_try_compile cat >config.log <<_ACEOF This file contains any messages produced by compilers while running configure, to aid debugging if configure makes a mistake. It was created by $as_me, which was generated by GNU Autoconf 2.69. Invocation command line was $ $0 $@ _ACEOF exec 5>>config.log { cat <<_ASUNAME ## --------- ## ## Platform. ## ## --------- ## hostname = `(hostname || uname -n) 2>/dev/null | sed 1q` uname -m = `(uname -m) 2>/dev/null || echo unknown` uname -r = `(uname -r) 2>/dev/null || echo unknown` uname -s = `(uname -s) 2>/dev/null || echo unknown` uname -v = `(uname -v) 2>/dev/null || echo unknown` /usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null || echo unknown` /bin/uname -X = `(/bin/uname -X) 2>/dev/null || echo unknown` /bin/arch = `(/bin/arch) 2>/dev/null || echo unknown` /usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null || echo unknown` /usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null || echo unknown` /usr/bin/hostinfo = `(/usr/bin/hostinfo) 2>/dev/null || echo unknown` /bin/machine = `(/bin/machine) 2>/dev/null || echo unknown` /usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null || echo unknown` /bin/universe = `(/bin/universe) 2>/dev/null || echo unknown` _ASUNAME as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. $as_echo "PATH: $as_dir" done IFS=$as_save_IFS } >&5 cat >&5 <<_ACEOF ## ----------- ## ## Core tests. ## ## ----------- ## _ACEOF # Keep a trace of the command line. # Strip out --no-create and --no-recursion so they do not pile up. # Strip out --silent because we don't want to record it for future runs. # Also quote any args containing shell meta-characters. # Make two passes to allow for proper duplicate-argument suppression. ac_configure_args= ac_configure_args0= ac_configure_args1= ac_must_keep_next=false for ac_pass in 1 2 do for ac_arg do case $ac_arg in -no-create | --no-c* | -n | -no-recursion | --no-r*) continue ;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil) continue ;; *\'*) ac_arg=`$as_echo "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;; esac case $ac_pass in 1) as_fn_append ac_configure_args0 " '$ac_arg'" ;; 2) as_fn_append ac_configure_args1 " '$ac_arg'" if test $ac_must_keep_next = true; then ac_must_keep_next=false # Got value, back to normal. else case $ac_arg in *=* | --config-cache | -C | -disable-* | --disable-* \ | -enable-* | --enable-* | -gas | --g* | -nfp | --nf* \ | -q | -quiet | --q* | -silent | --sil* | -v | -verb* \ | -with-* | --with-* | -without-* | --without-* | --x) case "$ac_configure_args0 " in "$ac_configure_args1"*" '$ac_arg' "* ) continue ;; esac ;; -* ) ac_must_keep_next=true ;; esac fi as_fn_append ac_configure_args " '$ac_arg'" ;; esac done done { ac_configure_args0=; unset ac_configure_args0;} { ac_configure_args1=; unset ac_configure_args1;} # When interrupted or exit'd, cleanup temporary files, and complete # config.log. We remove comments because anyway the quotes in there # would cause problems or look ugly. # WARNING: Use '\'' to represent an apostrophe within the trap. # WARNING: Do not start the trap code with a newline, due to a FreeBSD 4.0 bug. trap 'exit_status=$? # Save into config.log some information that might help in debugging. { echo $as_echo "## ---------------- ## ## Cache variables. ## ## ---------------- ##" echo # The following way of writing the cache mishandles newlines in values, ( for ac_var in `(set) 2>&1 | sed -n '\''s/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'\''`; do eval ac_val=\$$ac_var case $ac_val in #( *${as_nl}*) case $ac_var in #( *_cv_*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5 $as_echo "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; esac case $ac_var in #( _ | IFS | as_nl) ;; #( BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #( *) { eval $ac_var=; unset $ac_var;} ;; esac ;; esac done (set) 2>&1 | case $as_nl`(ac_space='\'' '\''; set) 2>&1` in #( *${as_nl}ac_space=\ *) sed -n \ "s/'\''/'\''\\\\'\'''\''/g; s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\''\\2'\''/p" ;; #( *) sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" ;; esac | sort ) echo $as_echo "## ----------------- ## ## Output variables. ## ## ----------------- ##" echo for ac_var in $ac_subst_vars do eval ac_val=\$$ac_var case $ac_val in *\'\''*) ac_val=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; esac $as_echo "$ac_var='\''$ac_val'\''" done | sort echo if test -n "$ac_subst_files"; then $as_echo "## ------------------- ## ## File substitutions. ## ## ------------------- ##" echo for ac_var in $ac_subst_files do eval ac_val=\$$ac_var case $ac_val in *\'\''*) ac_val=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; esac $as_echo "$ac_var='\''$ac_val'\''" done | sort echo fi if test -s confdefs.h; then $as_echo "## ----------- ## ## confdefs.h. ## ## ----------- ##" echo cat confdefs.h echo fi test "$ac_signal" != 0 && $as_echo "$as_me: caught signal $ac_signal" $as_echo "$as_me: exit $exit_status" } >&5 rm -f core *.core core.conftest.* && rm -f -r conftest* confdefs* conf$$* $ac_clean_files && exit $exit_status ' 0 for ac_signal in 1 2 13 15; do trap 'ac_signal='$ac_signal'; as_fn_exit 1' $ac_signal done ac_signal=0 # confdefs.h avoids OS command line length limits that DEFS can exceed. rm -f -r conftest* confdefs.h $as_echo "/* confdefs.h */" > confdefs.h # Predefined preprocessor variables. cat >>confdefs.h <<_ACEOF #define PACKAGE_NAME "$PACKAGE_NAME" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_TARNAME "$PACKAGE_TARNAME" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_VERSION "$PACKAGE_VERSION" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_STRING "$PACKAGE_STRING" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_BUGREPORT "$PACKAGE_BUGREPORT" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_URL "$PACKAGE_URL" _ACEOF # Let the site file select an alternate cache file if it wants to. # Prefer an explicitly selected file to automatically selected ones. ac_site_file1=NONE ac_site_file2=NONE if test -n "$CONFIG_SITE"; then # We do not want a PATH search for config.site. case $CONFIG_SITE in #(( -*) ac_site_file1=./$CONFIG_SITE;; */*) ac_site_file1=$CONFIG_SITE;; *) ac_site_file1=./$CONFIG_SITE;; esac elif test "x$prefix" != xNONE; then ac_site_file1=$prefix/share/config.site ac_site_file2=$prefix/etc/config.site else ac_site_file1=$ac_default_prefix/share/config.site ac_site_file2=$ac_default_prefix/etc/config.site fi for ac_site_file in "$ac_site_file1" "$ac_site_file2" do test "x$ac_site_file" = xNONE && continue if test /dev/null != "$ac_site_file" && test -r "$ac_site_file"; then { $as_echo "$as_me:${as_lineno-$LINENO}: loading site script $ac_site_file" >&5 $as_echo "$as_me: loading site script $ac_site_file" >&6;} sed 's/^/| /' "$ac_site_file" >&5 . "$ac_site_file" \ || { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "failed to load site script $ac_site_file See \`config.log' for more details" "$LINENO" 5; } fi done if test -r "$cache_file"; then # Some versions of bash will fail to source /dev/null (special files # actually), so we avoid doing that. DJGPP emulates it as a regular file. if test /dev/null != "$cache_file" && test -f "$cache_file"; then { $as_echo "$as_me:${as_lineno-$LINENO}: loading cache $cache_file" >&5 $as_echo "$as_me: loading cache $cache_file" >&6;} case $cache_file in [\\/]* | ?:[\\/]* ) . "$cache_file";; *) . "./$cache_file";; esac fi else { $as_echo "$as_me:${as_lineno-$LINENO}: creating cache $cache_file" >&5 $as_echo "$as_me: creating cache $cache_file" >&6;} >$cache_file fi # Check that the precious variables saved in the cache have kept the same # value. ac_cache_corrupted=false for ac_var in $ac_precious_vars; do eval ac_old_set=\$ac_cv_env_${ac_var}_set eval ac_new_set=\$ac_env_${ac_var}_set eval ac_old_val=\$ac_cv_env_${ac_var}_value eval ac_new_val=\$ac_env_${ac_var}_value case $ac_old_set,$ac_new_set in set,) { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5 $as_echo "$as_me: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&2;} ac_cache_corrupted=: ;; ,set) { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was not set in the previous run" >&5 $as_echo "$as_me: error: \`$ac_var' was not set in the previous run" >&2;} ac_cache_corrupted=: ;; ,);; *) if test "x$ac_old_val" != "x$ac_new_val"; then # differences in whitespace do not lead to failure. ac_old_val_w=`echo x $ac_old_val` ac_new_val_w=`echo x $ac_new_val` if test "$ac_old_val_w" != "$ac_new_val_w"; then { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' has changed since the previous run:" >&5 $as_echo "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;} ac_cache_corrupted=: else { $as_echo "$as_me:${as_lineno-$LINENO}: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&5 $as_echo "$as_me: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&2;} eval $ac_var=\$ac_old_val fi { $as_echo "$as_me:${as_lineno-$LINENO}: former value: \`$ac_old_val'" >&5 $as_echo "$as_me: former value: \`$ac_old_val'" >&2;} { $as_echo "$as_me:${as_lineno-$LINENO}: current value: \`$ac_new_val'" >&5 $as_echo "$as_me: current value: \`$ac_new_val'" >&2;} fi;; esac # Pass precious variables to config.status. if test "$ac_new_set" = set; then case $ac_new_val in *\'*) ac_arg=$ac_var=`$as_echo "$ac_new_val" | sed "s/'/'\\\\\\\\''/g"` ;; *) ac_arg=$ac_var=$ac_new_val ;; esac case " $ac_configure_args " in *" '$ac_arg' "*) ;; # Avoid dups. Use of quotes ensures accuracy. *) as_fn_append ac_configure_args " '$ac_arg'" ;; esac fi done if $ac_cache_corrupted; then { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} { $as_echo "$as_me:${as_lineno-$LINENO}: error: changes in the environment can compromise the build" >&5 $as_echo "$as_me: error: changes in the environment can compromise the build" >&2;} as_fn_error $? "run \`make distclean' and/or \`rm $cache_file' and start over" "$LINENO" 5 fi ## -------------------- ## ## Main body of script. ## ## -------------------- ## ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu { $as_echo "$as_me:${as_lineno-$LINENO}: checking for grep that handles long lines and -e" >&5 $as_echo_n "checking for grep that handles long lines and -e... " >&6; } if ${ac_cv_path_GREP+:} false; then : $as_echo_n "(cached) " >&6 else if test -z "$GREP"; then ac_path_GREP_found=false # Loop through the user's path and test for each of PROGNAME-LIST as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH$PATH_SEPARATOR/usr/xpg4/bin do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_prog in grep ggrep; do for ac_exec_ext in '' $ac_executable_extensions; do ac_path_GREP="$as_dir/$ac_prog$ac_exec_ext" as_fn_executable_p "$ac_path_GREP" || continue # Check for GNU ac_path_GREP and select it if it is found. # Check for GNU $ac_path_GREP case `"$ac_path_GREP" --version 2>&1` in *GNU*) ac_cv_path_GREP="$ac_path_GREP" ac_path_GREP_found=:;; *) ac_count=0 $as_echo_n 0123456789 >"conftest.in" while : do cat "conftest.in" "conftest.in" >"conftest.tmp" mv "conftest.tmp" "conftest.in" cp "conftest.in" "conftest.nl" $as_echo 'GREP' >> "conftest.nl" "$ac_path_GREP" -e 'GREP$' -e '-(cannot match)-' < "conftest.nl" >"conftest.out" 2>/dev/null || break diff "conftest.out" "conftest.nl" >/dev/null 2>&1 || break as_fn_arith $ac_count + 1 && ac_count=$as_val if test $ac_count -gt ${ac_path_GREP_max-0}; then # Best one so far, save it but keep looking for a better one ac_cv_path_GREP="$ac_path_GREP" ac_path_GREP_max=$ac_count fi # 10*(2^10) chars as input seems more than enough test $ac_count -gt 10 && break done rm -f conftest.in conftest.tmp conftest.nl conftest.out;; esac $ac_path_GREP_found && break 3 done done done IFS=$as_save_IFS if test -z "$ac_cv_path_GREP"; then as_fn_error $? "no acceptable grep could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" "$LINENO" 5 fi else ac_cv_path_GREP=$GREP fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_path_GREP" >&5 $as_echo "$ac_cv_path_GREP" >&6; } GREP="$ac_cv_path_GREP" { $as_echo "$as_me:${as_lineno-$LINENO}: checking for a sed that does not truncate output" >&5 $as_echo_n "checking for a sed that does not truncate output... " >&6; } if ${ac_cv_path_SED+:} false; then : $as_echo_n "(cached) " >&6 else ac_script=s/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa/bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb/ for ac_i in 1 2 3 4 5 6 7; do ac_script="$ac_script$as_nl$ac_script" done echo "$ac_script" 2>/dev/null | sed 99q >conftest.sed { ac_script=; unset ac_script;} if test -z "$SED"; then ac_path_SED_found=false # Loop through the user's path and test for each of PROGNAME-LIST as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_prog in sed gsed; do for ac_exec_ext in '' $ac_executable_extensions; do ac_path_SED="$as_dir/$ac_prog$ac_exec_ext" as_fn_executable_p "$ac_path_SED" || continue # Check for GNU ac_path_SED and select it if it is found. # Check for GNU $ac_path_SED case `"$ac_path_SED" --version 2>&1` in *GNU*) ac_cv_path_SED="$ac_path_SED" ac_path_SED_found=:;; *) ac_count=0 $as_echo_n 0123456789 >"conftest.in" while : do cat "conftest.in" "conftest.in" >"conftest.tmp" mv "conftest.tmp" "conftest.in" cp "conftest.in" "conftest.nl" $as_echo '' >> "conftest.nl" "$ac_path_SED" -f conftest.sed < "conftest.nl" >"conftest.out" 2>/dev/null || break diff "conftest.out" "conftest.nl" >/dev/null 2>&1 || break as_fn_arith $ac_count + 1 && ac_count=$as_val if test $ac_count -gt ${ac_path_SED_max-0}; then # Best one so far, save it but keep looking for a better one ac_cv_path_SED="$ac_path_SED" ac_path_SED_max=$ac_count fi # 10*(2^10) chars as input seems more than enough test $ac_count -gt 10 && break done rm -f conftest.in conftest.tmp conftest.nl conftest.out;; esac $ac_path_SED_found && break 3 done done done IFS=$as_save_IFS if test -z "$ac_cv_path_SED"; then as_fn_error $? "no acceptable sed could be found in \$PATH" "$LINENO" 5 fi else ac_cv_path_SED=$SED fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_path_SED" >&5 $as_echo "$ac_cv_path_SED" >&6; } SED="$ac_cv_path_SED" rm -f conftest.sed : ${R_HOME=`R RHOME`} if test -z "${R_HOME}"; then echo "could not determine R_HOME" exit 1 fi FC=`"${R_HOME}/bin/R" CMD config FC` if test -z "${FC}"; then { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: R could not find a Fortran compiler. Now trying to detect one." >&5 $as_echo "$as_me: WARNING: R could not find a Fortran compiler. Now trying to detect one." >&2;} ac_ext=${ac_fc_srcext-f} ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5' ac_link='$FC -o conftest$ac_exeext $FCFLAGS $LDFLAGS $ac_fcflags_srcext conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_fc_compiler_gnu if test -n "$ac_tool_prefix"; then for ac_prog in gfortran g95 xlf95 f95 fort ifort ifc efc pgfortran pgf95 lf95 ftn nagfor xlf90 f90 pgf90 pghpf epcf90 g77 xlf f77 frt pgf77 cf77 fort77 fl32 af77 do # Extract the first word of "$ac_tool_prefix$ac_prog", so it can be a program name with args. set dummy $ac_tool_prefix$ac_prog; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_FC+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$FC"; then ac_cv_prog_FC="$FC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_FC="$ac_tool_prefix$ac_prog" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi FC=$ac_cv_prog_FC if test -n "$FC"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $FC" >&5 $as_echo "$FC" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi test -n "$FC" && break done fi if test -z "$FC"; then ac_ct_FC=$FC for ac_prog in gfortran g95 xlf95 f95 fort ifort ifc efc pgfortran pgf95 lf95 ftn nagfor xlf90 f90 pgf90 pghpf epcf90 g77 xlf f77 frt pgf77 cf77 fort77 fl32 af77 do # Extract the first word of "$ac_prog", so it can be a program name with args. set dummy $ac_prog; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_ac_ct_FC+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$ac_ct_FC"; then ac_cv_prog_ac_ct_FC="$ac_ct_FC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_ac_ct_FC="$ac_prog" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi ac_ct_FC=$ac_cv_prog_ac_ct_FC if test -n "$ac_ct_FC"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_FC" >&5 $as_echo "$ac_ct_FC" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi test -n "$ac_ct_FC" && break done if test "x$ac_ct_FC" = x; then FC="" else case $cross_compiling:$ac_tool_warned in yes:) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 $as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac FC=$ac_ct_FC fi fi # Provide some information about the compiler. $as_echo "$as_me:${as_lineno-$LINENO}: checking for Fortran compiler version" >&5 set X $ac_compile ac_compiler=$2 for ac_option in --version -v -V -qversion; do { { ac_try="$ac_compiler $ac_option >&5" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_compiler $ac_option >&5") 2>conftest.err ac_status=$? if test -s conftest.err; then sed '10a\ ... rest of stderr output deleted ... 10q' conftest.err >conftest.er1 cat conftest.er1 >&5 fi rm -f conftest.er1 conftest.err $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } done rm -f a.out cat > conftest.$ac_ext <<_ACEOF program main end _ACEOF ac_clean_files_save=$ac_clean_files ac_clean_files="$ac_clean_files a.out a.out.dSYM a.exe b.out" # Try to create an executable without -o first, disregard a.out. # It will help us diagnose broken compilers, and finding out an intuition # of exeext. { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether the Fortran compiler works" >&5 $as_echo_n "checking whether the Fortran compiler works... " >&6; } ac_link_default=`$as_echo "$ac_link" | sed 's/ -o *conftest[^ ]*//'` # The possible output files: ac_files="a.out conftest.exe conftest a.exe a_out.exe b.out conftest.*" ac_rmfiles= for ac_file in $ac_files do case $ac_file in *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;; * ) ac_rmfiles="$ac_rmfiles $ac_file";; esac done rm -f $ac_rmfiles if { { ac_try="$ac_link_default" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_link_default") 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; }; then : # Autoconf-2.13 could set the ac_cv_exeext variable to `no'. # So ignore a value of `no', otherwise this would lead to `EXEEXT = no' # in a Makefile. We should not override ac_cv_exeext if it was cached, # so that the user can short-circuit this test for compilers unknown to # Autoconf. for ac_file in $ac_files '' do test -f "$ac_file" || continue case $ac_file in *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;; [ab].out ) # We found the default executable, but exeext='' is most # certainly right. break;; *.* ) if test "${ac_cv_exeext+set}" = set && test "$ac_cv_exeext" != no; then :; else ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` fi # We set ac_cv_exeext here because the later test for it is not # safe: cross compilers may not add the suffix if given an `-o' # argument, so we may need to know it at that point already. # Even if this section looks crufty: it has the advantage of # actually working. break;; * ) break;; esac done test "$ac_cv_exeext" = no && ac_cv_exeext= else ac_file='' fi if test -z "$ac_file"; then : { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error 77 "Fortran compiler cannot create executables See \`config.log' for more details" "$LINENO" 5; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking for Fortran compiler default output file name" >&5 $as_echo_n "checking for Fortran compiler default output file name... " >&6; } { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_file" >&5 $as_echo "$ac_file" >&6; } ac_exeext=$ac_cv_exeext rm -f -r a.out a.out.dSYM a.exe conftest$ac_cv_exeext b.out ac_clean_files=$ac_clean_files_save { $as_echo "$as_me:${as_lineno-$LINENO}: checking for suffix of executables" >&5 $as_echo_n "checking for suffix of executables... " >&6; } if { { ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_link") 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; }; then : # If both `conftest.exe' and `conftest' are `present' (well, observable) # catch `conftest.exe'. For instance with Cygwin, `ls conftest' will # work properly (i.e., refer to `conftest.exe'), while it won't with # `rm'. for ac_file in conftest.exe conftest conftest.*; do test -f "$ac_file" || continue case $ac_file in *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;; *.* ) ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` break;; * ) break;; esac done else { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot compute suffix of executables: cannot compile and link See \`config.log' for more details" "$LINENO" 5; } fi rm -f conftest conftest$ac_cv_exeext { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_exeext" >&5 $as_echo "$ac_cv_exeext" >&6; } rm -f conftest.$ac_ext EXEEXT=$ac_cv_exeext ac_exeext=$EXEEXT cat > conftest.$ac_ext <<_ACEOF program main open(unit=9,file='conftest.out') close(unit=9) end _ACEOF ac_clean_files="$ac_clean_files conftest.out" # Check that the compiler produces executables we can run. If not, either # the compiler is broken, or we cross compile. { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether we are cross compiling" >&5 $as_echo_n "checking whether we are cross compiling... " >&6; } if test "$cross_compiling" != yes; then { { ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_link") 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } if { ac_try='./conftest$ac_cv_exeext' { { case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_try") 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; }; }; then cross_compiling=no else if test "$cross_compiling" = maybe; then cross_compiling=yes else { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run Fortran compiled programs. If you meant to cross compile, use \`--host'. See \`config.log' for more details" "$LINENO" 5; } fi fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $cross_compiling" >&5 $as_echo "$cross_compiling" >&6; } rm -f conftest.$ac_ext conftest$ac_cv_exeext conftest.out ac_clean_files=$ac_clean_files_save { $as_echo "$as_me:${as_lineno-$LINENO}: checking for suffix of object files" >&5 $as_echo_n "checking for suffix of object files... " >&6; } if ${ac_cv_objext+:} false; then : $as_echo_n "(cached) " >&6 else cat > conftest.$ac_ext <<_ACEOF program main end _ACEOF rm -f conftest.o conftest.obj if { { ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_compile") 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; }; then : for ac_file in conftest.o conftest.obj conftest.*; do test -f "$ac_file" || continue; case $ac_file in *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM ) ;; *) ac_cv_objext=`expr "$ac_file" : '.*\.\(.*\)'` break;; esac done else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot compute suffix of object files: cannot compile See \`config.log' for more details" "$LINENO" 5; } fi rm -f conftest.$ac_cv_objext conftest.$ac_ext fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_objext" >&5 $as_echo "$ac_cv_objext" >&6; } OBJEXT=$ac_cv_objext ac_objext=$OBJEXT # If we don't use `.F' as extension, the preprocessor is not run on the # input file. (Note that this only needs to work for GNU compilers.) ac_save_ext=$ac_ext ac_ext=F { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether we are using the GNU Fortran compiler" >&5 $as_echo_n "checking whether we are using the GNU Fortran compiler... " >&6; } if ${ac_cv_fc_compiler_gnu+:} false; then : $as_echo_n "(cached) " >&6 else cat > conftest.$ac_ext <<_ACEOF program main #ifndef __GNUC__ choke me #endif end _ACEOF if ac_fn_fc_try_compile "$LINENO"; then : ac_compiler_gnu=yes else ac_compiler_gnu=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext ac_cv_fc_compiler_gnu=$ac_compiler_gnu fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_fc_compiler_gnu" >&5 $as_echo "$ac_cv_fc_compiler_gnu" >&6; } ac_ext=$ac_save_ext ac_test_FCFLAGS=${FCFLAGS+set} ac_save_FCFLAGS=$FCFLAGS FCFLAGS= { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether $FC accepts -g" >&5 $as_echo_n "checking whether $FC accepts -g... " >&6; } if ${ac_cv_prog_fc_g+:} false; then : $as_echo_n "(cached) " >&6 else FCFLAGS=-g cat > conftest.$ac_ext <<_ACEOF program main end _ACEOF if ac_fn_fc_try_compile "$LINENO"; then : ac_cv_prog_fc_g=yes else ac_cv_prog_fc_g=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_fc_g" >&5 $as_echo "$ac_cv_prog_fc_g" >&6; } if test "$ac_test_FCFLAGS" = set; then FCFLAGS=$ac_save_FCFLAGS elif test $ac_cv_prog_fc_g = yes; then if test "x$ac_cv_fc_compiler_gnu" = xyes; then FCFLAGS="-g -O2" else FCFLAGS="-g" fi else if test "x$ac_cv_fc_compiler_gnu" = xyes; then FCFLAGS="-O2" else FCFLAGS= fi fi if test $ac_compiler_gnu = yes; then GFC=yes else GFC= fi ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking for Fortran compiler" >&5 $as_echo_n "checking for Fortran compiler... " >&6; } case "${FC}" in *gfortran*) GNU_FORTRAN=`${FC} --version | ${GREP} 'GNU Fortran'` if test -z "${GNU_FORTRAN}"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } as_fn_error $? "Fortran compiler (${FC}) does not seem to be GNU Fortran." "$LINENO" 5 fi MINI_GFORTRAN_VERSION="4.6.3" FC_VERSION=`echo "__GNUC__.__GNUC_MINOR__.__GNUC_PATCHLEVEL__" | \ ${FC} -E -P - | ${SED} -e 's/ //g'` { $as_echo "$as_me:${as_lineno-$LINENO}: result: gfortran ${FC_VERSION}" >&5 $as_echo "gfortran ${FC_VERSION}" >&6; } as_arg_v1=${FC_VERSION} as_arg_v2=${MINI_GFORTRAN_VERSION} awk "$as_awk_strverscmp" v1="$as_arg_v1" v2="$as_arg_v2" /dev/null case $? in #( 1) : as_fn_error $? "this version of GNU Fortran cannot be used to compile this package. Please try to upgrade gfortran (>= ${MINI_GFORTRAN_VERSION}) or to use a different Fortran compiler." "$LINENO" 5 ;; #( 0) : ;; #( 2) : ;; #( *) : ;; esac ;; *g95*) { $as_echo "$as_me:${as_lineno-$LINENO}: result: ${FC}" >&5 $as_echo "${FC}" >&6; } as_fn_error $? "G95 cannot compile the Fortran code contained in this package. Please try to use a different Fortran compiler." "$LINENO" 5 ;; *) { $as_echo "$as_me:${as_lineno-$LINENO}: result: ${FC}" >&5 $as_echo "${FC}" >&6; } { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: the Fortran code contained in this package will be compiled with ${FC}. Please contact package maintainer if compilation fails." >&5 $as_echo "$as_me: WARNING: the Fortran code contained in this package will be compiled with ${FC}. Please contact package maintainer if compilation fails." >&2;} ;; esac BayesFM/man/0000755000176200001440000000000014631253115012314 5ustar liggesusersBayesFM/man/post.column.switch.Rd0000644000176200001440000000371614142561761016401 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/post.column.switch.R \name{post.column.switch} \alias{post.column.switch} \title{Perform column switchting on posterior MCMC sample} \usage{ post.column.switch(mcmc) } \arguments{ \item{mcmc}{Object of class '\code{befa}'.} } \value{ Same '\code{befa}' object as the one passed to the function, where the indicators in the matrix \code{dedic}, as well as the rows and columns of the correlation matrix of the factors saved in \code{draws}, have been switched appropriately to restore the identification of the factor model with respect to column switching. } \description{ This function reorders the columns of the factor loading matrix for each MCMC draw, as well as the rows and columns of the correlation matrix of the factors, to restore the identification of the model \emph{a posteriori} with respect to the column switching problem. } \details{ The reordering of the columns of the factor loading matrix is based on the top elements of the columns (i.e., the first row containing a nonzero factor loading in each nonzero column of \eqn{\alpha}, starting from the top of the matrix). At each MCMC iteration, the nonzero columns of \eqn{\alpha} are reordered such that the top elements appear in increasing order. The rows and columns of the correlation matrix \eqn{R} of the factors are switched accordingly. See section 4.3 of CFSHP (p.42) for more details. } \examples{ set.seed(6) Y <- simul.dedic.facmod(N = 100, dedic = rep(1:3, each = 5)) mcmc <- befa(Y, Kmax = 5, iter = 1000) mcmc <- post.column.switch(mcmc) } \references{ G. Conti, S. Frühwirth-Schnatter, J.J. Heckman, R. Piatek (2014): ``Bayesian Exploratory Factor Analysis'', \emph{Journal of Econometrics}, 183(1), pages 31-57, \doi{10.1016/j.jeconom.2014.06.008}. } \seealso{ \code{\link{post.sign.switch}} to restore identification a posteriori with respect to the sign switching problem. } \author{ Rémi Piatek \email{remi.piatek@gmail.com} } BayesFM/man/simul.nfac.prior.Rd0000644000176200001440000000613314142561761016005 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/simul.nfac.prior.R \name{simul.nfac.prior} \alias{simul.nfac.prior} \title{Simulate prior distribution of number of latent factors} \usage{ simul.nfac.prior(nvar, Kmax, Nid = 3, kappa = 1/Kmax, nrep = 10^6) } \arguments{ \item{nvar}{Number of manifest variables.} \item{Kmax}{Maximum number of latent factors.} \item{Nid}{Minimum number of manifest variables dedicated to each latent factor for identification.} \item{kappa}{Concentration parameter of the Dirichlet prior distribution on the indicators.} \item{nrep}{Number of Monte Carlo replications.} } \value{ A list of length equal to the number of parameters specified in \code{kappa} is returned, where each element of the list contains: \itemize{ \item \code{nfac}: Vector of integers of length equal to the number of accepted draws. \item \code{acc}: Acceptance rate of the accept/reject sampling scheme. } } \description{ This function produces a sample from the prior distribution of the number of latent factors. It depends on the prior parameters used for the distribution of the indicators, on the size of the model (number of manifest variables and maximum number of latent factors), and on the identification restriction (minimum number of manifest variables dedicated to each factor). } \details{ This function simulates the prior distribution of the number of latent factors for models that fulfill the identification restriction restriction that at least \code{Nid} manifest variables (or no variables) are loading on each latent factor. Several (scalar) parameters \code{kappa} can be passed to the function to simulate the prior for different prior parameter values and compare the results. An accept/reject sampling scheme is used: a vector of probabilities is drawn from a Dirichlet distribution with concentration parameter \code{kappa}, and the \code{nvar} manifest variables are randomly allocated to the \code{Kmax} latent factors. If each latent factor has at least \code{Nid} dedicated variables or no variables at all, the identification requirement is fulfilled and the draw is accepted. The number of factors loaded by at least \code{Nid} manifest variables is returned as a draw from the prior distribution. Note that this function does not use the two-level prior distribution implemented in CFSHP, where manifest variables can be discarded from the model according to a given probability. Therefore, this function only help understand the prior distribution conditional on all the manifest variables being included into the model. } \examples{ # replicate first row of table 2 in CFSHP (p.44) # note: use larger number of replications nrep to improve accuracy prior.nfac <- simul.nfac.prior(nvar = 15, Kmax = 5, kappa = c(.3, .7, 1), nrep = 10000) summary(prior.nfac) plot(prior.nfac) } \references{ G. Conti, S. Frühwirth-Schnatter, J.J. Heckman, R. Piatek (2014): ``Bayesian Exploratory Factor Analysis'', \emph{Journal of Econometrics}, 183(1), pages 31-57, \doi{10.1016/j.jeconom.2014.06.008}. } \author{ Rémi Piatek \email{remi.piatek@gmail.com} } BayesFM/man/plot.befa.Rd0000644000176200001440000000603614145716570014473 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/plot.befa.R \name{plot.befa} \alias{plot.befa} \title{Plot object of class 'befa'} \usage{ \method{plot}{befa}(x, ...) } \arguments{ \item{x}{Object of class 'befa'.} \item{...}{The following extra arguments can be specified: \itemize{ \item \code{what}: How to summarize the posterior distribution? \itemize{ \item \code{what = 'maxp'} (default): Only factor loadings with highest posterior probability of being different from zero or discarded from the model (if \code{dedic = 0}) are summarized. \item \code{what = 'all'}: All factor loadings with corresponding posterior probability to be allocated to a given factor (or to be discarded from the model) larger than \code{min.prob} are summarized. \item \code{what = 'hppm'}: Highest posterior probability models with probability larger than \code{min.prob} are summarized. } \item \code{byfac}: Sort factor loadings by factors if \code{TRUE}, otherwise by manifest variables if \code{FALSE} (default). \item \code{hpd.prob}: Probability used to compute the highest posterior density intervals of the posterior distribution of the model parameters (default: 0.95). \item \code{min.prob}: If \code{what = 'all'}, only factor loadings with posterior probability of being dedicated to a given factor (or discarded from the model) larger than this value are displayed. If \code{what = 'hppm'}, only highest posterior probability models with probability larger than this value are displayed. (default: 0.20) }} } \value{ No return value, called for side effects (plots the posterior results returned by \code{\link{summary.befa}}). } \description{ This function makes different plots that are useful to assess the posterior results: a trace plot of the number of latent factors (also showing Metropolis-Hastings acceptance across MCMC replications), a histogram of the posterior probabilities of the number of factors, heatmaps for the inficator probabilities, the factor loading matrix, and the correlation matrix of the latent factors. } \details{ This function makes graphs based on the summary results returned by \code{\link{summary.befa}}. It therefore accepts the same optional arguments as this function. } \examples{ set.seed(6) # generate fake data with 15 manifest variables and 3 factors Y <- simul.dedic.facmod(N = 100, dedic = rep(1:3, each = 5)) # run MCMC sampler and post process output # notice: 1000 MCMC iterations for illustration purposes only, # increase this number to obtain reliable posterior results! mcmc <- befa(Y, Kmax = 5, iter = 1000) mcmc <- post.column.switch(mcmc) mcmc <- post.sign.switch(mcmc) # plot results for highest posterior probability model plot(mcmc, what = 'hppm') } \seealso{ \code{\link{summary.befa}} to summarize posterior results. } \author{ Rémi Piatek \email{remi.piatek@gmail.com} } BayesFM/man/befa.Rd0000644000176200001440000004441014145012614013500 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/befa.R \name{befa} \alias{befa} \title{Bayesian Exploratory Factor Analysis} \usage{ befa(model, data, burnin = 1000, iter = 10000, Nid = 3, Kmax, A0 = 10, B0 = 10, c0 = 2, C0 = 1, HW.prior = TRUE, nu0 = Kmax + 1, S0 = 1, kappa0 = 2, xi0 = 1, kappa = 1/Kmax, indp.tau0 = TRUE, rnd.step = TRUE, n.step = 5, search.delay = min(burnin, 10), R.delay = min(burnin, 100), dedic.start, alpha.start, sigma.start, beta.start, R.start, verbose = TRUE) } \arguments{ \item{model}{This argument specifies the manifest variables and the covariates used in the model (if any). It can be specified in two different ways: \itemize{ \item A numeric matrix or a data frame containing the manifest variables. This corresponds to a model without covariates, and the argument \code{data} is not required. \item A list of model formulas. Each element of the list specifies a manifest variable and its corresponding control variables (e.g., '\code{Y1 ~ X1 + X2}' to use \code{X1} and \code{X2} as control variables for \code{Y1}). If a formula has no left-hand side variable, covariates on the right-hand side are included in all equations (e.g., '\code{~ X3}' means that \code{X3} is used as a control variable for all the manifest variables). Argument \code{data} can be passed to the function in that case, otherwise parent data frame is used. } Binary manifest variables should be specified as logical vectors in the data frame to be treated as dichotomous. \code{NA} values are accepted in manifest variables only.} \item{data}{Data frame. If missing, parent data frame if used.} \item{burnin}{Burn-in period of the MCMC sampler.} \item{iter}{Number of MCMC iterations saved for posterior inference (after burn-in).} \item{Nid}{Minimum number of manifest variables dedicated to each latent factor for identification.} \item{Kmax}{Maximum number of latent factors. If missing, the maximum number of factors that satisfies the identification condition determined by \code{Nid} and the Ledermann bound is specified (see CFSHP, section 2.2).} \item{A0}{Scaling parameters of the variance of the Normal prior on the nonzero factor loadings. Either a scalar or a numeric vector of length equal to the number of manifest variables.} \item{B0}{Variances of the Normal prior on the regression coefficients. Either a scalar or a numeric vector of length equal to the number of manifest variables.} \item{c0}{Shape parameters of the Inverse-Gamma prior on the idiosyncratic variances. Either a scalar or a numeric vector of length equal to the number of manifest variables.} \item{C0}{Scale parameters of the Inverse-Gamma prior on the idiosyncratic variances. Either a scalar or a numeric vector of length equal to the number of manifest variables.} \item{HW.prior}{If \code{TRUE}, implement Huang-Wand (2013) prior on the covariance matrix of the factors in the expanded model, otherwise use an Inverse-Wishart prior if \code{FALSE}, see CFSHP section 2.3.5.} \item{nu0}{Degrees of freedom of the Inverse-Wishart prior on the covariance matrix of the latent factors in the expanded model.} \item{S0}{Scale parameters of the Inverse-Wishart prior on the covariance matrix of latent factors in the expanded model: \itemize{ \item if \code{HW.prior = TRUE}, scale parameter of the Gamma hyperprior distribution on the individual scales of the Inverse-Wishart prior. \item if \code{HW.prior = FALSE}, diagonal elements of the scale matrix of the Inverse-Wishart prior on the covariance matrix of the latent factors in the expanded model. } Either a scalar or a numeric vector of length equal to \code{Kmax}.} \item{kappa0}{First shape parameter of the Beta prior distribution on the probability \eqn{\tau_0} that a manifest variable does not load on any factor.} \item{xi0}{Second shape parameter of the Beta prior distribution on the probability \eqn{\tau_0} that a manifest variable does not load on any factor.} \item{kappa}{Concentration parameters of the Dirichlet prior distribution on the indicators. Either a scalar or a numeric vector of length equal to \code{Kmax}.} \item{indp.tau0}{If \code{TRUE}, specify the alternative prior specification with independent parameters \eqn{\tau_{0m}}{\tau_0m} across manifest variables \eqn{m = 1, ..., M}, otherwise use a common parameter \eqn{\tau_0} if \code{FALSE}.} \item{rnd.step}{If \code{TRUE}, select randomly the number of intermediate steps in non-identified models at each MCMC iteration, otherwise use a fixed number of steps if \code{FALSE}.} \item{n.step}{Controls the number of intermediate steps in non-identified models: \itemize{ \item if \code{rnd.step = TRUE}, average number of steps. The number of steps is sampled at each MCMC iteration from 1+Poisson(\code{n.step}-1). \item if \code{rnd.step = FALSE}, fixed number of steps. }} \item{search.delay}{Number of MCMC iterations run with fixed indicator matrix (specified in \code{dedic.start}) at beginning of MCMC sampling.} \item{R.delay}{Number of MCMC iterations run with fixed correlation matrix (specified in \code{dedic.start}) at beginning of MCMC sampling.} \item{dedic.start}{Starting values for the indicators. Vector of integers of length equal to the number of manifest variables. Each element takes a value among 0, 1, ..., \code{Kmax}. If missing, random allocation of the manifest variables to the maximum number of factors \code{Kmax}, with a minimum of \code{Nid} manifest variables loading on each factor.} \item{alpha.start}{Starting values for the factor loadings. Numeric vector of length equal to the number of manifest variables. If missing, sampled from a Normal distribution with zero mean and variance \code{A0}.} \item{sigma.start}{Starting values for the idiosyncratic variances. Numeric vector of length equal to the number of manifest variables. Sampled from prior if missing.} \item{beta.start}{Starting values for the regression coefficients. Numeric vector of length equal to the total number of regression coefficients, concatenated for all the manifest variables. Sampled from prior if missing.} \item{R.start}{Starting values for the correlation matrix of the latent factors. Numeric matrix with \code{Kmax} rows and columns, and unit diagonal elements. If missing, identity matrix is used.} \item{verbose}{If \code{TRUE}, display information on the progress of the function.} } \value{ The function returns an object of class '\code{befa}' containing the MCMC draws of the model parameters saved in the following matrices (each matrix has '\code{iter}' rows): \itemize{ \item \code{alpha}: Factor loadings. \item \code{sigma}: Idiosyncratic variances. \item \code{R}: Correlation matrix of the latent factors (off-diagonal elements only). \item \code{beta}: regression coefficients (if any). \item \code{dedic}: indicators (integers indicating on which factors the manifest variable load). } The returned object also contains: \itemize{ \item \code{nfac}: Vector of number of 'active' factors across MCMC iterations (i.e., factors loaded by at least \code{Nid} manifest variables). \item \code{MHacc}: Logical vector indicating accepted proposals of Metropolis-Hastings algorithm. } The parameters \code{Kmax} and \code{Nid} are saved as object attributes, as well as the function call and the number of mcmc iterations (\code{burnin} and \code{iter}), and two logical variables indicating if the returned object has been post processed to address the column switching problem (\code{post.column.switch}) and the sign switching problem (\code{post.sign.switch}). } \description{ This function implements the Bayesian Exploratory Factor Analysis (\code{befa}) approach developed in Conti et al. (CFSHP, 2014). It runs a MCMC sampler for a factor model with dedicated factors, where each manifest variable is allowed to load on at most one latent factor. The allocation of the manifest variables to the latent factors is not fixed \emph{a priori} but determined stochastically during sampling. The minimum number of variables dedicated to each factor can be controlled by the user to achieve the desired level of identification. The manifest variables can be continuous or dichotomous, and control variables can be introduced as covariates. } \details{ \strong{Model specification.} The model is specified as follows, for each observation \eqn{i = 1, ..., N}: \deqn{Y^*_i = \beta X_i + \alpha \theta_i + \epsilon_i}{ Y*_i = \beta X_i + \alpha \theta_i + \epsilon_i} \deqn{\theta_i \sim \mathcal{N}(0, R)}{\theta_i ~ N(0, R)} \deqn{\epsilon_i \sim \mathcal{N}(0, \Sigma)}{\epsilon_i ~ N(0, \Sigma)} \deqn{\Sigma = diag(\sigma^2_1, ..., \sigma^2_M)} where \eqn{Y^*_i}{Y*_i} is the \eqn{M}-vector containing the latent variables underlying the corresponding \eqn{M} manifest variables \eqn{Y_i}, which can be continuous such that \eqn{Y_{im} = Y^*_{im}}{Y_im = Y*_im}, or binary with \eqn{Y_{im} = 1[Y^*_{im} > 0]}{Y_im = 1[Y*_im > 0]}, for \eqn{m = 1, ..., M}. The \eqn{K}-vector \eqn{\theta_i} contains the latent factors, and \eqn{\alpha} is the \eqn{(M \times K)}{(M*K)}-matrix of factor loadings. The \eqn{M}-vector \eqn{\epsilon_i} is the vector of error terms. Covariates can be included in the \eqn{Q}-vector \eqn{X_i} and are related to the manifest variables through the \eqn{(M \times Q)}{(M*Q)}-matrix of regression coefficients \eqn{\beta}. Intercept terms are automatically included, but can be omitted in some or all equations using the usual syntax for R formulae (e.g., 'Y1 ~ X1 - 1' specifies that that Y1 is regressed on X1 and no intercept is included in the corresponding equation). The number of latent factors \eqn{K} is specified as \code{Kmax}. However, during MCMC sampling the stochastic search process on the matrix \eqn{\alpha} may produce zero columns, thereby reducing the number of active factors. The covariance matrix \eqn{R} of the latent factors is assumed to be a correlation matrix for identification. Each row of the factor loading matrix \eqn{\alpha} contains at most one nonzero element (dedicated factor model). The allocation of the manifest variables to the latent factors is indicated by the binary matrix \eqn{\Delta} with same dimensions as \eqn{\alpha}, such that each row \eqn{\Delta_m} indicates which factor loading is different from zero, e.g.: \deqn{\Delta_m = (0, .., 0, 1, 0, ..., 0) \equiv e_k}{ \Delta_m = (0, .., 0, 1, 0, ..., 0) = e_k} indicates that variable \eqn{m} loads on the \eqn{k}th factor, where \eqn{e_k} is a \eqn{K}-vector that contains only zeros, besides its \eqn{k}th element that equals 1. \strong{Identification.} The function verifies that the maximum number of latent factors \code{Kmax} does not exceed the Ledermann bound. It also checks that \code{Kmax} is consistent with the identification restriction specified with \code{Nid} (enough variables should be available to load on the factors when \code{Kmax} is reached). The default value for \code{Kmax} is the minimum between the Ledermann bound and the maximum number of factors that can be loaded by \code{Nid} variables. The user is free to select the level of identification, see CFSHP section 2.2 (non-identified models are allowed with \code{Nid = 1}). Note that identification is achieved only with respect to the scale of the latent factors. Non-identifiability problems may affect the posterior sample because of column switching and sign switching of the factor loadings. These issues can be addressed \emph{a posteriori} with the functions \code{\link{post.column.switch}} and \code{\link{post.sign.switch}}. \strong{Prior specification.} The indicators are assumed to have the following probabilities, for \eqn{k = 1, ..., K}: \deqn{Prob(\Delta_m = e_k \mid \tau_k) = \tau_k}{ Prob(\Delta_m = e_k | \tau_k) = \tau_k} \deqn{\tau = (\tau_0, \tau_1, ..., \tau_K)} If \code{indp.tau0 = FALSE}, the probabilities are specified as: \deqn{\tau = [\tau_0, (1-\tau_0)\tau^*_1, ..., (1-\tau_0)\tau^*_K]}{ \tau = [\tau_0, (1-\tau_0)\tau*_1, ..., (1-\tau_0)\tau*_K]} \deqn{\tau_0 \sim \mathcal{B}eta(\kappa_0, \xi_0)}{ \tau_0 ~ Beta(\kappa_0, \xi_0)} \deqn{\tau^* = (\tau^*_1, ..., \tau^*_K) \sim \mathcal{D}ir(\kappa)}{ \tau* = (\tau*_1, ..., \tau*_K) ~ Dir(\kappa)} with \eqn{\kappa_0} = \code{kappa0}, \eqn{\xi_0} = \code{xi0} and \eqn{\kappa} = \code{kappa}. Alternatively, if \code{indp.tau0 = TRUE}, the probabilities are specified as: \deqn{\tau_m = [\tau_{0m}, (1-\tau_{0m})\tau^*_1, ..., (1-\tau_{0m})\tau^*_K]}{ \tau_m = [\tau_0m, (1-\tau_0m)\tau*_1, ..., (1-\tau_0m)\tau*_K]} \deqn{\tau_{0m} \sim \mathcal{B}eta(\kappa_0, \xi_0)}{ \tau_0m ~ Beta(\kappa_0, \xi_0)} for each manifest variable \eqn{m = 1, ..., M}. A normal-inverse-Gamma prior distribution is assumed on the nonzero factor loadings and on the idiosyncratic variances: \deqn{\sigma^2_m \sim \mathcal{I}nv-\mathcal{G}amma(c_{0m}, C_{0m})}{ \sigma^2_m ~ Inv-Gamma(c0_m, C0_m)} \deqn{\alpha_m^\Delta \mid \sigma^2_m \sim \mathcal{N}(0, A_{0m}\sigma^2_m)}{ \alpha_m^\Delta | \sigma^2_m ~ N(0, A0_m * \sigma^2_m)} where \eqn{\alpha_m^\Delta} denotes the only nonzero loading in the \eqn{m}th row of \eqn{\alpha}. For the regression coefficients, a multivariate Normal prior distribution is assumed on each row \eqn{m = 1, ..., M} of \eqn{\beta}: \deqn{\beta_m \sim \mathcal{N}(0, B_0 I_Q)}{\beta_m ~ N(0, B_0 I_Q)} The covariates can be different across manifest variables, implying zero restrictions on the matrix \eqn{\beta}. To specify covariates, use a list of formulas as \code{model} (see example below). Intercept terms can be introduced using To sample the correlation matrix \eqn{R} of the latent factors, marginal data augmentation is implemented (van Dyk and Meng, 2001), see CFSHP section 2.2. Using the transformation \eqn{\Omega = \Lambda^{1/2} R \Lambda^{1/2}}, the parameters \eqn{\Lambda = diag(\lambda_1, ..., \lambda_K)} are used as \emph{working parameters}. These parameters correspond to the variances of the latent factors in an expanded version of the model where the factors do not have unit variances. Two prior distributions can be specified on the covariance matrix \eqn{\Omega} in the expanded model: \itemize{ \item If \code{HW.prior = FALSE}, inverse-Wishart distribution: \deqn{\Omega \sim \mathcal{I}nv-\mathcal{W}ishart(\nu_0, diag(S_0))}{ \Omega ~ Inv-Wishart(\nu_0, diag(S0))} with \eqn{\nu_0} = \code{nu0} and \eqn{S_0} = \code{S0}. \item If \code{HW.prior = TRUE}, Huang-Wand (2013) prior: \deqn{\Omega \sim \mathcal{I}nv-\mathcal{W}ishart(\nu_0, W), \qquad W = diag(w_1, ..., w_K)}{ \Omega ~ Inv-Wishart(nu0, W), W = diag(w_1, ..., w_K)} \deqn{w_k \sim \mathcal{G}amma\left(\frac{1}{2}, \frac{1}{2\nu^*S_{0k}}\right)}{w_k ~ Gamma(1/2, 1/(2\nu*S0_k))} with \eqn{\nu^*}{\nu*} = \code{nu0} - \code{Kmax} + 1, and the shape and rate parameters are specified such that the mean of the gamma distribution is equal to \eqn{\nu^* S_{0k}}{\nu* S0_k}, for each \eqn{k = 1, ..., K}. } \strong{Missing values.} Missing values (\code{NA}) are allowed in the manifest variables. They are drawn from their corresponding conditional distributions during MCMC sampling. Control variables with missing values can be passed to the function. However, all the observations with at least one missing value in the covariates are discarded from the sample (a warning message is issued in that case). } \examples{ #### model without covariates set.seed(6) # generate fake data with 15 manifest variables and 3 factors N <- 100 # number of observations Y <- simul.dedic.facmod(N, dedic = rep(1:3, each = 5)) # run MCMC sampler # notice: 1000 MCMC iterations for illustration purposes only, # increase this number to obtain reliable posterior results! mcmc <- befa(Y, Kmax = 5, iter = 1000) # post process MCMC draws to restore identification mcmc <- post.column.switch(mcmc) mcmc <- post.sign.switch(mcmc) \donttest{ summary(mcmc) # summarize posterior results plot(mcmc) # plot posterior results # summarize highest posterior probability (HPP) model summary(mcmc, what = 'hppm') #### model with covariates # generate covariates and regression coefficients Xcov <- cbind(1, matrix(rnorm(4*N), ncol = 4)) colnames(Xcov) <- c('(Intercept)', paste0('X', 1:4)) beta <- rbind(rnorm(15), rnorm(15), diag(3) \%x\% t(rnorm(5))) # add covariates to previous model Y <- Y + Xcov \%*\% beta # specify model model <- c('~ X1', # X1 covariate in all equations paste0('Y', 1:5, ' ~ X2'), # X2 covariate for Y1-Y5 only paste0('Y', 6:10, ' ~ X3'), # X3 covariate for Y6-Y10 only paste0('Y', 11:15, ' ~ X4')) # X4 covariate for Y11-Y15 only model <- lapply(model, as.formula) # make list of formulas # run MCMC sampler, post process and summarize mcmc <- befa(model, data = data.frame(Y, Xcov), Kmax = 5, iter = 1000) mcmc <- post.column.switch(mcmc) mcmc <- post.sign.switch(mcmc) mcmc.sum <- summary(mcmc) mcmc.sum # compare posterior mean of regression coefficients to true values beta.comp <- cbind(beta[beta != 0], mcmc.sum$beta[, 'mean']) colnames(beta.comp) <- c('true', 'mcmc') print(beta.comp, digits = 3) } } \references{ G. Conti, S. Frühwirth-Schnatter, J.J. Heckman, R. Piatek (2014): ``Bayesian Exploratory Factor Analysis'', \emph{Journal of Econometrics}, 183(1), pages 31-57, \doi{10.1016/j.jeconom.2014.06.008}. A. Huang, M.P. Wand (2013): ``Simple Marginally Noninformative Prior Distributions for Covariance Matrices'', \emph{Bayesian Analysis}, 8(2), pages 439-452, \doi{10.1214/13-BA815}. D.A. van Dyk, X.-L. Meng (2001): ``The Art of Data Augmentation'', \emph{Journal of Computational and Graphical Statistics}, 10(1), pages 1-50, \doi{10.1198/10618600152418584}. } \seealso{ \code{\link{post.column.switch}} and \code{\link{post.sign.switch}} for column switching and sign switching of the factor loading matrix and of the correlation matrix of the latent factors to restore identification \emph{a posteriori}. \code{\link{summary.befa}} and \code{\link{plot.befa}} to summarize and plot the posterior results. \code{\link{simul.R.prior}} and \code{\link{simul.nfac.prior}} to simulate the prior distribution of the correlation matrix of the factors and the prior distribution of the indicator matrix, respectively. This is useful to perform prior sensitivity analysis and to understand the role of the corresponding parameters in the factor search. } \author{ Rémi Piatek \email{remi.piatek@gmail.com} } BayesFM/man/post.sign.switch.Rd0000644000176200001440000000632714142561761016045 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/post.sign.switch.R \name{post.sign.switch} \alias{post.sign.switch} \title{Perform sign switchting on posterior MCMC sample} \usage{ post.sign.switch(mcmc, benchmark = NULL, benchmark.threshold = 0.5) } \arguments{ \item{mcmc}{Object of class '\code{befa}'.} \item{benchmark}{Vector of integers of length equal to the maximum number of latent factors. Each element indicates which factor loading is used as a benchmark for the sign switch. If \code{NULL}, the factor loadings with the highest posterior probabilities of being different from zero in each column of the factor loading matrix are used as benchmarks.} \item{benchmark.threshold}{Minimum posterior probability for a factor loading to be considered as a benchmark.} } \value{ This function returns the same '\code{befa}' object, where the signs of the factor loadings and of the factor correlations have been switched appropriately to restore the identification of the factor model with respect to sign switching. } \description{ This function performs a sign switch on the MCMC draws to restore the consistency of the signs of the factors loadings and of the correlations of the latent factors \emph{a posteriori}. } \details{ The signs of the factor loadings, as well as of the corresponding correlations of the latent factors, are switched for each MCMC iteration such that the factor loadings defined as \code{benchmark}s are positive. The sign switch can only be performed if \code{\link{post.column.switch}} has been run before. See section 4.3 (p.42) of CFSHP for more details. If a latent factor has no benchmarks, or if its benchmark is equal to zero at some MCMC iteration, then no sign switch is performed on the corresponding loadings and correlations for this particular factor or MCMC iteration. Note that in complicated models where the sampler visits several models with different numbers of latent factors, it may not be relevant to use the default value of \code{benchmark}, as the posterior probabilities that the factor loadings are different from zero would be computed across models. Instead, the user might consider finding the highest posterior probability model first, and use its top elements in each column of the factor loading matrix as benchmarks to perform the sign switch. } \examples{ set.seed(6) Y <- simul.dedic.facmod(N = 100, dedic = rep(1:3, each = 5)) mcmc <- befa(Y, Kmax = 5, iter = 1000) mcmc <- post.column.switch(mcmc) # factor loadings corresponding to variables 1, 6, 11, 12 and 13 are # used as benchmarks: mcmc1 <- post.sign.switch(mcmc, benchmark = c(1, 6, 11, 12, 13)) # factor loadings with the highest posterior probability of being different # from zero in each column are used as benchmark: mcmc2 <- post.sign.switch(mcmc) } \references{ G. Conti, S. Frühwirth-Schnatter, J.J. Heckman, R. Piatek (2014): ``Bayesian Exploratory Factor Analysis'', \emph{Journal of Econometrics}, 183(1), pages 31-57, \doi{10.1016/j.jeconom.2014.06.008}. } \seealso{ \code{\link{post.column.switch}} for column switching of the factor loading matrix and of the correlation matrix of the latent factors to restore identification \emph{a posteriori}. } \author{ Rémi Piatek \email{remi.piatek@gmail.com} } BayesFM/man/summary.befa.Rd0000644000176200001440000001621314145550464015206 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/summary.befa.R \name{summary.befa} \alias{summary.befa} \title{Summarize 'befa' object} \usage{ \method{summary}{befa}(object, ...) } \arguments{ \item{object}{Object of class 'befa'.} \item{...}{The following extra arguments can be specified: \itemize{ \item \code{what}: How to summarize the posterior distribution? \itemize{ \item \code{what = 'maxp'} (default): Only factor loadings with highest posterior probability of being different from zero or discarded from the model (if \code{dedic = 0}) are summarized. \item \code{what = 'all'}: All factor loadings with corresponding posterior probability to be allocated to a given factor (or to be discarded from the model) larger than \code{min.prob} are summarized. \item \code{what = 'hppm'}: Highest posterior probability models with probability larger than \code{min.prob} are summarized. } \item \code{byfac}: Sort factor loadings by factors if \code{TRUE}, otherwise by manifest variables if \code{FALSE} (default). \item \code{hpd.prob}: Probability used to compute the highest posterior density intervals of the posterior distribution of the model parameters (default: 0.95). \item \code{min.prob}: If \code{what = 'all'}, only factor loadings with posterior probability of being dedicated to a given factor (or discarded from the model) larger than this value are displayed. If \code{what = 'hppm'}, only highest posterior probability models with probability larger than this value are displayed. (default: 0.20) }} } \value{ If called directly, the summary is formatted and displayed on the standard output. Otherwise if saved in an object, a list of the following elements is returned: \itemize{ \item \code{MHacc}: Metropolis-Hastings acceptance rate. \item \code{alpha}: Data frame (or list of data frames if \code{what = 'hppm'}) containing posterior summary statistics for the factor loadings. \item \code{sigma}: Data frame (or list of matrices if \code{what = 'hppm'}) containing posterior summary statistics for the idiosyncratic variances. \item \code{R}: Data frame (or list of data frames if \code{what = 'hppm'}) containing posterior summary statistics for the factor correlations. \item \code{beta}: Data frame (or list of data frames if \code{what = 'hppm'}) containing posterior summary statistics for the regression coefficients (if any). \item \code{nfac} (only if \code{what = 'maxp'} or \code{what = 'all'}): Table of posterior frequencies of numbers of factors. \item \code{hppm} (only if \code{what = 'hppm'}): List of the following elements summarizing the different HPP models, sorted in decreasing order of their posterior probabilities: \itemize{ \item \code{prob}: Vector of posterior probabilities. \item \code{nfac}: Vector of numbers of factors. \item \code{dedic}: Data frame of factor indicators. } } Data frames of posterior summary statistics include the means (\code{mean}), standard deviations (\code{sd}) and highest posterior density intervals (\code{hpd.lo} and \code{hpd.up}, for the probability specified in \code{hpd.prob}) of the corresponding parameters. For the factor loadings, the matrix may also include a column labeled '\code{dedic}' indicating to which factors the corresponding manifest variables are dedicated (a zero value means that the manifest variable does not load on any factor), as well as a column labeled '\code{prob}' showing the corresponding posterior probabilities that the manifest variables load on these factors. Summary results are returned as lists of data frames for HPP models, where the elements of the list are labeled as '\code{m1}, '\code{m2}', etc. } \description{ Generic function summarizing the posterior results of a 'befa' object. Optional arguments can be specified to customize the summary. } \details{ This function summarizes the posterior distribution of the parameters. The algorithm may visit different configurations of the indicator matrix \eqn{\Delta} during sampling, where the manifest variables are allocated to different latent factors. When the posterior distribution of the factor loadings is summarized separately for each manifest variable (\code{what = 'maxp'} or \code{what = 'all'}), the function provides the latent factor each manifest variable is allocated to (\code{dedic}), and the corresponding posterior probability (\code{prob}). If \code{dedic = 0}, then \code{prob} corresponds to the posterior probability that the manifest variable is discarded. Discarded variables are listed last if \code{byfac = TRUE}. Low probability cases can be discarded by setting \code{min.prob} appropriately (default is 0.20). Idiosyncratic variances, factor correlation matrix and regression coefficients (if any) are summarized across all MCMC iterations if \code{what = 'all'} or \code{what = 'maxp'}, and within each HPP model if \code{what = 'hppm'}. \strong{Highest posterior probability model.} The HPP model is the model with a given allocation of the measurements to the latent factors (i.e., a given indicator matrix \eqn{\Delta}) that is visited most often by the algorithm. When specifying \code{what = 'hppm'}, the function sorts the models according to the posterior frequencies of their indicator matrices in decreasing order. Therefore, the first model returned (labeled 'm1') corresponds to the HPP model. Low probability models can be discarded by setting \code{min.prob} appropriately(default is 0.20, implying that only models with a posterior probability larger than 0.20 are displayed). HPP models can only be found if identification with respect to column switching has been restored \emph{a posteriori}. An error message is returned if this is not the case. } \examples{ set.seed(6) # generate fake data with 15 manifest variables and 3 factors Y <- simul.dedic.facmod(N = 100, dedic = rep(1:3, each = 5)) # run MCMC sampler and post process output # notice: 1000 MCMC iterations for illustration purposes only, # increase this number to obtain reliable posterior results! mcmc <- befa(Y, Kmax = 5, iter = 1000) mcmc <- post.column.switch(mcmc) mcmc <- post.sign.switch(mcmc) # summarize posterior results summary(mcmc) # summarize highest posterior probability (HPP) model hppm.sum <- summary(mcmc, what = 'hppm') # print summary with 6-digit precision print(hppm.sum, digits = 6) # extract posterior means of the factor loadings in HPP model alpha.mean <- hppm.sum$alpha$m1$mean print(alpha.mean) \dontshow{ summary(mcmc, what = 'maxp', byfac = TRUE) summary(mcmc, what = 'all') summary(mcmc, what = 'all', byfac = TRUE) summary(mcmc, what = 'all', min.prob = 0) summary(mcmc, what = 'all', min.prob = 0, byfac = TRUE) summary(mcmc, what = 'hppm', byfac = TRUE) summary(mcmc, what = 'hppm', min.prob = 0) summary(mcmc, what = 'hppm', min.prob = 0, byfac = TRUE) } } \seealso{ \code{\link{plot.befa}} to plot posterior results. } \author{ Rémi Piatek \email{remi.piatek@gmail.com} } BayesFM/man/simul.R.prior.Rd0000644000176200001440000000562414143562732015303 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/simul.R.prior.R \name{simul.R.prior} \alias{simul.R.prior} \title{Simulate prior distribution of factor correlation matrix} \usage{ simul.R.prior(Kmax, nu0 = Kmax + 1, S0 = 1, HW.prior = TRUE, nrep = 10^5, verbose = TRUE) } \arguments{ \item{Kmax}{Maximum number of latent factors.} \item{nu0}{Degrees of freedom of the Inverse-Wishart prior on the covariance matrix of the latent factors in the expanded model.} \item{S0}{Scale parameters of the Inverse-Wishart prior on the covariance matrix of latent factors in the expanded model: \itemize{ \item if \code{HW.prior = TRUE}, scale parameter of the Gamma hyperprior distribution on the individual scales of the Inverse-Wishart prior. \item if \code{HW.prior = FALSE}, diagonal elements of the scale matrix of the Inverse-Wishart prior on the covariance matrix of the latent factors in the expanded model. } Either a scalar or a numeric vector of length equal to \code{Kmax}.} \item{HW.prior}{If \code{TRUE}, implement Huang-Wand (2013) prior on the covariance matrix of the factors in the expanded model, otherwise use an Inverse-Wishart prior if \code{FALSE}, see CFSHP section 2.3.5.} \item{nrep}{Number of Monte Carlo replications.} \item{verbose}{If \code{TRUE}, display information on the progress of the function.} } \value{ A list of length equal to the number of pairs of parameters \code{nu0} and \code{S0}, where each element of the list is an array of dimension (\code{Kmax}, \code{Kmax}, \code{nrep}) that contains the correlation matrices of the latent factors drawn from the prior. } \description{ This function produces a sample of correlation matrices drawn from their prior distribution induced in the identified version of the factor model, given the prior distribution specified on the corresponding covariance matrices of the factors in the expanded model. } \details{ Covariance matrices are sampled from the prior distribution in the expanded model, and transformed to produce the corresponding correlation matrices. See section 2.3.5 of CFSHP (p.36-37), as well as the details of the function \code{\link{befa}}. To compare several prior specifications, different values of the parameters \code{nu0} and \code{S0} can be specified. The function then simulates for each pair of these parameters. \code{nu0} and \code{S0} should therefore be scalars or vectors of same length. } \examples{ # partial reproduction of figure 1 in CFSHP (p.38) # note: use larger number of replications nrep to increase smoothness Kmax <- 10 Rsim <- simul.R.prior(Kmax, nu0 = Kmax + c(1, 2, 5), S0 = .5, nrep = 1000) summary(Rsim) plot(Rsim) } \references{ G. Conti, S. Frühwirth-Schnatter, J.J. Heckman, R. Piatek (2014): ``Bayesian Exploratory Factor Analysis'', \emph{Journal of Econometrics}, 183(1), pages 31-57, \doi{10.1016/j.jeconom.2014.06.008}. } \author{ Rémi Piatek \email{remi.piatek@gmail.com} } BayesFM/man/BayesFM.Rd0000644000176200001440000000241014631253115014066 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/BayesFM-package.R \docType{package} \name{BayesFM} \alias{BayesFM-package} \alias{BayesFM} \title{BayesFM: Package for Bayesian Factor Modeling} \description{ The long-term goal of this package is to provide a collection of procedures to perform Bayesian inference on a variety of factor models. } \details{ Currently, this package includes: Bayesian Exploratory Factor Analysis (\code{befa}), as developed in Conti et al. (2014), an approach to dedicated factor analysis with stochastic search on the structure of the factor loading matrix. The number of latent factors, as well as the allocation of the observed variables to the factors, are not fixed a priori but determined during MCMC sampling. More approaches will be included in future releases of this package. } \note{ You are very welcome to send me any comments or suggestions for improvements, and to share with me any problems you may encounter with the use of this package. } \references{ G. Conti, S. Frühwirth-Schnatter, J.J. Heckman, R. Piatek (2014): ``Bayesian Exploratory Factor Analysis'', \emph{Journal of Econometrics}, 183(1), pages 31-57, \doi{10.1016/j.jeconom.2014.06.008}. } \author{ Rémi Piatek \email{remi.piatek@gmail.com} } BayesFM/man/simul.dedic.facmod.Rd0000644000176200001440000001227114143562732016244 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/simul.dedic.facmod.R \name{simul.dedic.facmod} \alias{simul.dedic.facmod} \title{Generate synthetic data from a dedicated factor model} \usage{ simul.dedic.facmod(N, dedic, alpha, sigma, R, R.corr = TRUE, max.corr = 0.85, R.max.trial = 1000) } \arguments{ \item{N}{Number of observations in data set.} \item{dedic}{Vector of indicators. The number of manifest variables is equal to the length of this vector, and the number of factors is equal to the number of unique nonzero elements. Each integer element indicates on which latent factor the corresponding variable loads uniquely.} \item{alpha}{Vector of factor loadings, should be of same length as \code{dedic}. If missing, values are simulated (see details below).} \item{sigma}{Idiosyncratic variances, should be of same length as \code{dedic}. If missing, values are simulated (see details below).} \item{R}{Covariance matrix of the latent factors. If missing, values are simulated (see details below).} \item{R.corr}{If TRUE, covariance matrix \code{R} is rescaled to be a correlation matrix.} \item{max.corr}{Maximum correlation allowed between the latent factors.} \item{R.max.trial}{Maximum number of trials allowed to sample from the truncated distribution of the covariance matrix of the latent factors (accept/reject sampling scheme, to make sure \code{max.corr} is not exceeded).} } \value{ The function returns a data frame with \code{N} observations simulated from the corresponding dedicated factor model. The parameters used to generate the data are saved as attributes: \code{dedic}, \code{alpha}, \code{sigma} and \code{R}. } \description{ This function simulates data from a dedicated factor model. The parameters of the model are either passed by the user or simulated by the function. } \details{ The function simulates data from the following dedicated factor model, for \eqn{i = 1, ..., N}: \deqn{Y_i = \alpha \theta_i + \epsilon_i} \deqn{\theta_i \sim \mathcal{N}(0, R)}{\theta_i ~ N(0, R)} \deqn{\epsilon_i \sim \mathcal{N}(0, \Sigma)}{\epsilon_i ~ N(0, \Sigma)} where the \eqn{K}-vector \eqn{\theta_i} contains the latent factors, and \eqn{\alpha} is the \eqn{(M \times K)}{(M*K)}-matrix of factor loadings. Each row \eqn{m} of \eqn{\alpha} contains only zeros, besides its element indicated by the \eqn{m}th element of \code{dedic} that is equal to the \eqn{m}th element of \code{alpha} (denoted \eqn{\alpha_m^\Delta} below). The \eqn{M}-vector \eqn{\epsilon_i} is the vector of error terms, with \eqn{\Sigma = diag(}\code{sigma}\eqn{)}. \eqn{M} is equal to the length of the vector \code{dedic}, and \eqn{K} is equal to the maximum value of this vector. Only \code{N} and \code{dedic} are required, all the other parameters can be missing, completely or partially. Missing values (\code{NA}) are independently sampled from the following distributions, for each manifest variable \eqn{m = 1, ..., M}: Factor loadings: \deqn{\alpha_m^\Delta = (-1)^{\phi_m}\sqrt{a_m}}{ \alpha_m^\Delta = (-1)^\phi_m\sqrt(a_m)} \deqn{\phi_m \sim \mathcal{B}er(0.5)}{\phi_m ~ Ber(0.5)} \deqn{a_m \sim \mathcal{U}nif (0.04, 0.64)}{a_m ~ Unif (0.04, 0.64)} Idiosyncratic variances: \deqn{\sigma^2_m \sim \mathcal{U}nif (0.2, 0.8)}{ \sigma^2_m ~ Unif (0.2, 0.8)} For the variables that do not load on any factors (i.e., for which the corresponding elements of \code{dedic} are equal to 0), it is specified that \eqn{\alpha_m^\Delta = 0} and \eqn{\sigma^2_m = 1}. Covariance matrix of the latent factors: \deqn{\Omega \sim \mathcal{I}nv-\mathcal{W}ishart(K+5, I_K)}{ \Omega ~ Inv-Wishart(K+5, I_K)} which is rescaled to be a correlation matrix if \code{R.corr = TRUE}: \deqn{R = \Lambda^{-1/2} \Omega \Lambda^{-1/2}}{ R = \Lambda^-1/2 \Omega \Lambda^-1/2} \deqn{\Lambda = diag(\Omega)} Note that the distribution of the covariance matrix is truncated such that all the off-diagonal elements of the implied correlation matrix \eqn{R} are below \code{max.corr} in absolute value. The truncation is also applied if the covariance matrix is used instead of the correlation matrix (i.e., if \code{R.corr = FALSE}). The distributions and the corresponding default values used to simulate the model parameters are specified as in the Monte Carlo study of CFSHP, see section 4.1 (p.43). } \examples{ # generate 1000 observations from model with 4 factors and 20 variables # (5 variables loading on each factor) dat <- simul.dedic.facmod(N = 1000, dedic = rep(1:4, each = 5)) # generate data set with 5000 observations from the following model: dedic <- rep(1:3, each = 4) # 3 factors and 12 manifest variables alpha <- rep(c(1, NA, NA, NA), 3) # set first loading to 1 for each factor, # sample remaining loadings from default sigma <- rep(0.5, 12) # idiosyncratic variances all set to 0.5 R <- toeplitz(c(1, .6, .3)) # Toeplitz matrix dat <- simul.dedic.facmod(N = 5000, dedic, alpha, sigma, R) } \references{ G. Conti, S. Frühwirth-Schnatter, J.J. Heckman, R. Piatek (2014): ``Bayesian Exploratory Factor Analysis'', \emph{Journal of Econometrics}, 183(1), pages 31-57, \doi{10.1016/j.jeconom.2014.06.008}. } \author{ Rémi Piatek \email{remi.piatek@gmail.com} } BayesFM/DESCRIPTION0000644000176200001440000000242214632664630013260 0ustar liggesusersPackage: BayesFM Title: Bayesian Inference for Factor Modeling Type: Package Version: 0.1.7 Authors@R: person( given = "Rémi", family = "Piatek", role = c("aut", "cre"), email = "remi.piatek@gmail.com", comment = c(ORCID = "0000-0002-3474-1304")) Description: Collection of procedures to perform Bayesian analysis on a variety of factor models. Currently, it includes: "Bayesian Exploratory Factor Analysis" (befa) from G. Conti, S. Frühwirth-Schnatter, J.J. Heckman, R. Piatek (2014) , an approach to dedicated factor analysis with stochastic search on the structure of the factor loading matrix. The number of latent factors, as well as the allocation of the manifest variables to the factors, are not fixed a priori but determined during MCMC sampling. Depends: R (>= 3.0.0) Imports: checkmate (>= 1.8.0), coda, ggplot2 (>= 2.1.0), gridExtra, plyr (>= 1.8.0) SystemRequirements: gfortran (>= 4.6.3) License: GPL-3 NeedsCompilation: yes Encoding: UTF-8 RoxygenNote: 7.3.1 Packaged: 2024-06-09 07:16:09 UTC; remek Author: Rémi Piatek [aut, cre] () Maintainer: Rémi Piatek Repository: CRAN Date/Publication: 2024-06-13 21:50:16 UTC