├── .github ├── .gitignore └── workflows │ └── check-standard.yaml ├── src ├── Makevars ├── init.c ├── loglikMPT.cpp └── RcppExports.cpp ├── tests ├── testthat.R └── testthat │ ├── test_fitModelCpp.R │ ├── test_readEQN.R │ └── test_genMPT.R ├── data └── arnold2013.RData ├── .Rbuildignore ├── man ├── figures │ └── TreeBUGS.png ├── summarizeMCMC.Rd ├── probitInverse.Rd ├── getSamples.Rd ├── plotParam.Rd ├── PPP.Rd ├── transformedParameters.Rd ├── summarizeMPT.Rd ├── plotPriorPost.Rd ├── getGroupMeans.Rd ├── plotDistribution.Rd ├── extendMPT.Rd ├── plotFit.Rd ├── withinSubjectEQN.Rd ├── plotFreq.Rd ├── betweenSubjectMPT.Rd ├── plot.Rd ├── posteriorPredictive.Rd ├── getParam.Rd ├── plotPrior.Rd ├── BayesFactorMPT.Rd ├── genMPT.Rd ├── testHetChi.Rd ├── testHetPerm.Rd ├── arnold2013.Rd ├── BayesFactorSlope.Rd ├── TreeBUGS-package.Rd ├── correlationPosterior.Rd ├── genBetaMPT.Rd ├── WAIC.Rd ├── priorPredictive.Rd ├── simpleMPT.Rd ├── readEQN.Rd ├── genTraitMPT.Rd └── betaMPTcpp.Rd ├── vignettes ├── Heck_2018_BRM.pdf ├── Heck_2018_BRM.pdf.asis ├── TreeBUGS_2_extended.R └── TreeBUGS_1_intro.R ├── .gitignore ├── inst ├── MPTmodels │ ├── 2htm.eqn │ ├── winbugs_zero_trick.jags │ └── 2htsm.eqn └── CITATION ├── TreeBUGS.Rproj ├── R ├── RcppExports.R ├── covFactor.R ├── T1perGroup.R ├── BF_likelihoods.R ├── writeSummaryToFile.R ├── renameBUGSoutput.R ├── corSamples.R ├── BF_auxiliary.R ├── parseEQN.R ├── checkFunctions.R ├── fitSimpleMPT.R ├── getSamples.R ├── fitBetaMPTcpp.R ├── covCorrelationString.R ├── covDataRead.R ├── arnold2013.R ├── summarizeMCMC.R ├── input_functions.R ├── extendMPT.R ├── plotParameters.R ├── genDataCheck.R ├── within_subject_EQN.R ├── probitInverse.R ├── plotFit.R ├── plotDistribution.R ├── TreeBUGS-package.R ├── parseRestrictions.R ├── transformedParModelfile.R ├── getParam.R ├── genDataMPT.R ├── plotFrequencies.R ├── plotConvergence.R ├── genDataBeta.R ├── testHetChi.R ├── plotPrior.R ├── correlationBayes.R └── plotPriorPost.R ├── .travis.yml ├── DESCRIPTION └── NAMESPACE /.github/.gitignore: -------------------------------------------------------------------------------- 1 | *.html 2 | -------------------------------------------------------------------------------- /src/Makevars: -------------------------------------------------------------------------------- 1 | PKG_LIBS = $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS) 2 | -------------------------------------------------------------------------------- /tests/testthat.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library(TreeBUGS) 3 | 4 | test_check("TreeBUGS") 5 | -------------------------------------------------------------------------------- /data/arnold2013.RData: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/danheck/TreeBUGS/HEAD/data/arnold2013.RData -------------------------------------------------------------------------------- /.Rbuildignore: -------------------------------------------------------------------------------- 1 | ^.*\.Rproj$ 2 | ^\.Rproj\.user$ 3 | README.md 4 | .travis.yml 5 | 6 | ^\.github$ 7 | -------------------------------------------------------------------------------- /man/figures/TreeBUGS.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/danheck/TreeBUGS/HEAD/man/figures/TreeBUGS.png -------------------------------------------------------------------------------- /vignettes/Heck_2018_BRM.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/danheck/TreeBUGS/HEAD/vignettes/Heck_2018_BRM.pdf -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | #Generic R files 2 | .Rhistory 3 | .Rdata 4 | .Rproj.user 5 | .RDataTmp 6 | 7 | Rplot.png 8 | 9 | 10 | #Rcpp files 11 | src/*.o 12 | src/*.so 13 | src/*.dll 14 | 15 | # folders for binary packages 16 | src-x64/* 17 | src-i386/* 18 | -------------------------------------------------------------------------------- /inst/MPTmodels/2htm.eqn: -------------------------------------------------------------------------------- 1 | # Title (ignored by TreeBUGS): Basic 2HTM for a single test condition 2 | Target Hit Do 3 | Target Hit (1-Do)*g 4 | Target Miss (1-Do)*(1-g) 5 | Lure FA (1-Dn)*g 6 | Lure CR (1-Dn)*(1-g) 7 | Lure CR Dn 8 | -------------------------------------------------------------------------------- /vignettes/Heck_2018_BRM.pdf.asis: -------------------------------------------------------------------------------- 1 | %\VignetteIndexEntry{Heck, Arnold, & Arnold (2018): TreeBUGS paper (Behavior Research Methods)} 2 | %\VignetteEngine{R.rsp::asis} 3 | %\VignetteKeyword{PDF} 4 | %\VignetteKeyword{HTML} 5 | %\VignetteKeyword{vignette} 6 | %\VignetteKeyword{package} 7 | %\VignetteKeyword{TreeBUGS} 8 | -------------------------------------------------------------------------------- /inst/MPTmodels/winbugs_zero_trick.jags: -------------------------------------------------------------------------------- 1 | # "sets up priors to be close to flat 2 | # on the mean and standard deviation of the beta 3 | # distribution" 4 | 5 | data{ 6 | zero <- 0 7 | } 8 | 9 | model{ 10 | 11 | zero ~ dpois(phi) 12 | phi<- -log(1/pow(alpha+beta,power)) 13 | 14 | alpha ~ dunif(min,max) 15 | beta ~ dunif(min,max) 16 | 17 | #for(i in 1:N){ 18 | y ~ dbeta(alpha, beta) 19 | #} 20 | 21 | # meanp <- alpha/(alpha+beta) 22 | # varp <- sqrt(alpha*beta/(pow(alpha+beta,2)*(alpha+beta+1))) 23 | } 24 | -------------------------------------------------------------------------------- /inst/MPTmodels/2htsm.eqn: -------------------------------------------------------------------------------- 1 | # The two-high threshold model of source monitoring (2HTSM) 2 | E EE D1*d1 3 | E EE D1*(1-d1)*a 4 | E EU D1*(1-d1)*(1-a) 5 | E EE (1-D1)*b*g 6 | E EU (1-D1)*b*(1-g) 7 | E EN (1-D1)*(1-b) 8 | U UU D2*d2 9 | U UE D2*(1-d2)*a 10 | U UU D2*(1-d2)*(1-a) 11 | U UE (1-D2)*b*g 12 | U UU (1-D2)*b*(1-g) 13 | U UN (1-D2)*(1-b) 14 | N NN D3 15 | N NE (1-D3)*b*g 16 | N NU (1-D3)*b*(1-g) 17 | N NN (1-D3)*(1-b) 18 | -------------------------------------------------------------------------------- /TreeBUGS.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | ProjectId: c4d3970e-0b82-4acf-9709-7565087eb9d1 3 | 4 | RestoreWorkspace: Default 5 | SaveWorkspace: Default 6 | AlwaysSaveHistory: Default 7 | 8 | EnableCodeIndexing: Yes 9 | UseSpacesForTab: Yes 10 | NumSpacesForTab: 2 11 | Encoding: UTF-8 12 | 13 | RnwWeave: Sweave 14 | LaTeX: pdfLaTeX 15 | 16 | AutoAppendNewline: Yes 17 | StripTrailingWhitespace: Yes 18 | 19 | BuildType: Package 20 | PackageUseDevtools: Yes 21 | PackageInstallArgs: --no-multiarch --with-keep.source 22 | PackageCheckArgs: --as-cran 23 | PackageRoxygenize: rd,collate,namespace,vignette 24 | -------------------------------------------------------------------------------- /R/RcppExports.R: -------------------------------------------------------------------------------- 1 | # Generated by using Rcpp::compileAttributes() -> do not edit by hand 2 | # Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393 3 | 4 | betampt <- function(M, L, nthin, H, a, b, c, map, shape, rate) { 5 | .Call(`_TreeBUGS_betampt`, M, L, nthin, H, a, b, c, map, shape, rate) 6 | } 7 | 8 | simplempt <- function(M, L, nthin, H, a, b, c, map, alpha, beta) { 9 | .Call(`_TreeBUGS_simplempt`, M, L, nthin, H, a, b, c, map, alpha, beta) 10 | } 11 | 12 | loglikMPT <- function(theta, h, a, b, c, map) { 13 | .Call(`_TreeBUGS_loglikMPT`, theta, h, a, b, c, map) 14 | } 15 | 16 | -------------------------------------------------------------------------------- /man/summarizeMCMC.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/summarizeMCMC.R 3 | \name{summarizeMCMC} 4 | \alias{summarizeMCMC} 5 | \title{MCMC Summary} 6 | \usage{ 7 | summarizeMCMC(mcmc, batchSize = 50, probs = c(0.025, 0.5, 0.975)) 8 | } 9 | \arguments{ 10 | \item{mcmc}{a \code{\link[coda]{mcmc.list}} object} 11 | 12 | \item{batchSize}{size of batches of parameters used to reduce memory load 13 | when computing posterior summary statistics (including Rhat and effective 14 | sample size).} 15 | 16 | \item{probs}{quantile probabilities used to compute credibility intervals} 17 | } 18 | \description{ 19 | TreeBUGS-specific MCMC summary for \code{mcmc.list}-objects. 20 | } 21 | -------------------------------------------------------------------------------- /inst/CITATION: -------------------------------------------------------------------------------- 1 | bibentry("Article", 2 | title="TreeBUGS: An R package for hierarchical multinomial-processing-tree modeling", 3 | author="Daniel W. Heck, Nina R. Arnold, and Denis Arnold", 4 | journal = "Behavior Research Methods", 5 | year="2018", 6 | volume = "50", 7 | pages = "264-284", 8 | doi = "10.3758/s13428-017-0869-7", 9 | url="https://github.com/danheck/TreeBUGS", 10 | textVersion = 11 | paste0("Heck, D. W., Arnold, N. R., & Arnold, D. (2018). ", 12 | "TreeBUGS: An R package for hierarchical multinomial-processing-tree modeling. ", 13 | "Behavior Research Methods, 50. 264-284. doi: 10.3758/s13428-017-0869-7"), 14 | mheader = "To cite TreeBUGS in publications use:") 15 | 16 | -------------------------------------------------------------------------------- /src/init.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include // for NULL 4 | #include 5 | 6 | /* FIXME: 7 | Check these declarations against the C/Fortran source code. 8 | */ 9 | 10 | /* .Call calls */ 11 | extern SEXP _TreeBUGS_betampt(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); 12 | extern SEXP _TreeBUGS_loglikMPT(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); 13 | extern SEXP _TreeBUGS_simplempt(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); 14 | 15 | static const R_CallMethodDef CallEntries[] = { 16 | {"_TreeBUGS_betampt", (DL_FUNC) &_TreeBUGS_betampt, 10}, 17 | {"_TreeBUGS_loglikMPT", (DL_FUNC) &_TreeBUGS_loglikMPT, 6}, 18 | {"_TreeBUGS_simplempt", (DL_FUNC) &_TreeBUGS_simplempt, 10}, 19 | {NULL, NULL, 0} 20 | }; 21 | 22 | void R_init_TreeBUGS(DllInfo *dll) 23 | { 24 | R_registerRoutines(dll, NULL, CallEntries, NULL, NULL); 25 | R_useDynamicSymbols(dll, FALSE); 26 | } 27 | -------------------------------------------------------------------------------- /R/covFactor.R: -------------------------------------------------------------------------------- 1 | 2 | # factor handling 3 | 4 | # recodes factor labels into integer index 5 | # returns a pure numeric data set covData and the old factor labels 6 | covRecodeFactor <- function(covData, predType) { 7 | numCov <- ncol(covData) 8 | predFactorLevels <- vector("list", numCov) 9 | 10 | for (i in 1:numCov) { 11 | if (predType[i] != "c") { 12 | # store factor level labels: 13 | predFactorLevels[[i]] <- sort(unique(levels(as.factor(covData[, i])))) 14 | nLevel <- length(predFactorLevels[[i]]) 15 | 16 | if (nLevel <= 1) { 17 | stop("Factor", colnames(covData)[i], "has only one factor level!") 18 | } 19 | 20 | # replace factor levels by an integer index: 21 | covData[, i] <- match(as.factor(covData[, i]), predFactorLevels[[i]]) 22 | covData[, i] <- as.numeric(covData[, i]) 23 | } 24 | } 25 | 26 | 27 | list(covData = covData, predFactorLevels = predFactorLevels) 28 | } 29 | -------------------------------------------------------------------------------- /tests/testthat/test_fitModelCpp.R: -------------------------------------------------------------------------------- 1 | context("C++ samplers") 2 | 3 | 4 | test_that( 5 | "Simple-MPT C++ sampling", 6 | { 7 | testthat::skip_on_cran() 8 | testthat::skip_on_ci() 9 | res <- simpleMPT( 10 | eqnfile = system.file("MPTmodels/2htsm.eqn", package = "TreeBUGS"), 11 | data = TreeBUGS::arnold2013[1:10, ], 12 | restrictions = list("D1 = D2 = D3", "d1 = d2"), 13 | n.iter = 1e3, 14 | n.burnin = 5e2, 15 | n.thin = 2 16 | ) 17 | expect_s3_class(object = res, class = "simpleMPT") 18 | } 19 | ) 20 | 21 | test_that( 22 | "Beta-MPT C++ sampling", 23 | { 24 | testthat::skip_on_cran() 25 | testthat::skip_on_ci() 26 | res <- betaMPTcpp( 27 | eqnfile = system.file("MPTmodels/2htsm.eqn", package = "TreeBUGS"), 28 | data = TreeBUGS::arnold2013[1:10, ], 29 | restrictions = list("D1 = D2 = D3", "d1 = d2"), 30 | n.iter = 1e3, 31 | n.burnin = 5e2, 32 | n.thin = 1 33 | ) 34 | expect_s3_class(object = res, class = "betaMPT") 35 | } 36 | ) 37 | -------------------------------------------------------------------------------- /R/T1perGroup.R: -------------------------------------------------------------------------------- 1 | 2 | # make index variables to compute T1 statistic by group 3 | getGroupT1 <- function(covData, predType, T1group = NULL) { 4 | if (!is.null(T1group)) { 5 | if (!T1group %in% colnames(covData)) { 6 | stop("T1group not found in covData (matching by column names)") 7 | } 8 | if (is.null(covData) || is.null(T1group)) { 9 | return(NULL) 10 | } 11 | 12 | groupTab <- table(covData[, T1group]) 13 | NgroupT1 <- as.vector(groupTab) 14 | groupNames <- names(groupTab) 15 | names(NgroupT1) <- groupNames 16 | N <- sum(NgroupT1) 17 | G <- length(NgroupT1) 18 | 19 | #### general index vector, stored in matrix 20 | groupMatT1 <- matrix(0, G, max(NgroupT1), 21 | dimnames = list(groupNames, NULL) 22 | ) 23 | cnt <- rep(0, G) 24 | for (i in 1:N) { 25 | group <- covData[i, T1group] 26 | groupMatT1[group, cnt[group] <- cnt[group] + 1] <- i 27 | } 28 | list( 29 | groupMatT1 = groupMatT1, 30 | NgroupT1 = NgroupT1 31 | ) 32 | } else { 33 | NULL 34 | } 35 | } 36 | -------------------------------------------------------------------------------- /R/BF_likelihoods.R: -------------------------------------------------------------------------------- 1 | 2 | # full log-likelihood of simple MPT models 3 | llMPT <- function(pars, mod, dataset = 1) { 4 | if (is.vector(pars)) pars <- t(pars) 5 | pars <- as.matrix(pars) 6 | ll <- loglikMPT( 7 | pars, 8 | unlist(mod$mptInfo$data[dataset, ]), 9 | mod$mptInfo$MPT$a, mod$mptInfo$MPT$b, 10 | mod$mptInfo$MPT$c, mod$mptInfo$MPT$map 11 | ) 12 | const <- logMultinomCoefficient(mod, dataset = dataset) 13 | ll + const 14 | } 15 | 16 | # product-multinomial constant for density 17 | logMultinomCoefficient <- function(mod, dataset = 1) { 18 | tree <- mod$mptInfo$MPT$tree.idx 19 | data <- mod$mptInfo$data[dataset, ] 20 | logCoef <- tapply(t(data), list(tree), function(n) { 21 | lgamma(sum(n) + 1) - sum(lgamma(n + 1)) 22 | }) 23 | sum(logCoef) 24 | } 25 | 26 | 27 | # density for product of beta distributions 28 | dProductBeta <- function(x, shapes, log = TRUE) { 29 | x <- as.matrix(x) 30 | ll <- 0 31 | for (i in 1:nrow(shapes)) { 32 | ll <- ll + dbeta(x[, i], shapes[i, 1], 33 | shapes[i, 2], 34 | log = TRUE 35 | ) 36 | } 37 | if (!log) ll <- exp(ll) 38 | ll 39 | } 40 | 41 | 42 | rProductBeta <- function(n, shapes) { 43 | apply(shapes, 1, function(s) rbeta(n, s[1], s[2])) 44 | } 45 | -------------------------------------------------------------------------------- /man/probitInverse.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/probitInverse.R 3 | \name{probitInverse} 4 | \alias{probitInverse} 5 | \title{Probit-Inverse of Group-Level Normal Distribution} 6 | \usage{ 7 | probitInverse(mu, sigma, fittedModel = NULL) 8 | } 9 | \arguments{ 10 | \item{mu}{latent-probit mean of normal distribution} 11 | 12 | \item{sigma}{latent-probit SD of normal distribution} 13 | 14 | \item{fittedModel}{optional: fitted \link{traitMPT} model. If provided, the 15 | bivariate inverse-probit transform is applied to all MCMC samples (and 16 | \code{mu} and \code{sigma} are ignored).} 17 | } 18 | \value{ 19 | implied mean and SD on probability scale 20 | } 21 | \description{ 22 | Transform latent group-level normal distribution (latent-trait MPT) into mean 23 | and SD on probability scale. 24 | } 25 | \examples{ 26 | ####### compare bivariate vs. univariate transformation 27 | probitInverse(mu = 0.8, sigma = c(0.25, 0.5, 0.75, 1)) 28 | pnorm(0.8) 29 | 30 | # full distribution 31 | prob <- pnorm(rnorm(10000, mean = 0.8, sd = 0.7)) 32 | hist(prob, 80, col = "gray", xlim = 0:1) 33 | 34 | \dontrun{ 35 | # transformation for fitted model 36 | mean_sd <- probitInverse(fittedModel = fit) 37 | summarizeMCMC(mean_sd) 38 | } 39 | } 40 | -------------------------------------------------------------------------------- /R/writeSummaryToFile.R: -------------------------------------------------------------------------------- 1 | 2 | # write summary to file 3 | writeSummary <- function(fittedModel, parEstFile = NULL) { 4 | if (!(missing(parEstFile) || is.null(parEstFile))) { 5 | sink(file = parEstFile, type = "o") 6 | try({ 7 | print(summary(fittedModel)) 8 | 9 | # cat("\n\n#################################\n#### Group Parameter Estimates\n") 10 | # print(fittedModel$summary$groupParameters) 11 | 12 | cat("\n\n#################################\n#### Individual Parameter Estimates\n") 13 | printIndividualPar(fittedModel$summary$individParameters) 14 | 15 | if (!is.null(fittedModel$summary$transformedParameters)) { 16 | cat("\n\n#################################\n#### Transformed Parameters (Group level)\n") 17 | print(fittedModel$summary$transformedParameters) 18 | } 19 | 20 | 21 | cat("\n\n#################################\n#### Model information\n") 22 | print(fittedModel$mptInfo) 23 | }) 24 | sink() 25 | } 26 | } 27 | 28 | 29 | # print array of individual estimates 30 | printIndividualPar <- function(array) { 31 | dd <- dim(array) 32 | par <- dimnames(array)[[1]] 33 | for (i in 1:dd[1]) { 34 | cat("Parameter ", par[i], "\n") 35 | print(array[i, , ]) 36 | } 37 | } 38 | -------------------------------------------------------------------------------- /man/getSamples.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/getSamples.R 3 | \name{getSamples} 4 | \alias{getSamples} 5 | \title{Get Posterior Samples from Fitted MPT Model} 6 | \usage{ 7 | getSamples( 8 | fittedModel, 9 | parameter = "mean", 10 | select = "all", 11 | names = "par_label" 12 | ) 13 | } 14 | \arguments{ 15 | \item{fittedModel}{a fitted latent-trait MPT model (see 16 | \code{\link{traitMPT}}) or beta MPT model (see \code{\link{betaMPT}})} 17 | 18 | \item{parameter}{which parameter(s) of the (hierarchical) MPT model should be 19 | returned? (see details in \code{\link{getParam}}).} 20 | 21 | \item{select}{character vector of parameters to be plotted (e.g., \code{select = c("d", "g")}. Can be used to plot subsets of parameters and change the order of parameters.} 22 | 23 | \item{names}{whether and how to rename the variables in the MCMC output: 24 | \code{par} (internal parameter labels such as \code{mu[1]}), \code{label} 25 | (MPT label from EQN file such as \code{"d"}), or \code{par_name} 26 | (concatenation of both such as \code{"mu[1]_d"}).} 27 | } 28 | \description{ 29 | Extracts MCMC posterior samples as an \code{coda::mcmc.list} and relabels the 30 | MCMC variables. 31 | } 32 | \examples{ 33 | \dontrun{ 34 | getSamples(fittedModel, "mu", select = c("d", "g")) 35 | } 36 | } 37 | -------------------------------------------------------------------------------- /man/plotParam.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/plotParameters.R 3 | \name{plotParam} 4 | \alias{plotParam} 5 | \title{Plot Parameter Estimates} 6 | \usage{ 7 | plotParam( 8 | x, 9 | includeIndividual = TRUE, 10 | addLines = FALSE, 11 | estimate = "mean", 12 | select = "all", 13 | ... 14 | ) 15 | } 16 | \arguments{ 17 | \item{x}{a fitted Beta or latent-trait MPT model} 18 | 19 | \item{includeIndividual}{whether to plot individual estimates} 20 | 21 | \item{addLines}{whether to connect individual parameter estimates by lines} 22 | 23 | \item{estimate}{type of point estimates for group-level and individual parameters 24 | (either \code{"mean"} or \code{"median"})} 25 | 26 | \item{select}{character vector of parameters to be plotted (e.g., \code{select = c("d", "g")}. Can be used to plot subsets of parameters and change the order of parameters.} 27 | 28 | \item{...}{further arguments passed to the standard \code{\link{plot}} function} 29 | } 30 | \description{ 31 | Plot parameter estimates for hierarchical MPT models. 32 | } 33 | \examples{ 34 | \dontrun{ 35 | plotParam(fit, 36 | addLines = TRUE, 37 | estimate = "median", 38 | select = c("d1", "d2") 39 | ) 40 | } 41 | } 42 | \seealso{ 43 | \code{\link{betaMPT}}, \code{\link{traitMPT}}, \code{\link{plotDistribution}} 44 | } 45 | \author{ 46 | Daniel Heck 47 | } 48 | -------------------------------------------------------------------------------- /man/PPP.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/PPP.R 3 | \name{PPP} 4 | \alias{PPP} 5 | \title{Compute Posterior Predictive P-Values} 6 | \usage{ 7 | PPP(fittedModel, M = 1000, nCPU = 4, T2 = TRUE, type = "X2") 8 | } 9 | \arguments{ 10 | \item{fittedModel}{fitted latent-trait or beta MPT model (\code{\link{traitMPT}}, \code{\link{betaMPT}})} 11 | 12 | \item{M}{number of posterior predictive samples. As a maximum, the number of posterior samples in \code{fittedModel} is used.} 13 | 14 | \item{nCPU}{number of CPUs used for parallel sampling. For large models and many participants, this requires considerable computer-memory resources (as a remedy, use \code{nCPU=1}).} 15 | 16 | \item{T2}{whether to compute T2 statistic to check coveriance structure (can 17 | take a lot of time). If some participants do not have responses for some 18 | trees, (co)variances are computed by pairwise deletion of the corresponding 19 | persons.} 20 | 21 | \item{type}{whether the T1 statistic of expected means is computed using 22 | Person's \code{"X2"} or the likelihood-ratio statistic \code{"G2"}} 23 | } 24 | \description{ 25 | Computes posterior predictive p-values to test model fit. 26 | } 27 | \references{ 28 | Klauer, K. C. (2010). Hierarchical multinomial processing tree 29 | models: A latent-trait approach. Psychometrika, 75, 70-98. 30 | } 31 | \author{ 32 | Daniel Heck 33 | } 34 | -------------------------------------------------------------------------------- /man/transformedParameters.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/transformedParPosthoc.R 3 | \name{transformedParameters} 4 | \alias{transformedParameters} 5 | \title{Get Transformed Parameters} 6 | \usage{ 7 | transformedParameters( 8 | fittedModel, 9 | transformedParameters, 10 | level = "group", 11 | nCPU = 4 12 | ) 13 | } 14 | \arguments{ 15 | \item{fittedModel}{either a fitted latent-trait or beta MPT model 16 | (\code{\link{traitMPT}}, \code{\link{betaMPT}}) or an 17 | \code{\link[coda]{mcmc.list}}.} 18 | 19 | \item{transformedParameters}{list with parameter transformations that should 20 | be computed based on the posterior samples (e.g., for testing parameter 21 | differences: \code{list("diffD=Do-Dn")}).} 22 | 23 | \item{level}{whether to compute transformations of \code{"group"} or 24 | \code{"individual"} estimates} 25 | 26 | \item{nCPU}{number of CPU cores across which the MCMC chains are distributed} 27 | } 28 | \value{ 29 | an \link[coda]{mcmc.list} of posterior samples for the transformed 30 | parameters 31 | } 32 | \description{ 33 | Computes transformations of MPT parameters based on the MCMC posterior 34 | samples (e.g., differences of parameters). 35 | } 36 | \examples{ 37 | \dontrun{ 38 | tt <- transformedParameters(fittedModel, 39 | list("diff = a-b", "p = a>b"), 40 | level = "individual" 41 | ) 42 | summary(tt) 43 | } 44 | } 45 | -------------------------------------------------------------------------------- /.github/workflows/check-standard.yaml: -------------------------------------------------------------------------------- 1 | # Workflow derived from https://github.com/r-lib/actions/tree/v2/examples 2 | # Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help 3 | on: 4 | push: 5 | branches: [main, master] 6 | pull_request: 7 | branches: [main, master] 8 | 9 | name: R-CMD-check 10 | 11 | jobs: 12 | R-CMD-check: 13 | runs-on: ${{ matrix.config.os }} 14 | 15 | name: ${{ matrix.config.os }} (${{ matrix.config.r }}) 16 | 17 | strategy: 18 | fail-fast: false 19 | matrix: 20 | config: 21 | - {os: ubuntu-latest, r: 'devel', http-user-agent: 'release'} 22 | - {os: ubuntu-latest, r: 'release'} 23 | 24 | env: 25 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 26 | R_KEEP_PKG_SOURCE: yes 27 | 28 | steps: 29 | - uses: actions/checkout@v3 30 | 31 | - uses: r-lib/actions/setup-pandoc@v2 32 | 33 | - uses: r-lib/actions/setup-r@v2 34 | with: 35 | r-version: ${{ matrix.config.r }} 36 | http-user-agent: ${{ matrix.config.http-user-agent }} 37 | use-public-rspm: true 38 | 39 | - uses: r-lib/actions/setup-r-dependencies@v2 40 | with: 41 | extra-packages: any::rcmdcheck 42 | needs: check 43 | 44 | - uses: r-lib/actions/check-r-package@v2 45 | with: 46 | upload-snapshots: true 47 | -------------------------------------------------------------------------------- /man/summarizeMPT.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/summarizeMPT.R 3 | \name{summarizeMPT} 4 | \alias{summarizeMPT} 5 | \title{Summarize JAGS Output for Hierarchical MPT Models} 6 | \usage{ 7 | summarizeMPT(mcmc, mptInfo, probs = c(0.025, 0.5, 0.975), summ = NULL) 8 | } 9 | \arguments{ 10 | \item{mcmc}{the actual mcmc.list output of the sampler of a fitted MPT model 11 | (accesible via \code{fittedModel$runjags$mcmc})} 12 | 13 | \item{mptInfo}{the internally stored information about the fitted MPT model 14 | (accesible via \code{fittedModel$mptInfo})} 15 | 16 | \item{probs}{quantile probabilities used to compute credibility intervals} 17 | 18 | \item{summ}{optional argument for internal use} 19 | } 20 | \description{ 21 | Provide clean and readable summary statistics tailored to MPT models based on 22 | the JAGS output. 23 | } 24 | \details{ 25 | The MPT-specific summary is computed directly after fitting a model. 26 | However, this function might be used manually after removing MCMC samples 27 | (e.g., extending the burnin period). 28 | } 29 | \examples{ 30 | # Remove additional burnin samples and recompute MPT summary 31 | \dontrun{ 32 | # start later or thin (see ?window) 33 | mcmc.subsamp <- window(fittedModel$runjags$mcmc, start = 3001, thin = 2) 34 | new.mpt.summary <- summarizeMPT(mcmc.subsamp, fittedModel$mptInfo) 35 | new.mpt.summary 36 | } 37 | } 38 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: r 2 | latex: true 3 | 4 | warnings_are_errors: TRUE 5 | r_check_args: '--ignore-vignettes' 6 | r_build_args: '--no-build-vignettes' 7 | 8 | cache: 9 | - packages 10 | - ccache 11 | 12 | before_install: 13 | - sudo apt-get install jags libgit2-dev libharfbuzz-dev libfribidi-dev 14 | 15 | env: 16 | - WARNINGS_ARE_ERRORS=1 17 | _R_CHECK_FORCE_SUGGESTS_=true 18 | _R_CHECK_CRAN_INCOMING_=true 19 | 20 | repos: 21 | CRAN: https://cloud.r-project.org 22 | ropensci: http://packages.ropensci.org 23 | 24 | matrix: 25 | include: 26 | - r: release 27 | r_packages: 28 | - devtools 29 | - Rcpp 30 | - RcppArmadillo 31 | - runjags 32 | - hypergeo 33 | - logspline 34 | - testthat 35 | - R.rsp 36 | - rjags 37 | - remotes 38 | - knitr 39 | - rmarkdown 40 | - r: devel 41 | r_packages: 42 | - devtools 43 | - Rcpp 44 | - RcppArmadillo 45 | - runjags 46 | - hypergeo 47 | - logspline 48 | - testthat 49 | - R.rsp 50 | - rjags 51 | - remotes 52 | - knitr 53 | - rmarkdown 54 | 55 | notifications: 56 | email: 57 | on_success: change 58 | on_failure: change 59 | 60 | # r_github_packages: 61 | # - jimhester/covr 62 | # after_success: 63 | # - Rscript -e 'library(covr);coveralls()' 64 | -------------------------------------------------------------------------------- /man/plotPriorPost.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/plotPriorPost.R 3 | \name{plotPriorPost} 4 | \alias{plotPriorPost} 5 | \title{Plot Prior vs. Posterior Distribution} 6 | \usage{ 7 | plotPriorPost( 8 | fittedModel, 9 | probitInverse = "mean", 10 | M = 2e+05, 11 | ci = 0.95, 12 | nCPU = 3, 13 | ... 14 | ) 15 | } 16 | \arguments{ 17 | \item{fittedModel}{fitted latent-trait or beta MPT model (\code{\link{traitMPT}}, \code{\link{betaMPT}})} 18 | 19 | \item{probitInverse}{which latent-probit parameters (for 20 | \code{\link{traitMPT}} model) to transform to probability scale. Either 21 | \code{"none"}, \code{"mean"} (simple transformation \eqn{\Phi(\mu)}), or 22 | \code{"mean_sd"} (see \code{\link{probitInverse}})} 23 | 24 | \item{M}{number of random samples to approximate prior distributions} 25 | 26 | \item{ci}{credibility interval indicated by vertical red lines} 27 | 28 | \item{nCPU}{number of CPUs used for parallel sampling. For large models and 29 | many participants, this may require a lot of memory.} 30 | 31 | \item{...}{arguments passed to \code{\link{boxplot}}} 32 | } 33 | \description{ 34 | Allows to judge how much the data informed the parameter posterior 35 | distributions compared to the prior. 36 | } 37 | \details{ 38 | Prior distributions are shown as blue, dashed lines, whereas 39 | posterior distributions are shown as solid, black lines. 40 | } 41 | -------------------------------------------------------------------------------- /man/getGroupMeans.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/getGroupMeans.R 3 | \name{getGroupMeans} 4 | \alias{getGroupMeans} 5 | \title{Get Mean Parameters per Group} 6 | \usage{ 7 | getGroupMeans( 8 | traitMPT, 9 | factor = "all", 10 | probit = FALSE, 11 | file = NULL, 12 | mcmc = FALSE 13 | ) 14 | } 15 | \arguments{ 16 | \item{traitMPT}{a fitted \code{\link{traitMPT}} model} 17 | 18 | \item{factor}{whether to get group estimates for all combinations of factor 19 | levels (default) or only for specific factors (requires the names of the 20 | covariates in covData)} 21 | 22 | \item{probit}{whether to use probit scale or probability scale} 23 | 24 | \item{file}{filename to export results in .csv format (e.g., 25 | \code{file="fit_group.csv"})} 26 | 27 | \item{mcmc}{if \code{TRUE}, the raw MCMC samples for the group means are 28 | returned as an \code{\link[coda]{mcmc.list}} object. This allows pairwise 29 | tests of group means (see \code{\link{transformedParameters}}).} 30 | } 31 | \description{ 32 | For hierarchical latent-trait MPT models with discrete predictor variables as 33 | fitted with \code{traitMPT(..., predStructure = list("f"))}. 34 | } 35 | \examples{ 36 | \dontrun{ 37 | # save group means (probability scale): 38 | getGroupMeans(traitMPT, file = "groups.csv") 39 | } 40 | } 41 | \seealso{ 42 | \code{\link{getParam}} for parameter estimates 43 | } 44 | \author{ 45 | Daniel Heck 46 | } 47 | -------------------------------------------------------------------------------- /man/plotDistribution.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/plotDistribution.R 3 | \name{plotDistribution} 4 | \alias{plotDistribution} 5 | \title{Plot Distribution of Individual Estimates} 6 | \usage{ 7 | plotDistribution(fittedModel, scale = "probability", ...) 8 | } 9 | \arguments{ 10 | \item{fittedModel}{fitted latent-trait or beta MPT model 11 | (\code{\link{traitMPT}}, \code{\link{betaMPT}})} 12 | 13 | \item{scale}{only for latent-trait MPT: should estimates be plotted on the 14 | \code{"latent"} or the \code{"probability"} scale (i.e., as MPT 15 | parameters). Can be abbreviated by \code{"l"} and \code{"p"}.} 16 | 17 | \item{...}{further arguments passed to \code{\link{hist}} (e.g., 18 | \code{breaks=50} to get a more fine-grained histogram)} 19 | } 20 | \description{ 21 | Plots histograms of the posterior-means of individual MPT parameters against 22 | the group-level distribution given by the posterior-mean of the hierarchical 23 | parameters (e.g., the beta distribution in case of the beta-MPT) 24 | } 25 | \details{ 26 | For the latent-trait MPT, differences due to continuous predictors 27 | or discrete factors are currently not considered in the group-level 28 | predictions (red density). Under such a model, individual estimates are not 29 | predicted to be normally distributed on the latent scale as shown in the 30 | plot. 31 | } 32 | \seealso{ 33 | \code{\link{plot.traitMPT}} 34 | } 35 | -------------------------------------------------------------------------------- /man/extendMPT.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/extendMPT.R 3 | \name{extendMPT} 4 | \alias{extendMPT} 5 | \title{Extend MCMC Sampling for MPT Model} 6 | \usage{ 7 | extendMPT(fittedModel, n.iter = 10000, n.adapt = 1000, n.burnin = 0, ...) 8 | } 9 | \arguments{ 10 | \item{fittedModel}{a fitted \code{\link{traitMPT}} or \code{\link{betaMPT}}} 11 | 12 | \item{n.iter}{Number of iterations per chain (including burnin samples). See 13 | \code{\link[runjags]{run.jags}} for details.} 14 | 15 | \item{n.adapt}{number of adaption samples to adjust MCMC sampler in JAGS. The 16 | sampler will be more efficient if it is tuned well. However, MCMC sampling 17 | will still give correct results even if the warning appears: "Adaptation 18 | incomplete." (this just means that sampling efficiency could be better).} 19 | 20 | \item{n.burnin}{Number of samples for burnin (samples will not be stored and 21 | removed from n.iter)} 22 | 23 | \item{...}{further arguments passed to \code{extend.jags} (see arguments 24 | listed in: \link[runjags]{run.jags}). 25 | 26 | When drawing more samples, JAGS requires an additional adaptation phase, in 27 | which the MCMC sampling procedure is adjusted. Note that the MCMC sampling 28 | will still give correct results even if the warning appears: "Adaptation 29 | incomplete." (this just means that sampling efficiency is not optimal).} 30 | } 31 | \description{ 32 | Adds more MCMC samples to the fitted MPT model. 33 | } 34 | -------------------------------------------------------------------------------- /man/plotFit.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/plotFit.R 3 | \name{plotFit} 4 | \alias{plotFit} 5 | \title{Plot Posterior Predictive Mean Frequencies} 6 | \usage{ 7 | plotFit(fittedModel, M = 1000, stat = "mean", ...) 8 | } 9 | \arguments{ 10 | \item{fittedModel}{fitted latent-trait or beta MPT model (\code{\link{traitMPT}}, \code{\link{betaMPT}})} 11 | 12 | \item{M}{number of posterior predictive samples. As a maximum, the number of posterior samples in \code{fittedModel} is used.} 13 | 14 | \item{stat}{whether to plot mean frequencies (\code{"mean"}) or covariances 15 | of individual frequencies (\code{"cov"})} 16 | 17 | \item{...}{arguments passed to \code{\link{boxplot}}} 18 | } 19 | \description{ 20 | Plots observed means/covariances of individual frequencies against the 21 | means/covariances sampled from the posterior distribution (posterior 22 | predictive distribution). 23 | } 24 | \details{ 25 | If posterior predictive p-values were computed when fitting the 26 | model (e.g., by adding the argument \code{traitMPT(...,ppp=1000)} ), the 27 | stored posterior samples are re-used for plotting. Note that the last 28 | category in each MPT tree is dropped, because one category per multinomial 29 | distribution is fixed. 30 | } 31 | \examples{ 32 | \dontrun{ 33 | # add posterior predictive samples to fitted model (optional step) 34 | fittedModel$postpred$freq.pred <- 35 | posteriorPredictive(fittedModel, M = 1000) 36 | 37 | # plot model fit 38 | plotFit(fittedModel, stat = "mean") 39 | } 40 | } 41 | -------------------------------------------------------------------------------- /man/withinSubjectEQN.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/within_subject_EQN.R 3 | \name{withinSubjectEQN} 4 | \alias{withinSubjectEQN} 5 | \title{Generate EQN Files for Within-Subject Designs} 6 | \usage{ 7 | withinSubjectEQN(eqnfile, labels, constant, save) 8 | } 9 | \arguments{ 10 | \item{eqnfile}{The (relative or full) path to the file that specifies the MPT 11 | model (standard .eqn syntax). Note that category labels must start with a 12 | letter (different to multiTree) and match the column names of \code{data}. 13 | Alternatively, the EQN-equations can be provided within R as a character 14 | value (cf. \code{\link{readEQN}}). Note that the first line of an .eqn-file 15 | is reserved for comments and always ignored.} 16 | 17 | \item{labels}{a character vector defining the labels that are added to the 18 | parameters in each within-subject condition} 19 | 20 | \item{constant}{optional: a character vector defining which parameters are 21 | constrained to be constant across within-conditions} 22 | 23 | \item{save}{optional: path to an EQN output file. By default, the model is 24 | return as a string character} 25 | } 26 | \description{ 27 | Replicates an MPT model multiple times with different tree, category, and 28 | parameter labels for within-subject factorial designs. 29 | } 30 | \examples{ 31 | # Example: Standard Two-High-Threshold Model (2HTM) 32 | EQNfile <- system.file("MPTmodels/2htm.eqn", 33 | package = "TreeBUGS" 34 | ) 35 | withinSubjectEQN(EQNfile, c("high", "low"), constant = c("g")) 36 | } 37 | -------------------------------------------------------------------------------- /R/renameBUGSoutput.R: -------------------------------------------------------------------------------- 1 | 2 | 3 | ################ deprecated: only for use with R2jags 4 | # rename BUGSoutput object for further use 5 | renameBUGSoutput <- function(BUGSoutput, 6 | thetaUnique, 7 | model = c("traitMPT", "betaMPT")) { 8 | rownames(BUGSoutput$median$theta) <- 9 | rownames(BUGSoutput$mean$theta) <- 10 | rownames(BUGSoutput$sd$theta) <- 11 | names(BUGSoutput$mean$mean) <- 12 | names(BUGSoutput$sd$mean) <- 13 | names(BUGSoutput$median$mean) <- 14 | thetaUnique 15 | 16 | if (model == "traitMPT") { 17 | rownames(BUGSoutput$median$rho) <- 18 | rownames(BUGSoutput$mean$rho) <- 19 | rownames(BUGSoutput$sd$rho) <- 20 | colnames(BUGSoutput$median$rho) <- 21 | colnames(BUGSoutput$mean$rho) <- 22 | colnames(BUGSoutput$sd$rho) <- 23 | names(BUGSoutput$mean$mu) <- 24 | names(BUGSoutput$sd$mu) <- 25 | names(BUGSoutput$median$mu) <- 26 | names(BUGSoutput$mean$sigma) <- 27 | names(BUGSoutput$sd$sigma) <- 28 | names(BUGSoutput$median$sigma) <- 29 | thetaUnique 30 | } else if (model == "betaMPT") { 31 | names(BUGSoutput$mean$alph) <- 32 | names(BUGSoutput$mean$bet) <- 33 | names(BUGSoutput$sd$alph) <- 34 | names(BUGSoutput$sd$bet) <- 35 | names(BUGSoutput$median$alph) <- 36 | names(BUGSoutput$median$bet) <- 37 | names(BUGSoutput$mean$sd) <- 38 | names(BUGSoutput$sd$sd) <- 39 | names(BUGSoutput$median$sd) <- 40 | thetaUnique 41 | } 42 | BUGSoutput 43 | } 44 | -------------------------------------------------------------------------------- /src/loglikMPT.cpp: -------------------------------------------------------------------------------- 1 | // -*- mode: C++; c-indent-level: 4; c-basic-offset: 4; indent-tabs-mode: nil; -*- 2 | // [[Rcpp::depends(RcppArmadillo)]] 3 | #include 4 | // #include 5 | // #include 6 | // #include 7 | 8 | using namespace Rcpp; 9 | 10 | // MPT log-likelihood (without multinomial normalizing constants!) 11 | // [[Rcpp::export]] 12 | arma::vec loglikMPT(arma::mat theta, // MPT parameters 13 | arma::vec h, // response frequencies 14 | arma::mat a, 15 | arma::mat b, 16 | arma::vec c, 17 | arma::vec map) 18 | { 19 | // initialize predicted category probabilities 20 | arma::vec cat = arma::zeros(h.n_elem); 21 | double branch; 22 | arma::vec ll(theta.n_rows); 23 | 24 | // loop across separate sets of parameters: 25 | for(arma::uword m=0; m covData 22 | if (!is.null(covData) && !ncol(covData) == 0) { 23 | cor.samp <- matrix(t(apply(theta, 1, function(tt) { 24 | theta.tmp <- matrix(tt, nrow = nrow(covData), byrow = TRUE) 25 | cor(theta.tmp, covData) 26 | })), nrow = nrow(theta)) 27 | cor.names <- outer(thetaUnique, colnames(covData), FUN = paste, sep = "_") 28 | colnames(cor.samp) <- paste0("cor_", cor.names) 29 | } else { 30 | cor.samp <- NULL 31 | } 32 | 33 | ########## intercorrelations for theta (=rho) 34 | if (rho & ncol(theta) > 1) { 35 | rho.samp <- matrix(t(apply(theta, 1, function(tt) { 36 | theta.tmp <- matrix(tt, nrow = length(tt) / S, byrow = TRUE) 37 | cc <- cor(theta.tmp) 38 | # cc[lower.tri(cc)] 39 | cc 40 | })), nrow = nrow(theta)) 41 | rho.names <- outer(1:length(thetaUnique), 42 | 1:length(thetaUnique), 43 | FUN = paste, sep = "," 44 | ) 45 | # colnames(rho.samp) <- paste0("rho[",rho.names[lower.tri(rho.names)],"]") 46 | colnames(rho.samp) <- paste0("rho[", rho.names, "]") 47 | } else { 48 | rho.samp <- NULL 49 | } 50 | 51 | mcmc.attr <- attr(mcmc, "mcpar") 52 | mcmc(cbind(mcmc, cor.samp, rho.samp), 53 | start = mcmc.attr[1], end = mcmc.attr[2], thin = mcmc.attr[3] 54 | ) 55 | } 56 | -------------------------------------------------------------------------------- /R/BF_auxiliary.R: -------------------------------------------------------------------------------- 1 | 2 | # Approximate posterior distribution of MPT parameters by a well-known, simple density 3 | # Curently, only distribution="beta" is implemented 4 | approximatePosterior <- function(mod, dataset = 1, 5 | sample = 500, distribution = "beta", 6 | lower = .1, upper = 1e4) { 7 | # estimate alpha/beta parameters of beta approximation 8 | S <- length(mod$mptInfo$thetaUnique) 9 | betapar <- matrix(1, S, 2, dimnames = list( 10 | mod$mptInfo$thetaUnique, 11 | c("alpha", "beta") 12 | )) 13 | for (i in 1:S) { 14 | sel <- paste0("theta[", i, ",", dataset, "]") 15 | ss <- unlist(mod$runjags$mcmc[, sel]) 16 | ss <- sample(ss, min(sample, length(ss))) 17 | m <- mean(ss) 18 | v <- var(ss) 19 | betapar[i, 1] <- m * (m * (1 - m) / v - 1) 20 | betapar[i, 2] <- (1 - m) * (m * (1 - m) / v - 1) 21 | try( 22 | betapar[i, ] <- fitdistr(ss, "beta", 23 | list( 24 | shape1 = betapar[i, 1], 25 | shape2 = betapar[i, 2] 26 | ), 27 | lower = lower, 28 | upper = upper 29 | )$estimate, 30 | silent = TRUE 31 | ) 32 | } 33 | betapar 34 | } 35 | 36 | 37 | # resample MCMC iterations from simpleMPT object 38 | resampling <- function(mod, dataset = 1, resample = 1000) { 39 | S <- length(mod$mptInfo$thetaUnique) 40 | 41 | sel <- paste0("theta[", 1:S, ",", dataset, "]") 42 | C <- length(mod$runjags$mcmc) 43 | R <- nrow(mod$runjags$mcmc[[1]]) 44 | r <- ceiling(resample / C) 45 | if (resample > C * R) { 46 | warning( 47 | "Fitted models have less samples than required for resampling.", 48 | "Posterior samples will be reused!" 49 | ) 50 | rr <- lapply( 51 | mod$runjags$mcmc[, sel, drop = FALSE], 52 | function(mm) mm[sample(1:R, r, replace = TRUE), , drop = FALSE] 53 | ) 54 | } else { 55 | rr <- lapply( 56 | mod$runjags$mcmc[, sel, drop = FALSE], 57 | function(mm) mm[sample(1:R, r), , drop = FALSE] 58 | ) 59 | } 60 | do.call("rbind", rr)[1:resample, , drop = FALSE] 61 | } 62 | -------------------------------------------------------------------------------- /vignettes/TreeBUGS_2_extended.R: -------------------------------------------------------------------------------- 1 | ## ---- eval=F------------------------------------------------------------------ 2 | # fitMPT <- traitMPT( 3 | # eqnfile = "2htm.txt", 4 | # data = "data_ind.csv", 5 | # restrictions = list("Dn=Do", "g=.5"), 6 | # covData = "data_covariates.csv", 7 | # corProbit = TRUE, 8 | # predStructure = list("Do ; IQ"), # IQ as predictor for Do=Dn 9 | # ... 10 | # ) 11 | 12 | ## ---- eval = FALSE------------------------------------------------------------ 13 | # fitMPT <- traitMPT( 14 | # eqnfile = "2htm.txt", 15 | # data = "data_ind.csv", 16 | # covData = "data_covariates.csv", 17 | # predStructure = list( 18 | # "Do ; factor1", 19 | # "Dn ; factor2" 20 | # ), # discrete factors 21 | # predType = c("c", "c", "f", "r") 22 | # ) 23 | 24 | ## ---- eval=F------------------------------------------------------------------ 25 | # getGroupMeans(fitMPT) 26 | 27 | ## ---- eval=FALSE-------------------------------------------------------------- 28 | # transformedParameters <- list( 29 | # "deltaG = G_1-G_2", # difference of parameters 30 | # "G1_larger = G_1>G_2" 31 | # ) # Bayesian p-value / testing order constraints 32 | 33 | ## ---- eval=FALSE-------------------------------------------------------------- 34 | # # beta-MPT 35 | # genBeta <- genBetaMPT( 36 | # N = 100, # number of participants 37 | # numItems = c(Target = 250, Lure = 250), # number of responses per tree 38 | # eqnfile = "2htm.eqn", # path to MPT file 39 | # mean = c(Do = .7, Dn = .7, g = .5), # true group-level parameters 40 | # sd = c(Do = .1, Dn = .1, g = .05) 41 | # ) # SD of individual parameters 42 | # 43 | # # latent-trait MPT 44 | # genTrait <- genTraitMPT( 45 | # N = 100, # number of participants 46 | # numItems = c(Target = 250, Lure = 250), # number of responses per tree 47 | # eqnfile = "2htm.eqn", # path to MPT file 48 | # mean = c(Do = .7, Dn = .7, g = .5), # true group-level parameters 49 | # sigma = c(Do = .25, Dn = .25, g = .05), # SD of latent (!) individual parameters 50 | # rho = diag(3) 51 | # ) # correlation matrix. here: no correlation 52 | 53 | -------------------------------------------------------------------------------- /man/getParam.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/getParam.R 3 | \name{getParam} 4 | \alias{getParam} 5 | \title{Get Parameter Posterior Statistics} 6 | \usage{ 7 | getParam(fittedModel, parameter = "mean", stat = "mean", file = NULL) 8 | } 9 | \arguments{ 10 | \item{fittedModel}{a fitted latent-trait MPT model (see 11 | \code{\link{traitMPT}}) or beta MPT model (see \code{\link{betaMPT}})} 12 | 13 | \item{parameter}{which parameter(s) of the (hierarchical) MPT model should be 14 | returned? (see details in \code{\link{getParam}}).} 15 | 16 | \item{stat}{whether to get the posterior \code{"mean"}, \code{"median"}, 17 | \code{"sd"}, or \code{"summary"} (includes mean, SD, and 95\% credibility 18 | interval)} 19 | 20 | \item{file}{filename to export results in .csv format (e.g., 21 | \code{file="est_param.csv"})} 22 | } 23 | \description{ 24 | Returns posterior statistics (e.g., mean, median) for the parameters of a 25 | hierarchical MPT model. 26 | } 27 | \details{ 28 | This function is a convenient way to get the information stored in 29 | \code{fittedModel$mcmc.summ}. 30 | 31 | The latent-trait MPT includes the following parameters: 32 | \itemize{ 33 | \item \code{"mean"} (group means on probability scale) 34 | \item \code{"mu"} (group means on probit scale) 35 | \item \code{"sigma"} (SD on probit scale) 36 | \item \code{"rho"} (correlations on probit scale) 37 | \item \code{"theta"} (individual MPT parameters) 38 | } 39 | 40 | The beta MPT includes the following parameters: 41 | \itemize{ 42 | \item \code{"mean"} (group means on probability scale) 43 | \item \code{"sd"} (SD on probability scale) 44 | \item \code{"alph"},\code{"bet"} (group parameters of beta distribution) 45 | \item \code{"theta"} (individual MPT parameters) 46 | } 47 | } 48 | \examples{ 49 | \dontrun{ 50 | # mean estimates per person: 51 | getParam(fittedModel, parameter = "theta") 52 | 53 | # save summary of individual estimates: 54 | getParam(fittedModel, 55 | parameter = "theta", 56 | stat = "summary", file = "ind_summ.csv" 57 | ) 58 | } 59 | } 60 | \seealso{ 61 | \code{\link{getGroupMeans}} mean group estimates 62 | } 63 | \author{ 64 | Daniel Heck 65 | } 66 | -------------------------------------------------------------------------------- /man/plotPrior.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/plotPrior.R 3 | \name{plotPrior} 4 | \alias{plotPrior} 5 | \title{Plot Prior Distributions} 6 | \usage{ 7 | plotPrior(prior, probitInverse = "mean", M = 5000, nCPU = 3, ...) 8 | } 9 | \arguments{ 10 | \item{prior}{a named list defining the priors. For the \link{traitMPT}, the 11 | default is \code{list(mu = "dnorm(0,1)", xi="dunif(0,10)", V=diag(S), 12 | df=S+1)}, where S is the number of free parameters. For the \link{betaMPT}, 13 | the default is \code{list(alpha ="dgamma(1,.1)", beta = "dgamma(1,.1)")}. 14 | Note that the normal distribution \code{"dnorm(mu,prec)"} is parameterized 15 | as in JAGS by the mean and precision (= 1/variance).} 16 | 17 | \item{probitInverse}{which latent-probit parameters (for 18 | \code{\link{traitMPT}} model) to transform to probability scale. Either 19 | \code{"none"}, \code{"mean"} (simple transformation \eqn{\Phi(\mu)}), or 20 | \code{"mean_sd"} (see \code{\link{probitInverse}})} 21 | 22 | \item{M}{number of random samples to approximate priors of group-level 23 | parameters} 24 | 25 | \item{nCPU}{number of CPUs used for parallel sampling. For large models and 26 | many participants, this may require a lot of memory.} 27 | 28 | \item{...}{further arguments passed to \code{plot}} 29 | } 30 | \description{ 31 | Plots prior distributions for group means, standard deviation, and 32 | correlations of MPT parameters across participants. 33 | } 34 | \details{ 35 | This function samples from a set of hyperpriors (either for 36 | hierarchical traitMPT or betaMPT structure) to approximate the implied 37 | prior distributions on the parameters of interest (group-level mean, SD, 38 | and correlations of MPT parameters). Note that the normal distribution 39 | \code{"dnorm(mu,prec)"} is parameterized as in JAGS by the mean and 40 | precision (= 1/variance). 41 | } 42 | \examples{ 43 | \dontrun{ 44 | # default priors for traitMPT: 45 | plotPrior(list( 46 | mu = "dnorm(0, 1)", 47 | xi = "dunif(0, 10)", 48 | V = diag(2), 49 | df = 2 + 1 50 | ), M = 4000) 51 | 52 | # default priors for betaMPT: 53 | plotPrior(list( 54 | alpha = "dgamma(1, 0.1)", 55 | beta = "dgamma(1, 0.1)" 56 | ), M = 4000) 57 | } 58 | } 59 | \seealso{ 60 | \code{\link{priorPredictive}} 61 | } 62 | -------------------------------------------------------------------------------- /R/parseEQN.R: -------------------------------------------------------------------------------- 1 | 2 | # tab <- readEQN("2htm.eqn") 3 | 4 | parseEQN <- function(tab) { 5 | branch.names <- paste(tab$Tree, tab$Category, sep = "_") 6 | 7 | 8 | # simple extractions 9 | cat.names <- unlist(tapply( 10 | tab$Category, tab$Tree, 11 | function(x) sort(unique(x)) 12 | )) 13 | J <- length(cat.names) 14 | B <- nrow(tab) 15 | map <- match(tab$Category, cat.names) 16 | names(map) <- paste0("br", 1:B) 17 | tree.names <- unique(tab$Tree) 18 | R <- length(tree.names) 19 | tree.vec <- match(tab$Tree, tree.names) 20 | 21 | 22 | # JxB matrix: reduce branch to category probabilities 23 | reduce <- matrix(0, J, B, 24 | dimnames = list( 25 | cat = cat.names, 26 | branch = paste0("br", 1:B) 27 | ) 28 | ) 29 | for (rr in 1:B) { 30 | reduce[map[rr], rr] <- 1 31 | } 32 | 33 | 34 | # assignment of categories to trees: 35 | cat.to.tree <- matrix(tree.vec, J, B, byrow = TRUE) * reduce 36 | tree.idx <- apply( 37 | cat.to.tree, 1, 38 | function(xx) unique(xx[xx != 0]) 39 | ) 40 | warn <- paste0( 41 | "check definition of categories and trees:", 42 | "\n some categories are assigned to more than one tree!" 43 | ) 44 | if (!is.numeric(tree.idx)) { 45 | print(rbind(Tree = tree.names[tree.idx], Category = cat.names)) 46 | stop(warn) 47 | } 48 | 49 | ####### 2. MPT model structure: build matrices a and b 50 | mpt.list <- strsplit(tab$Equation, split = "*", fixed = TRUE) 51 | mpt.unique <- unique(unlist(mpt.list)) 52 | selpar <- grep("(", mpt.unique, fixed = TRUE, invert = TRUE) 53 | S <- length(selpar) 54 | theta.names <- sort(mpt.unique[selpar]) 55 | theta.comp <- paste0("(1-", theta.names, ")") 56 | a <- b <- matrix(0, B, S, dimnames = list(branch.names, theta.names)) 57 | for (bbb in 1:B) { 58 | tmp <- table(mpt.list[[bbb]]) 59 | sel_a <- theta.names %in% rownames(tmp) 60 | a[bbb, sel_a] <- tmp[rownames(tmp) %in% theta.names] 61 | sel_b <- theta.comp %in% rownames(tmp) 62 | b[bbb, sel_b] <- tmp[rownames(tmp) %in% theta.comp] 63 | } 64 | list( 65 | a = a, b = b, 66 | # reduce branches to categories: 67 | map = map, 68 | R = R, 69 | # trees: 70 | tree.idx = tree.idx, 71 | # labels: 72 | cat.names = cat.names, 73 | tree.names = tree.names 74 | ) 75 | } 76 | -------------------------------------------------------------------------------- /man/BayesFactorMPT.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/BF_Rao_Blackwell.R 3 | \name{BayesFactorMPT} 4 | \alias{BayesFactorMPT} 5 | \title{Bayes Factors for Simple (Nonhierarchical) MPT Models} 6 | \usage{ 7 | BayesFactorMPT( 8 | models, 9 | dataset = 1, 10 | resample, 11 | batches = 5, 12 | scale = 1, 13 | store = FALSE, 14 | cores = 1 15 | ) 16 | } 17 | \arguments{ 18 | \item{models}{list of models fitted with \code{\link{simpleMPT}}, e.g., 19 | \code{list(mod1, mod2)}} 20 | 21 | \item{dataset}{for which data set should Bayes factors be computed?} 22 | 23 | \item{resample}{how many of the posterior samples of the MPT parameters 24 | should be resampled per model} 25 | 26 | \item{batches}{number of batches. Used to compute a standard error of the 27 | estimate.} 28 | 29 | \item{scale}{how much should posterior-beta approximations be downscaled to 30 | get fatter importance-sampling density} 31 | 32 | \item{store}{whether to save parameter samples} 33 | 34 | \item{cores}{number of CPUs used} 35 | } 36 | \description{ 37 | Computes Bayes factors for simple (fixed-effects, nonhierarchical) MPT models 38 | with beta distributions as priors on the parameters. 39 | } 40 | \details{ 41 | Currently, this is only implemented for a single data set! 42 | 43 | Uses a Rao-Blackwellized version of the product-space method (Carlin & Chib, 44 | 1995) as proposed by Barker and Link (2013). First, posterior distributions 45 | of the MPT parameters are approximated by independent beta distributions. 46 | Second, for one a selected model, parameters are sampled from these proposal 47 | distributions. Third, the conditional probabilities to switch to a different 48 | model are computed and stored. Finally, the eigenvector with eigenvalue one 49 | of the matrix of switching probabilities provides an estimate of the 50 | posterior model probabilities. 51 | } 52 | \references{ 53 | Barker, R. J., & Link, W. A. (2013). Bayesian multimodel 54 | inference by RJMCMC: A Gibbs sampling approach. The American Statistician, 55 | 67(3), 150-156. 56 | 57 | Carlin, B. P., & Chib, S. (1995). Bayesian model choice via Markov chain 58 | Monte Carlo methods. Journal of the Royal Statistical Society. Series B 59 | (Methodological), 57(3), 473-484. 60 | } 61 | \seealso{ 62 | \code{\link{marginalMPT}} 63 | } 64 | -------------------------------------------------------------------------------- /man/genMPT.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/genDataMPT.R 3 | \name{genMPT} 4 | \alias{genMPT} 5 | \title{Generate MPT Frequencies} 6 | \usage{ 7 | genMPT(theta, numItems, eqnfile, restrictions, warning = TRUE) 8 | } 9 | \arguments{ 10 | \item{theta}{matrix of MPT parameters (rows: individuals; columns: 11 | parameters). Parameters are assigned by column names of the matrix. all of 12 | the parameters in the model file need to be included.} 13 | 14 | \item{numItems}{number of responses per tree (a named vector with tree 15 | labels)} 16 | 17 | \item{eqnfile}{The (relative or full) path to the file that specifies the MPT 18 | model (standard .eqn syntax). Note that category labels must start with a 19 | letter (different to multiTree) and match the column names of \code{data}. 20 | Alternatively, the EQN-equations can be provided within R as a character 21 | value (cf. \code{\link{readEQN}}). Note that the first line of an .eqn-file 22 | is reserved for comments and always ignored.} 23 | 24 | \item{restrictions}{Specifies which parameters should be (a) constant (e.g., 25 | \code{"a=b=.5"}) or (b) constrained to be identical (e.g., \code{"Do=Dn"}) 26 | or (c) treated as fixed effects (i.e., identical for all participants; 27 | \code{"a=b=FE"}). Either given as the path to a text file with restrictions 28 | per row or as a list of restrictions, e.g., \code{list("D1=D2","g=0.5")}. 29 | Note that numbers in .eqn-equations (e.g., \code{d*(1-g)*.50}) are directly 30 | interpreted as equality constraints.} 31 | 32 | \item{warning}{whether to show warning in case the naming of data-generating 33 | parameters are unnamed or do not match} 34 | } 35 | \description{ 36 | Uses a matrix of individual MPT parameters to generate MPT frequencies. 37 | } 38 | \examples{ 39 | # Example: Standard Two-High-Threshold Model (2HTM) 40 | EQNfile <- system.file("MPTmodels/2htm.eqn", package = "TreeBUGS") 41 | theta <- matrix( 42 | c( 43 | .8, .4, .5, 44 | .6, .3, .4 45 | ), 46 | nrow = 2, byrow = TRUE, 47 | dimnames = list(NULL, c("Do", "Dn", "g")) 48 | ) 49 | genDat <- genMPT( 50 | theta, c(Target = 250, Lure = 250), 51 | EQNfile 52 | ) 53 | genDat 54 | } 55 | \seealso{ 56 | \code{\link{genTraitMPT}} and \code{\link{genBetaMPT}} to generate 57 | data for latent normal/beta hierarchical distributions. 58 | } 59 | -------------------------------------------------------------------------------- /R/checkFunctions.R: -------------------------------------------------------------------------------- 1 | 2 | 3 | ### CHECK FUNCTIONS FOR INPUT 4 | 5 | 6 | checkParEstFile <- function(parEstFile) { 7 | if (!missing(parEstFile) && !is.null(parEstFile)) { 8 | if (!is.character(parEstFile)) { 9 | stop("'parEstFile' must be a character string pointing\n to the output file in an existing directory.") 10 | } 11 | } 12 | NULL 13 | } 14 | 15 | 16 | checkModelfilename <- function(modelfilename) { 17 | if (missing(modelfilename) || is.null(modelfilename)) { 18 | modelfilename <- tempfile(pattern = "MODELFILE", fileext = ".txt") 19 | } else if (!is.character(modelfilename)) { 20 | stop("'parEstFile' must be a character string pointing\n to the mode file in an existing directory.") 21 | } 22 | 23 | modelfilename 24 | } 25 | 26 | 27 | # data: path, matrix etc. 28 | # mpt: parsed MPT model structure 29 | readData <- function(data, 30 | mpt = NULL) { 31 | if (is.matrix(data) | is.data.frame(data)) { 32 | data <- as.data.frame(data) 33 | } else { 34 | data <- read.csv(data, header = TRUE, sep = ",") 35 | } 36 | if (any(is.na(data))) { 37 | stop("Missings in the data file!") 38 | } 39 | colnames(data) <- gsub(" ", "", colnames(data), fixed = TRUE) 40 | 41 | if (!missing(mpt) && !is.null(mpt)) { 42 | if (is.null(colnames(data)) || 43 | all(colnames(data) == paste0("V", 1:ncol(data)))) { 44 | nam <- paste(as.character(mpt$cat.names), collapse = ", ") 45 | warning( 46 | "No column names in 'data'. Default order of categories is assumed:\n", 47 | nam 48 | ) 49 | colnames(data) <- as.character(mpt$cat.names) 50 | } else { 51 | data <- data[, as.character(mpt$cat.names)] 52 | } 53 | } 54 | data 55 | } 56 | 57 | 58 | 59 | 60 | check.hyperprior <- function(par, thetaUnique, label = "parameter") { 61 | if (length(par) == length(thetaUnique) && !is.null(names(par))) { 62 | if (any(thetaUnique != sort(names(par)))) { 63 | stop( 64 | "Names of the hyperprior vector '", label, "' do not match model parameters.", 65 | "\n Use read.EQN(.., paramOrder=TRUE) to get the correct parameter labels." 66 | ) 67 | } 68 | par <- par[thetaUnique] 69 | } else if (length(par) == 1) { 70 | par <- rep(par, length(thetaUnique)) 71 | names(par) <- thetaUnique 72 | } 73 | 74 | par 75 | } 76 | -------------------------------------------------------------------------------- /R/fitSimpleMPT.R: -------------------------------------------------------------------------------- 1 | #' C++ Sampler for Standard (Nonhierarchical) MPT Models 2 | #' 3 | #' Fast Gibbs sampler in C++ that is tailored to the standard fixed-effects MPT 4 | #' model (i.e., fixed-effects, non-hierarchical MPT). Assumes independent 5 | #' parameters per person if a matrix of frequencies per person is supplied. 6 | #' 7 | #' @inheritParams betaMPT 8 | #' @inheritParams betaMPTcpp 9 | #' @param alpha first shape parameter(s) for the beta prior-distribution of the 10 | #' MPT parameters \eqn{\theta_s} (can be a named vector to use a different 11 | #' prior for each MPT parameter) 12 | #' @param beta second shape parameter(s) 13 | #' 14 | #' @details Beta distributions with fixed shape parameters \eqn{\alpha} and 15 | #' \eqn{\beta} are used. The default \eqn{\alpha=1} and \eqn{\beta=1} assumes 16 | #' uniform priors for all MPT parameters. 17 | #' @author Daniel Heck 18 | #' 19 | #' @examples 20 | #' \dontrun{ 21 | #' # fit nonhierarchical MPT model for aggregated data (see ?arnold2013): 22 | #' EQNfile <- system.file("MPTmodels/2htsm.eqn", package = "TreeBUGS") 23 | #' d.encoding <- subset(arnold2013, group == "encoding", select = -(1:4)) 24 | #' fit <- simpleMPT(EQNfile, colSums(d.encoding), 25 | #' restrictions = list("D1=D2=D3", "d1=d2", "a=g") 26 | #' ) 27 | #' # convergence 28 | #' plot(fit) 29 | #' summary(fit) 30 | #' } 31 | #' @importFrom parallel parLapply stopCluster detectCores 32 | #' @export 33 | simpleMPT <- function( 34 | eqnfile, 35 | data, 36 | restrictions, 37 | n.iter = 2000, 38 | n.burnin = 500, 39 | n.thin = 3, 40 | n.chains = 3, 41 | ppp = 0, 42 | alpha = 1, 43 | beta = 1, 44 | parEstFile, 45 | posteriorFile, 46 | cores = 1 47 | ) { 48 | hyperprior <- list(alpha = alpha, beta = beta) 49 | if (!is.character(data) && is.null(dim(data))) { 50 | data <- matrix(data, nrow = 1, dimnames = list(NULL, names(data))) 51 | } 52 | 53 | fittedModel <- fitModelCpp("simpleMPT", 54 | eqnfile = eqnfile, 55 | data = data, restrictions = restrictions, 56 | hyperprior = hyperprior, 57 | n.iter = n.iter, 58 | n.burnin = n.burnin, n.thin = n.thin, 59 | n.chains = n.chains, ppp = ppp, 60 | parEstFile = parEstFile, 61 | posteriorFile = posteriorFile, 62 | call = match.call(), 63 | cores = cores 64 | ) 65 | 66 | fittedModel 67 | } 68 | -------------------------------------------------------------------------------- /R/getSamples.R: -------------------------------------------------------------------------------- 1 | #' Get Posterior Samples from Fitted MPT Model 2 | #' 3 | #' Extracts MCMC posterior samples as an \code{coda::mcmc.list} and relabels the 4 | #' MCMC variables. 5 | #' 6 | #' @inheritParams getParam 7 | #' @inheritParams plotParam 8 | #' @param names whether and how to rename the variables in the MCMC output: 9 | #' \code{par} (internal parameter labels such as \code{mu[1]}), \code{label} 10 | #' (MPT label from EQN file such as \code{"d"}), or \code{par_name} 11 | #' (concatenation of both such as \code{"mu[1]_d"}). 12 | #' 13 | #' @importFrom coda varnames niter nvar nchain mcmc.list 14 | #' @examples 15 | #' \dontrun{ 16 | #' getSamples(fittedModel, "mu", select = c("d", "g")) 17 | #' } 18 | #' @export 19 | getSamples <- function( 20 | fittedModel, 21 | parameter = "mean", 22 | select = "all", 23 | names = "par_label" 24 | ) { 25 | parnames <- fittedModel$mptInfo$thetaUnique 26 | if (missing(select) || identical(select, "all")) { 27 | select <- parnames 28 | } else if (!all(select %in% parnames)) { 29 | stop( 30 | "Check arguments: Not all parameters in 'select' are included in the MPT model!\n", 31 | "Parameters are: ", paste(parnames, collapse = ", ") 32 | ) 33 | } 34 | 35 | S <- length(parnames) 36 | var <- "" 37 | 38 | idx <- match(select, parnames) 39 | # matches <- grep(parameter, varnames(fittedModel$runjags$mcmc), value = TRUE) 40 | if (S > 1L && parameter == "theta") { 41 | var <- paste0("[", outer(idx, seq_len(nrow(fittedModel$mptInfo$data)), FUN = "paste", sep = ","), "]") 42 | } else if (S > 1L || (parameter == "theta" && S == 1)) { 43 | var <- paste0("[", idx, "]") 44 | } else if (S > 1L && parameter == "rho") { 45 | var <- paste0("[", outer(idx, idx, FUN = "paste", sep = ","), "]") 46 | } 47 | 48 | 49 | # print(paste0(parameter, var)) 50 | mcmc <- fittedModel$runjags$mcmc[, paste0(parameter, var), drop = FALSE] 51 | 52 | if (parameter != "rho") { 53 | mcmc <- rename_mcmc(mcmc, names, select) 54 | } 55 | mcmc 56 | } 57 | 58 | rename_mcmc <- function(mcmc, names, parnames) { 59 | if (nvar(mcmc) == length(parnames)) { 60 | if (names == "par_label") { 61 | coda::varnames(mcmc) <- paste0(varnames(mcmc), "_", parnames) 62 | } else if (names == "label") { 63 | coda::varnames(mcmc) <- parnames 64 | } 65 | } 66 | mcmc 67 | } 68 | -------------------------------------------------------------------------------- /R/fitBetaMPTcpp.R: -------------------------------------------------------------------------------- 1 | #' C++ Sampler for Hierarchical Beta-MPT Model 2 | #' 3 | #' Fast Gibbs sampler in C++ that is tailored to the beta-MPT model. 4 | #' 5 | #' @inheritParams betaMPT 6 | #' @param shape shape parameter(s) of Gamma-hyperdistribution for the 7 | #' hierarchical beta-parameters \eqn{\alpha_s} and \eqn{\beta_s} (can be a 8 | #' named vector to provide different hyperpriors for each parameter) 9 | #' @param rate rate parameter(s) of Gamma-hyperdistribution 10 | #' @param cores number of CPUs to be used 11 | #' 12 | #' @author Daniel Heck 13 | #' @examples 14 | #' \dontrun{ 15 | #' # fit beta-MPT model for encoding condition (see ?arnold2013): 16 | #' EQNfile <- system.file("MPTmodels/2htsm.eqn", package = "TreeBUGS") 17 | #' d.encoding <- subset(arnold2013, group == "encoding", select = -(1:4)) 18 | #' fit <- betaMPTcpp(EQNfile, d.encoding, 19 | #' n.thin = 5, 20 | #' restrictions = list("D1=D2=D3", "d1=d2", "a=g") 21 | #' ) 22 | #' # convergence 23 | #' plot(fit, parameter = "mean", type = "default") 24 | #' summary(fit) 25 | #' } 26 | #' @importFrom parallel parLapply stopCluster detectCores 27 | #' @export 28 | betaMPTcpp <- function( 29 | eqnfile, 30 | data, 31 | restrictions, 32 | covData, 33 | corProbit = FALSE, 34 | n.iter = 20000, 35 | n.burnin = 2000, 36 | n.thin = 5, 37 | n.chains = 3, 38 | ppp = 0, 39 | shape = 1, 40 | rate = 0.1, 41 | parEstFile, 42 | posteriorFile, 43 | cores = 1 44 | ) { 45 | hyperprior <- list(shape = shape, rate = rate) 46 | 47 | fittedModel <- fitModelCpp("betaMPT", 48 | eqnfile = eqnfile, 49 | data = data, 50 | restrictions = restrictions, 51 | covData = covData, 52 | corProbit = corProbit, 53 | hyperprior = hyperprior, 54 | n.iter = n.iter, 55 | n.burnin = n.burnin, n.thin = n.thin, 56 | n.chains = n.chains, 57 | ppp = ppp, 58 | parEstFile = parEstFile, 59 | posteriorFile = posteriorFile, 60 | call = match.call(), 61 | cores = cores 62 | ) 63 | fittedModel 64 | } 65 | -------------------------------------------------------------------------------- /man/testHetChi.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/testHetChi.R 3 | \name{testHetChi} 4 | \alias{testHetChi} 5 | \title{Chi-Square Test of Heterogeneity} 6 | \usage{ 7 | testHetChi(freq, tree) 8 | } 9 | \arguments{ 10 | \item{freq}{matrix with observed frequencies (rows: persons/items; columns: 11 | categories). Can also be the path to a .csv file with frequencies 12 | (comma-separated; first line defines category labels)} 13 | 14 | \item{tree}{a vector defining which columns of x belong to separate 15 | multinomial distributions (i.e., MPT trees). For instance, if \code{x} has 16 | five categories from two MPT trees: \code{tree=c(1,1,2,2,2)} or 17 | \code{tree=c("t1","t1","t2","t2","t2")}} 18 | } 19 | \description{ 20 | Tests whether whether participants (items) are homogeneous under the 21 | assumption of item (participant) homogeneity. 22 | } 23 | \details{ 24 | If an item/person has zero frequencies on all categories in an MPT 25 | tree, these zeros are neglected when computing mean frequencies per column. 26 | As an example, consider a simple recognition test with a fixed assignments of 27 | words to the learn/test list. In such an experiment, all learned words will 28 | result in hits or misses (i.e., the MPT tree of old items), whereas new words 29 | are always false alarms/correct rejections and thus belong to the MPT tree of 30 | new items (this is not necessarily the case if words are assigned randomly). 31 | 32 | Note that the test assumes independence of observations and item homogeneity 33 | when testing participant heterogeneity. The latter assumption can be dropped 34 | when using a permutation test (\code{\link{testHetPerm}}). 35 | } 36 | \examples{ 37 | # some made up frequencies: 38 | freq <- matrix( 39 | c( 40 | 13, 16, 11, 13, 41 | 15, 21, 18, 13, 42 | 21, 14, 16, 17, 43 | 19, 20, 21, 18 44 | ), 45 | ncol = 4, byrow = TRUE 46 | ) 47 | # for a product-binomial distribution: 48 | # (categories 1 and 2 and categories 3 and 4 are binomials) 49 | testHetChi(freq, tree = c(1, 1, 2, 2)) 50 | # => no significant deviation from homogeneity (low power!) 51 | } 52 | \references{ 53 | Smith, J. B., & Batchelder, W. H. (2008). Assessing individual 54 | differences in categorical data. Psychonomic Bulletin & Review, 15, 55 | 713-731. \doi{10.3758/PBR.15.4.713} 56 | } 57 | \seealso{ 58 | \code{\link{testHetPerm}}, \code{\link{plotFreq}} 59 | } 60 | \author{ 61 | Daniel W. Heck 62 | } 63 | -------------------------------------------------------------------------------- /R/covCorrelationString.R: -------------------------------------------------------------------------------- 1 | # add model string that computes correlation of MPT model parameters with external covariate 2 | # does not change estimation of the model! 3 | 4 | covStringCorrelation <- function(covTable, corProbit = FALSE) { 5 | checkCorrelations <- any(covTable$predType != "c") 6 | if (checkCorrelations) { 7 | stop("To compute correlations, only continuous covariates are allowed.") 8 | } 9 | 10 | modelString <- "\n## Covariate Handling: Correlations ##\n" 11 | 12 | if (!is.null(covTable)) { 13 | # use probit-transformed values (e.g., in traitMPT model) 14 | corProbitString <- ifelse(corProbit, "theta.probit", "theta") 15 | 16 | pars <- unique(covTable$Parameter) 17 | modelString <- paste0( 18 | modelString, 19 | "for(i in 1:S){", 20 | ifelse(corProbit, 21 | "\n for(n in 1:subjs){\n theta.probit[i,n] <- probit(theta[i,n])\n }", 22 | "" 23 | ), 24 | "\nthetaSD[i] <- sd(", corProbitString, 25 | "[i,]) 26 | } 27 | " 28 | ) 29 | cnt <- 0 30 | for (pp in 1:length(pars)) { 31 | sel <- covTable$Parameter == pars[pp] 32 | thetaIdx <- covTable$theta[sel][1] 33 | covs <- covTable$Covariate[sel] 34 | for (cc in 1:length(covs)) { 35 | covIdx <- covTable$covIdx[sel][cc] 36 | 37 | ### requires commputation of correlation using only sum / sd 38 | # (par-mean(par))*(cov-mean(cov))/(sd(par) * sd(cov)) 39 | 40 | modelString <- paste0( 41 | modelString, 42 | "cor_", pars[pp], "_", covs[cc], 43 | # " <- mean( (theta[",thetaIdx, ",]-mean(theta[",thetaIdx, 44 | " <- mean( (", corProbitString, "[", thetaIdx, ",]- mean(", 45 | corProbitString, "[", thetaIdx, 46 | ",]))*(covData[,", covIdx, "]-mean(covData[,", covIdx, 47 | "])) )/covSD[", covIdx, 48 | "] / thetaSD[", thetaIdx, "]\n" 49 | ) 50 | # nice, not supported: cor(theta[",thetaIdx, ",], covData[,",covIdx, "]) 51 | covTable$covPar[cnt <- cnt + 1] <- paste0("cor_", pars[pp], "_", covs[cc]) 52 | } 53 | } 54 | } 55 | 56 | 57 | # lines in JAGS: 58 | # additionally monitored variable: covPars <- paste0("cor_", sapply(covList, function(ll, ll$Par) )) 59 | ################### ################### ################### 60 | 61 | return(list( 62 | modelString = modelString, 63 | covPars = covTable$covPar 64 | )) 65 | } 66 | -------------------------------------------------------------------------------- /R/covDataRead.R: -------------------------------------------------------------------------------- 1 | 2 | # read, check and mean-center covData 3 | covDataRead <- function(covData, N, binaryToNumeric = FALSE) { 4 | if (!is.null(covData)) { 5 | # list / path to file 6 | if (is.character(covData)) { 7 | covData <- read.csv(covData, header = T, sep = ",", strip.white = T) 8 | } 9 | try(covData <- as.data.frame(covData)) 10 | 11 | 12 | if (nrow(covData) != N) { 13 | stop("Number of individuals in 'data' and 'covData' differs!") 14 | } 15 | 16 | if (is.null(colnames(covData))) { 17 | stop("Check names of covariates in covData!") 18 | } 19 | 20 | if (binaryToNumeric) { 21 | for (k in 1:ncol(covData)) { 22 | if (inherits(covData[, k], c("factor", "ordered", "character"))) { 23 | if (length(unique(covData[, k])) == 2) { 24 | covData[, k] <- as.numeric(as.factor(covData[, k])) 25 | } 26 | } 27 | } 28 | } 29 | } 30 | covData 31 | } 32 | 33 | 34 | 35 | # get default values for predType 36 | predTypeDefault <- function(covData, predType = NULL) { 37 | if (!is.null(covData)) { 38 | # default: continuous / random covariates 39 | if (missing(predType) || is.null(predType)) { 40 | cov.class <- sapply(covData, class) 41 | predType <- ifelse(cov.class %in% c("character", "factor"), "f", 42 | ifelse(cov.class %in% c("integer", "numeric", "matrix"), "c", "") 43 | ) 44 | } 45 | for (cc in 1:length(predType)) { 46 | if (!all(predType %in% c("f", "c", "r"))) { 47 | stop( 48 | "Check definition of predType: should be a vector of the same length\n ", 49 | "as there are columns in covData. Possible values are:\n", 50 | " 'c' (continuous variable),", 51 | "\n 'f' (fixed effects factor; only traitMPT), or", 52 | "\n 'r' (random effects factor; only traitMPT)." 53 | ) 54 | } 55 | } 56 | } else { 57 | predType <- NULL 58 | } 59 | predType 60 | } 61 | 62 | 63 | # mean-centered variables as default (does not matter much for correlational analyses) 64 | covDataCenter <- function(covData, predType) { 65 | if (!is.null(covData)) { 66 | for (i in 1:ncol(covData)) { 67 | if (predType[i] == "c") { 68 | scaled <- scale(covData[, i], center = TRUE, scale = FALSE) # centering of continuous variables 69 | if (any(scaled != covData[, i])) { 70 | covData[, i] <- c(scaled) 71 | } 72 | } 73 | } 74 | } 75 | 76 | covData 77 | } 78 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: TreeBUGS 2 | Version: 1.5.3 3 | Date: 2025-09-23 4 | Title: Hierarchical Multinomial Processing Tree Modeling 5 | Authors@R: c(person("Daniel W.", "Heck", role=c("aut","cre"), 6 | email="daniel.heck@uni-marburg.de", 7 | comment = c(ORCID = "0000-0002-6302-9252")), 8 | person("Nina R.", "Arnold", role = c("aut","dtc"), 9 | email="arnold@uni-mannheim.de"), 10 | person("Denis", "Arnold", role = c("aut"), 11 | email="denis.arnold@uni-tuebingen.de"), 12 | person("Alexander", "Ly", role = c("ctb"), 13 | email="a.ly@uva.nl"), 14 | person("Marius", "Barth", role = c("ctb"), 15 | email="marius.barth@uni-koeln.de", 16 | comment = c(ORCID = "0000-0002-3421-6665"))) 17 | Maintainer: Daniel W. Heck 18 | Depends: 19 | R (>= 4.0.0) 20 | Imports: 21 | Rcpp (>= 1.0.0), 22 | stats, 23 | parallel, 24 | graphics, 25 | utils, 26 | grDevices, 27 | MASS, 28 | runjags, 29 | rjags, 30 | coda, 31 | hypergeo, 32 | logspline 33 | Suggests: 34 | knitr, 35 | rmarkdown, 36 | testthat, 37 | R.rsp 38 | LinkingTo: 39 | Rcpp, 40 | RcppArmadillo 41 | VignetteBuilder: 42 | knitr, 43 | R.rsp 44 | NeedsCompilation: yes 45 | SystemRequirements: JAGS (https://mcmc-jags.sourceforge.io/) 46 | Description: User-friendly analysis of hierarchical multinomial processing tree (MPT) 47 | models that are often used in cognitive psychology. Implements the latent-trait 48 | MPT approach (Klauer, 2010) and the beta-MPT 49 | approach (Smith & Batchelder, 2010) to model 50 | heterogeneity of participants. MPT models are conveniently specified by an 51 | .eqn-file as used by other MPT software and data are provided by a .csv-file 52 | or directly in R. Models are either fitted by calling JAGS or by an MPT-tailored 53 | Gibbs sampler in C++ (only for nonhierarchical and beta MPT models). Provides 54 | tests of heterogeneity and MPT-tailored summaries and plotting functions. 55 | A detailed documentation is available in Heck, Arnold, & Arnold (2018) 56 | and a tutorial on MPT modeling can be found 57 | in Schmidt, Erdfelder, & Heck (2023) . 58 | License: GPL-3 59 | Encoding: UTF-8 60 | URL: https://github.com/danheck/TreeBUGS 61 | RoxygenNote: 7.3.3 62 | LazyData: TRUE 63 | -------------------------------------------------------------------------------- /man/testHetPerm.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/testHetPerm.R 3 | \name{testHetPerm} 4 | \alias{testHetPerm} 5 | \title{Permutation Test of Heterogeneity} 6 | \usage{ 7 | testHetPerm(data, tree, source = "person", rep = 1000, nCPU = 4) 8 | } 9 | \arguments{ 10 | \item{data}{matrix or data frame with three columns: person code/index, item 11 | label, response category. Can also be the path to a .csv file with 12 | frequencies (comma-separated; first line defines category labels)} 13 | 14 | \item{tree}{a list that defines which categories belong to the same 15 | multinomial distribution (i.e., the the same MPT tree). For instance: 16 | \code{tree = list(tree.old = c("hit","cr"), tree.new = c("fa","miss"))}. 17 | Category labels must match the values of the third column of \code{data}} 18 | 19 | \item{source}{whether to test for \code{"person"} or \code{"item"} 20 | homogeneity} 21 | 22 | \item{rep}{number of permutations to be sampled} 23 | 24 | \item{nCPU}{number of CPUs used for parallel Monte Carlo sampling of 25 | permutations} 26 | } 27 | \description{ 28 | Tests whether whether participants (items) are homogeneous without assuming 29 | item (participant) homogeneity. 30 | } 31 | \details{ 32 | If an item/person has zero frequencies on all categories in an MPT 33 | tree, these zeros are neglected when computing mean frequencies per column. 34 | As an example, consider a simple recognition test with a fixed assignments of 35 | words to the learn/test list. In such an experiment, all learned words will 36 | result in hits or misses (i.e., the MPT tree of old items), whereas new words 37 | are always false alarms/correct rejections and thus belong to the MPT tree of 38 | new items (this is not necessarily the case if words are assigned randomly). 39 | 40 | Note that the test does still assume independence of observations. However, 41 | it does not require item homogeneity when testing participant heterogeneity 42 | (in contrast to the chi-square test: \code{\link{testHetChi}}). 43 | } 44 | \examples{ 45 | # generate homogeneous data 46 | # (N=15 participants, M=30 items) 47 | data <- data.frame( 48 | id = rep(1:15, each = 30), 49 | item = rep(1:30, 15) 50 | ) 51 | data$cat <- sample(c("h", "cr", "m", "fa"), 15 * 30, 52 | replace = TRUE, 53 | prob = c(.7, .3, .4, .6) 54 | ) 55 | head(data) 56 | tree <- list( 57 | old = c("h", "m"), 58 | new = c("fa", "cr") 59 | ) 60 | 61 | # test participant homogeneity: 62 | tmp <- testHetPerm(data, tree, rep = 200, nCPU = 1) 63 | tmp[2:3] 64 | } 65 | \references{ 66 | Smith, J. B., & Batchelder, W. H. (2008). Assessing individual 67 | differences in categorical data. Psychonomic Bulletin & Review, 15, 68 | 713-731. \doi{10.3758/PBR.15.4.713} 69 | } 70 | \seealso{ 71 | \code{\link{testHetChi}}, \code{\link{plotFreq}} 72 | } 73 | \author{ 74 | Daniel W. Heck 75 | } 76 | -------------------------------------------------------------------------------- /vignettes/TreeBUGS_1_intro.R: -------------------------------------------------------------------------------- 1 | ## ---- eval=F------------------------------------------------------------------ 2 | # readEQN( 3 | # file = "pathToFile.eqn", # relative or absolute path 4 | # restrictions = list("Dn=Do"), # equality constraints 5 | # paramOrder = TRUE 6 | # ) # show parameter order 7 | 8 | ## ---- eval=FALSE-------------------------------------------------------------- 9 | # restrictions <- list("Dn=Do", "g=0.5") 10 | 11 | ## ---- eval=FALSE-------------------------------------------------------------- 12 | # # load the package: 13 | # library(TreeBUGS) 14 | # 15 | # # fit the model: 16 | # fitHierarchicalMPT <- betaMPT( 17 | # eqnfile = "2htm.txt", # .eqn file 18 | # data = "data_ind.csv", # individual data 19 | # restrictions = list("Dn=Do"), # parameter restrictions (or path to file) 20 | # 21 | # ### optional MCMC input: 22 | # n.iter = 20000, # number of iterations 23 | # n.burnin = 5000, # number of burnin samples that are removed 24 | # n.thin = 5, # thinning rate of removing samples 25 | # n.chains = 3 # number of MCMC chains (run in parallel) 26 | # ) 27 | 28 | ## ---- eval=FALSE-------------------------------------------------------------- 29 | # # Default: Traceplot and density 30 | # plot(fitHierarchicalMPT, # fitted model 31 | # parameter = "mean" # which parameter to plot 32 | # ) 33 | # # further arguments are passed to ?plot.mcmc.list 34 | # 35 | # # Auto-correlation plots: 36 | # plot(fitHierarchicalMPT, parameter = "mean", type = "acf") 37 | # 38 | # # Gelman-Rubin plots: 39 | # plot(fitHierarchicalMPT, parameter = "mean", type = "gelman") 40 | 41 | ## ---- eval=FALSE-------------------------------------------------------------- 42 | # summary(fitHierarchicalMPT) 43 | 44 | ## ---- eval=FALSE-------------------------------------------------------------- 45 | # plotParam(fitHierarchicalMPT, # estimated parameters 46 | # includeIndividual = TRUE # whether to plot individual estimates 47 | # ) 48 | # plotDistribution(fitHierarchicalMPT) # estimated hierarchical parameter distribution 49 | # plotFit(fitHierarchicalMPT) # observed vs. predicted mean frequencies 50 | # plotFit(fitHierarchicalMPT, stat = "cov") # observed vs. predicted covariance 51 | # plotFreq(fitHierarchicalMPT) # individual and mean raw frequencies per tree 52 | # plotPriorPost(fitHierarchicalMPT) # comparison of prior/posterior (group level parameters) 53 | 54 | ## ---- eval=FALSE-------------------------------------------------------------- 55 | # # matrix for further use within R: 56 | # tt <- getParam(fitHierarchicalMPT, 57 | # parameter = "theta", 58 | # stat = "mean" 59 | # ) 60 | # tt 61 | # 62 | # # save complete summary of individual estimates to file: 63 | # getParam(fitHierarchicalMPT, 64 | # parameter = "theta", 65 | # stat = "summary", file = "parameter.csv" 66 | # ) 67 | 68 | -------------------------------------------------------------------------------- /R/arnold2013.R: -------------------------------------------------------------------------------- 1 | #' Data of a Source-Monitoring Experiment 2 | #' 3 | #' Dataset of a source-monitoring experiment by Arnold, Bayen, Kuhlmann, and 4 | #' Vaterrodt (2013) using a 2 (Source; within) x 3 (Expectancy; within) x 2 5 | #' (Time of Schema Activation; between) mixed factorial design. 6 | #' 7 | #' @details Eighty-four participants had to learn statements that were either 8 | #' presented by a doctor or a lawyer (Source) and were either typical for 9 | #' doctors, typical for lawyers, or neutral (Expectancy). These two types of 10 | #' statements were completely crossed in a balanced way, resulting in a true 11 | #' contingency of zero between Source and Expectancy. Whereas the profession 12 | #' schemata were activated at the time of encoding for half of the participants 13 | #' (encoding condition), the other half were told about the profession of the 14 | #' sources just before the test (retrieval condition). After the test, 15 | #' participants were asked to judge the contingency between item type and source 16 | #' (perceived contingency pc). 17 | #' 18 | #' @format A data frame 13 variables: 19 | #' \describe{ 20 | #' \item{\code{subject}}{Participant code} 21 | #' \item{\code{age}}{Age in years} 22 | #' \item{\code{group}}{ Between-subject factor "Time of Schema Activation": 23 | #' Retrieval vs. encoding condition} 24 | #' \item{\code{pc}}{perceived contingency} 25 | #' \item{\code{EE}}{Frequency of "Source E" responses to items from source "E"} 26 | #' \item{\code{EU}}{Frequency of "Source U" responses to items from source "E"} 27 | #' \item{\code{EN}}{Frequency of "New" responses to items from source "E"} 28 | #' \item{\code{UE}}{Frequency of "Source E" responses to items from source "E"} 29 | #' \item{\code{UU}}{Frequency of "Source U" responses to items from source "E"} 30 | #' \item{\code{UN}}{Frequency of "New" responses to items from source "E"} 31 | #' \item{\code{NE}}{Frequency of "Source E" responses to new items} 32 | #' \item{\code{NU}}{Frequency of "Source U" responses to new items} 33 | #' \item{\code{NN}}{Frequency of "New" responses to new items} 34 | #' } 35 | #' @references Arnold, N. R., Bayen, U. J., Kuhlmann, B. G., & Vaterrodt, B. 36 | #' (2013). Hierarchical modeling of contingency-based source monitoring: A 37 | #' test of the probability-matching account. Psychonomic Bulletin & Review, 38 | #' 20, 326-333. 39 | #' 40 | #' @examples 41 | #' head(arnold2013) 42 | #' 43 | #' \dontrun{ 44 | #' # fit hierarchical MPT model for encoding condition: 45 | #' EQNfile <- system.file("MPTmodels/2htsm.eqn", package = "TreeBUGS") 46 | #' d.encoding <- subset(arnold2013, group == "encoding", select = -(1:4)) 47 | #' fit <- betaMPTcpp(EQNfile, d.encoding, 48 | #' n.thin = 5, 49 | #' restrictions = list("D1=D2=D3", "d1=d2", "a=g") 50 | #' ) 51 | #' # convergence 52 | #' plot(fit, parameter = "mean", type = "default") 53 | #' summary(fit) 54 | #' } 55 | "arnold2013" 56 | -------------------------------------------------------------------------------- /R/summarizeMCMC.R: -------------------------------------------------------------------------------- 1 | #' MCMC Summary 2 | #' 3 | #' TreeBUGS-specific MCMC summary for \code{mcmc.list}-objects. 4 | #' 5 | #' @param mcmc a \code{\link[coda]{mcmc.list}} object 6 | #' @param batchSize size of batches of parameters used to reduce memory load 7 | #' when computing posterior summary statistics (including Rhat and effective 8 | #' sample size). 9 | #' @param probs quantile probabilities used to compute credibility intervals 10 | #' 11 | #' @importFrom coda varnames 12 | #' @export 13 | summarizeMCMC <- function( 14 | mcmc, 15 | batchSize = 50, 16 | probs = c(.025, .50, .975) 17 | ) { 18 | if (inherits(mcmc, c("traitMPT", "betaMPT", "simpleMPT"))) { 19 | mcmc <- mcmc$runjags$mcmc 20 | } 21 | if (inherits(mcmc, "runjags")) { 22 | mcmc <- mcmc$mcmc 23 | } 24 | 25 | # initialize matrix with summary statistics 26 | vnames <- varnames(mcmc) 27 | npar <- length(vnames) 28 | snames <- c( 29 | "Mean", "SD", names(quantile(1, probs)), 30 | "Time-series SE", "n.eff", "Rhat", "R_95%" 31 | ) 32 | summTab <- matrix(NA, npar, length(snames), 33 | dimnames = list(vnames, snames) 34 | ) 35 | 36 | # summarize in batches (to avoid RAM issues) 37 | n_batches <- (npar %/% batchSize) + 1 38 | for (ii in seq(n_batches)) { 39 | if (n_batches == 1) { 40 | idx <- seq(npar) 41 | } else if (ii < n_batches) { 42 | idx <- (ii - 1) * batchSize + 1:batchSize # complete batches 43 | } else if ((ii - 1) * batchSize + 1 <= npar) { 44 | idx <- ((ii - 1) * batchSize + 1):npar 45 | } else { 46 | break() 47 | } 48 | 49 | try({ 50 | mcmc.mat <- do.call("rbind", mcmc[, idx, drop = FALSE]) 51 | summTab[idx, "Mean"] <- apply(mcmc.mat, 2, mean, na.rm = TRUE) 52 | summTab[idx, "SD"] <- apply(mcmc.mat, 2, sd, na.rm = TRUE) 53 | summTab[idx, 2 + seq(length(probs))] <- 54 | t(apply(mcmc.mat, 2, quantile, probs, na.rm = TRUE)) 55 | rm(mcmc.mat) 56 | gc(verbose = FALSE) 57 | }) 58 | 59 | try( 60 | { 61 | summTab[idx, "n.eff"] <- round(effectiveSize(mcmc[, idx])) 62 | summTab[idx, "Time-series SE"] <- summTab[idx, "SD"] / sqrt(summTab[idx, "n.eff"]) 63 | }, 64 | silent = TRUE 65 | ) 66 | 67 | try(summTab[idx, c("Rhat", "R_95%")] <- 68 | gelman.diag(mcmc[, idx], multivariate = FALSE)[[1]]) 69 | } 70 | 71 | if (all(is.na(summTab))) { 72 | cat("summarizeMCMC: posterior summary in baches failed. trying coda::summary instead.\n") 73 | try({ 74 | summ <- summary(mcmc) 75 | summTab <- cbind(summ[[1]][, c("Mean", "SD")], 76 | summ[[2]], 77 | "Time-series SE" = summ[[1]][, "Time-series SE"], 78 | "n.eff" = (summ[[1]][, "SD"] / summ[[1]][, "Time-series SE"])^2, 79 | "Rhat" = NA, "R_95%" = NA 80 | ) 81 | ###### MCMC effective N: 82 | # "Time-series SE" = "SD" / sqrt("Effective N") 83 | # "Effective N" = ("SD" / "Time-series SE")^2 84 | }) 85 | } 86 | 87 | summTab 88 | } 89 | -------------------------------------------------------------------------------- /man/arnold2013.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/arnold2013.R 3 | \docType{data} 4 | \name{arnold2013} 5 | \alias{arnold2013} 6 | \title{Data of a Source-Monitoring Experiment} 7 | \format{ 8 | A data frame 13 variables: 9 | \describe{ 10 | \item{\code{subject}}{Participant code} 11 | \item{\code{age}}{Age in years} 12 | \item{\code{group}}{ Between-subject factor "Time of Schema Activation": 13 | Retrieval vs. encoding condition} 14 | \item{\code{pc}}{perceived contingency} 15 | \item{\code{EE}}{Frequency of "Source E" responses to items from source "E"} 16 | \item{\code{EU}}{Frequency of "Source U" responses to items from source "E"} 17 | \item{\code{EN}}{Frequency of "New" responses to items from source "E"} 18 | \item{\code{UE}}{Frequency of "Source E" responses to items from source "E"} 19 | \item{\code{UU}}{Frequency of "Source U" responses to items from source "E"} 20 | \item{\code{UN}}{Frequency of "New" responses to items from source "E"} 21 | \item{\code{NE}}{Frequency of "Source E" responses to new items} 22 | \item{\code{NU}}{Frequency of "Source U" responses to new items} 23 | \item{\code{NN}}{Frequency of "New" responses to new items} 24 | } 25 | } 26 | \usage{ 27 | arnold2013 28 | } 29 | \description{ 30 | Dataset of a source-monitoring experiment by Arnold, Bayen, Kuhlmann, and 31 | Vaterrodt (2013) using a 2 (Source; within) x 3 (Expectancy; within) x 2 32 | (Time of Schema Activation; between) mixed factorial design. 33 | } 34 | \details{ 35 | Eighty-four participants had to learn statements that were either 36 | presented by a doctor or a lawyer (Source) and were either typical for 37 | doctors, typical for lawyers, or neutral (Expectancy). These two types of 38 | statements were completely crossed in a balanced way, resulting in a true 39 | contingency of zero between Source and Expectancy. Whereas the profession 40 | schemata were activated at the time of encoding for half of the participants 41 | (encoding condition), the other half were told about the profession of the 42 | sources just before the test (retrieval condition). After the test, 43 | participants were asked to judge the contingency between item type and source 44 | (perceived contingency pc). 45 | } 46 | \examples{ 47 | head(arnold2013) 48 | 49 | \dontrun{ 50 | # fit hierarchical MPT model for encoding condition: 51 | EQNfile <- system.file("MPTmodels/2htsm.eqn", package = "TreeBUGS") 52 | d.encoding <- subset(arnold2013, group == "encoding", select = -(1:4)) 53 | fit <- betaMPTcpp(EQNfile, d.encoding, 54 | n.thin = 5, 55 | restrictions = list("D1=D2=D3", "d1=d2", "a=g") 56 | ) 57 | # convergence 58 | plot(fit, parameter = "mean", type = "default") 59 | summary(fit) 60 | } 61 | } 62 | \references{ 63 | Arnold, N. R., Bayen, U. J., Kuhlmann, B. G., & Vaterrodt, B. 64 | (2013). Hierarchical modeling of contingency-based source monitoring: A 65 | test of the probability-matching account. Psychonomic Bulletin & Review, 66 | 20, 326-333. 67 | } 68 | \keyword{datasets} 69 | -------------------------------------------------------------------------------- /R/input_functions.R: -------------------------------------------------------------------------------- 1 | # #' Unique branches for each Tree with the same answer and sum the corresponing formulas 2 | # #' 3 | # #' @param Tree Data returned from readEQN() 4 | # #' @author Nina R. Arnold, Denis Arnold 5 | # #' @export 6 | mergeBranches <- function(Tree) { # OLD ,DataNames){ # Unique branches for each Tree with one answer and sum the corresponing formulas 7 | 8 | treeNames <- sort(unique(Tree$Tree)) 9 | catNames <- as.list(by(Tree$Category, Tree$Tree, function(xx) sort(unique(xx)))) 10 | names(catNames) <- treeNames 11 | 12 | NewTree <- data.frame( 13 | Tree = rep(treeNames, sapply(catNames, length)), 14 | Category = as.character(unlist(catNames)), 15 | Equation = "...", stringsAsFactors = FALSE 16 | ) 17 | for (tt in 1:length(treeNames)) { 18 | for (cc in 1:length(catNames[[tt]])) { 19 | selTree <- Tree$Tree == treeNames[tt] & Tree$Category == catNames[[tt]][cc] 20 | selNewTree <- NewTree$Tree == treeNames[tt] & NewTree$Category == catNames[[tt]][cc] 21 | NewTree$Equation[selNewTree] <- paste(Tree[selTree, ]$Equation, collapse = "+") 22 | } 23 | } 24 | 25 | return(NewTree) 26 | } 27 | 28 | 29 | 30 | # #' Extract all parameter from the formulas of a given model 31 | # #' 32 | # #' @param TreeData Data returned from readEQN() 33 | # #' @author Nina R. Arnold, Denis Arnold 34 | # #' @export 35 | getParameter <- function(TreeData) { 36 | Parameter <- unique(unlist(strsplit(TreeData$Equation, 37 | split = "\\*|\\(|\\)|\\-|\\+" 38 | ))) 39 | r <- c( 40 | which(nchar(Parameter) == 0), 41 | grep("^[0-9]+$|^[0-9]+\\.[0-9]+", Parameter) 42 | ) 43 | Parameter <- Parameter[-r] 44 | 45 | suppressWarnings(par.free <- is.na(as.numeric(Parameter))) 46 | Parameter <- Parameter[par.free] 47 | 48 | # Parameter=c(sort(Parameter[grepl("[A-Z]",Parameter)]), 49 | # sort(Parameter[!grepl("[A-Z]",Parameter)])) 50 | # returns errors if model does not contain uppercase parameters 51 | 52 | return(sort(Parameter)) 53 | } 54 | 55 | 56 | # #' Read the subject data from file 57 | # #' 58 | # #' @param data the data as data.frame 59 | # #' @param Category is the unique of the $Category from TreeData which is $Category after mergeBrachnes() 60 | # #' @author Nina R. Arnold, Denis Arnold 61 | # #' @export 62 | readSubjectData <- function(data, Category) { 63 | sel <- Category %in% names(data) 64 | sel2 <- names(data) %in% Category 65 | if (sum(sel) != length(Category)) { 66 | if (dim(data)[2] != length(Category)) { 67 | stop("Number of categories (", length(Category), ") in EQN differs from number of columns in data/csv file (", dim(data)[2], ").") 68 | } else { 69 | stop( 70 | "The following category names are mismatching:\n", 71 | " EQN file: ", 72 | paste(paste0("'", Category[!sel], "'"), collapse = "; "), 73 | "\n data column names: ", 74 | paste(paste0("'", names(data)[!sel2], "'"), collapse = "; ") 75 | ) 76 | } 77 | } 78 | 79 | data <- data[, Category, drop = FALSE] # order data columns according to Tree category label order 80 | 81 | return(data) 82 | } 83 | -------------------------------------------------------------------------------- /man/BayesFactorSlope.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/BFslope.R 3 | \name{BayesFactorSlope} 4 | \alias{BayesFactorSlope} 5 | \title{Bayes Factor for Slope Parameters in Latent-Trait MPT} 6 | \usage{ 7 | BayesFactorSlope( 8 | fittedModel, 9 | parameter, 10 | direction = "!=", 11 | approx = "normal", 12 | plot = TRUE, 13 | ... 14 | ) 15 | } 16 | \arguments{ 17 | \item{fittedModel}{a fitted latent-trait model fitted with 18 | \code{\link{traitMPT}} with predictor variables that have been defined via 19 | \code{predStructure}.} 20 | 21 | \item{parameter}{name of the slope parameter (e.g., 22 | \code{"slope_d_covariate"}).} 23 | 24 | \item{direction}{alternative hypothesis: whether slope is smaller or larger 25 | than zero (\code{"<"} or \code{">"}) or unequal to zero (\code{"!="}).} 26 | 27 | \item{approx}{how to approximate the posterior density of the slope parameter 28 | at zero: \code{approx="normal"} uses a normal approximation to all samples 29 | and \code{approx="logspline"} uses a nonparametric density estimate of the 30 | package \link[logspline]{logspline}. Usually, both methods provide similar 31 | results.} 32 | 33 | \item{plot}{if \code{TRUE}, the prior and posterior densities and the ratio 34 | at slope=0 are plotted.} 35 | 36 | \item{...}{further arguments passed to \code{\link[logspline]{logspline}}, 37 | which is used to approximate the density of the posterior distribution.} 38 | } 39 | \description{ 40 | Uses the Savage-Dickey method to compute the Bayes factor that the slope 41 | parameter of a continuous covariate in \code{\link{traitMPT}} is zero vs. 42 | positive/negative/unequal to zero. 43 | } 44 | \details{ 45 | The Bayes factor is computed with the Savage-Dickey method, which is 46 | defined as the ratio of the density of the posterior and the density of the 47 | prior evaluated at \code{slope=0} (Heck, 2019). Note that this method cannot 48 | be used with default JZS priors (\code{IVprec="dgamma(.5,.5)"}) if more than 49 | one predictor is added for an MPT parameter. As a remedy, a g-prior (normal 50 | distribution) can be used on the slopes by setting the hyperprior parameter 51 | \eqn{g} to a fixed constant when fitting the model: \code{traitMPT(..., 52 | IVprec = 1)} (see Heck, 2019). 53 | } 54 | \examples{ 55 | \dontrun{ 56 | # latent-trait MPT model for the encoding condition (see ?arnold2013): 57 | EQNfile <- system.file("MPTmodels/2htsm.eqn", package = "TreeBUGS") 58 | d.enc <- subset(arnold2013, group == "encoding") 59 | 60 | fit <- traitMPT(EQNfile, 61 | data = d.enc[, -(1:4)], n.thin = 5, 62 | restrictions = list("D1=D2=D3", "d1=d2", "a=g"), 63 | covData = d.enc[, c("age", "pc")], 64 | predStructure = list("D1 ; age") 65 | ) 66 | plot(fit, parameter = "slope", type = "default") 67 | summary(fit) 68 | 69 | BayesFactorSlope(fit, "slope_D1_age", direction = "<") 70 | } 71 | } 72 | \references{ 73 | Heck, D. W. (2019). A caveat on the Savage-Dickey density ratio: 74 | The case of computing Bayes factors for regression parameters. \emph{British 75 | Journal of Mathematical and Statistical Psychology, 72}, 316–333. 76 | \doi{10.1111/bmsp.12150} 77 | } 78 | -------------------------------------------------------------------------------- /man/TreeBUGS-package.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/TreeBUGS-package.R 3 | \docType{package} 4 | \name{TreeBUGS-package} 5 | \alias{TreeBUGS} 6 | \alias{TreeBUGS-package} 7 | \title{TreeBUGS: Hierarchical Multinomial Processing Tree Modeling} 8 | \description{ 9 | { 10 | \if{html}{\figure{TreeBUGS.png}{options: width='120' alt='logo' style='float: right'}} 11 | \if{latex}{\figure{TreeBUGS.png}{options: width=0.5in}} 12 | 13 | Uses standard MPT files in the .eqn-format (Moshagen, 2010) to fit 14 | hierarchical Bayesian MPT models. Note that the software JAGS is required 15 | (\url{https://mcmc-jags.sourceforge.io/}). } 16 | 17 | 18 | The core functions either fit a Beta-MPT model (\code{\link{betaMPT}}; Smith 19 | & Batchelder, 2010) or a latent-trait MPT model (\code{\link{traitMPT}}; 20 | Klauer, 2010). A fitted model can be inspected using convenient summary and 21 | plot functions tailored to hierarchical MPT models. 22 | 23 | Detailed explanations and examples can be found in the package vignette, 24 | accessible via \code{vignette("TreeBUGS")} 25 | } 26 | \section{Citation}{ 27 | 28 | 29 | If you use TreeBUGS, please cite the software as follows: 30 | 31 | Heck, D. W., Arnold, N. R., & Arnold, D. (2018). 32 | TreeBUGS: An R package for hierarchical multinomial-processing-tree modeling. 33 | \emph{Behavior Research Methods, 50}, 264–284. 34 | \doi{10.3758/s13428-017-0869-7} 35 | } 36 | 37 | \section{Tutorial}{ 38 | 39 | 40 | For a tutorial on MPT modeling (including hierarchical modeling in TreeBUGS), see: 41 | 42 | Schmidt, O., Erdfelder, E., & Heck, D. W. (2023). 43 | How to develop, test, and extend multinomial processing tree models: A tutorial. 44 | \emph{Psychological Methods}. 45 | \doi{10.1037/met0000561}. 46 | (Preprint: \url{https://osf.io/preprints/psyarxiv/gh8md/}) 47 | } 48 | 49 | \references{ 50 | Klauer, K. C. (2010). Hierarchical multinomial processing tree models: 51 | A latent-trait approach. 52 | \emph{Psychometrika, 75}, 70-98. 53 | \doi{10.1007/s11336-009-9141-0} 54 | 55 | Matzke, D., Dolan, C. V., Batchelder, W. H., & Wagenmakers, E.-J. (2015). 56 | Bayesian estimation of multinomial processing tree models with heterogeneity 57 | in participants and items. 58 | \emph{Psychometrika, 80}, 205-235. 59 | \doi{10.1007/s11336-013-9374-9} 60 | 61 | Moshagen, M. (2010). 62 | multiTree: A computer program for the analysis of multinomial processing 63 | tree models. 64 | \emph{Behavior Research Methods, 42}, 42-54. 65 | \doi{10.3758/BRM.42.1.42} 66 | 67 | Smith, J. B., & Batchelder, W. H. (2008). 68 | Assessing individual differences in categorical data. 69 | \emph{Psychonomic Bulletin & Review, 15}, 713-731. 70 | \doi{10.3758/PBR.15.4.713} 71 | 72 | Smith, J. B., & Batchelder, W. H. (2010). 73 | Beta-MPT: Multinomial processing tree models for addressing 74 | individual differences. 75 | \emph{Journal of Mathematical Psychology, 54}, 167-183. 76 | \doi{10.1016/j.jmp.2009.06.007} 77 | } 78 | \seealso{ 79 | Useful links: 80 | \itemize{ 81 | \item \url{https://github.com/danheck/TreeBUGS} 82 | } 83 | 84 | } 85 | \author{ 86 | Daniel W. Heck, Denis Arnold, & Nina Arnold 87 | } 88 | -------------------------------------------------------------------------------- /R/extendMPT.R: -------------------------------------------------------------------------------- 1 | #' Extend MCMC Sampling for MPT Model 2 | #' 3 | #' Adds more MCMC samples to the fitted MPT model. 4 | #' 5 | #' @param fittedModel a fitted \code{\link{traitMPT}} or \code{\link{betaMPT}} 6 | #' @inheritParams betaMPT 7 | #' @param ... further arguments passed to \code{extend.jags} (see arguments 8 | #' listed in: \link[runjags]{run.jags}). 9 | #' 10 | #' When drawing more samples, JAGS requires an additional adaptation phase, in 11 | #' which the MCMC sampling procedure is adjusted. Note that the MCMC sampling 12 | #' will still give correct results even if the warning appears: "Adaptation 13 | #' incomplete." (this just means that sampling efficiency is not optimal). 14 | #' 15 | #' @export 16 | extendMPT <- function( 17 | fittedModel, 18 | n.iter = 10000, 19 | n.adapt = 1000, 20 | n.burnin = 0, 21 | ... 22 | ) { 23 | args <- list(...) 24 | if ("n.thin" %in% names(args)) { 25 | warning("Thinnning interval cannot be changed and is ignored!") 26 | } 27 | args$n.thin <- args$burnin <- args$adapt <- args$sample <- args$summarise <- args$model <- NULL 28 | 29 | # remove correlations (otherwise, extension not possible) 30 | sel.cor <- grep("cor_", varnames(fittedModel$runjags$mcmc), fixed = TRUE) 31 | if (inherits(fittedModel, "betaMPT")) { 32 | sel.cor <- c(sel.cor, grep("rho", varnames(fittedModel$runjags$mcmc), fixed = TRUE)) 33 | } 34 | if (length(sel.cor) > 0) { 35 | fittedModel$runjags$mcmc <- fittedModel$runjags$mcmc[, -sel.cor] 36 | } 37 | 38 | args_extend <- c( 39 | list( 40 | runjags.object = fittedModel$runjags, 41 | burnin = n.burnin, 42 | sample = ceiling((n.iter - n.burnin) / fittedModel$runjags$thin), 43 | adapt = n.adapt, 44 | summarise = FALSE 45 | ), 46 | args 47 | ) 48 | fittedModel$runjags <- do.call("extend.jags", args_extend) 49 | 50 | # add correlations 51 | covData <- fittedModel$mptInfo$covData 52 | predTable <- fittedModel$mptInfo$predTable 53 | if (!is.null(covData) | fittedModel$mptInfo$model == "betaMPT") { 54 | if (!is.null(predTable) & fittedModel$mptInfo$model == "traitMPT") { 55 | isPred <- (1:ncol(covData)) %in% predTable$covIdx 56 | } else { 57 | isPred <- rep(FALSE, length(fittedModel$mptInfo$predType)) 58 | } 59 | 60 | sel <- fittedModel$mptInfo$predType == "c" & !isPred 61 | if (any(sel) || inherits(fittedModel, "betaMPT")) { 62 | cdat <- covData[, sel, drop = FALSE] 63 | fittedModel$runjags$mcmc <- as.mcmc.list( 64 | lapply(fittedModel$runjags$mcmc, corSamples, 65 | covData = cdat, 66 | thetaUnique = fittedModel$mptInfo$thetaUnique, 67 | rho = ifelse(inherits(fittedModel, "betaMPT"), TRUE, FALSE), 68 | corProbit = fittedModel$mptInfo$corProbit 69 | ) 70 | ) 71 | } 72 | } 73 | 74 | fittedModel$mcmc.summ <- summarizeMCMC(fittedModel$runjags$mcmc, batchSize = 10) 75 | fittedModel$summary <- summarizeMPT( 76 | mcmc = fittedModel$runjags$mcmc, 77 | summ = fittedModel$mcmc.summ, 78 | mptInfo = fittedModel$mptInfo 79 | ) 80 | fittedModel$call <- c(fittedModel$call, match.call()) 81 | fittedModel 82 | } 83 | -------------------------------------------------------------------------------- /R/plotParameters.R: -------------------------------------------------------------------------------- 1 | 2 | ############## PLOTTING FUNCTIONS FOR betaMPT 3 | 4 | #' Plot Parameter Estimates 5 | #' 6 | #' Plot parameter estimates for hierarchical MPT models. 7 | #' 8 | #' @param x a fitted Beta or latent-trait MPT model 9 | #' @param includeIndividual whether to plot individual estimates 10 | #' @param addLines whether to connect individual parameter estimates by lines 11 | #' @param estimate type of point estimates for group-level and individual parameters 12 | #' (either \code{"mean"} or \code{"median"}) 13 | #' @param select character vector of parameters to be plotted (e.g., \code{select = c("d", "g")}. Can be used to plot subsets of parameters and change the order of parameters. 14 | #' @param ... further arguments passed to the standard \code{\link{plot}} function 15 | #' 16 | #' @author Daniel Heck 17 | #' @seealso \code{\link{betaMPT}}, \code{\link{traitMPT}}, \code{\link{plotDistribution}} 18 | #' @examples 19 | #' \dontrun{ 20 | #' plotParam(fit, 21 | #' addLines = TRUE, 22 | #' estimate = "median", 23 | #' select = c("d1", "d2") 24 | #' ) 25 | #' } 26 | #' @export 27 | plotParam <- function(x, includeIndividual = TRUE, addLines = FALSE, 28 | estimate = "mean", select = "all", ...) { 29 | stat <- ifelse(estimate == "median", "50%", "Mean") 30 | par.group <- x$summary$groupParameters$mean 31 | par.ind <- x$summary$individParameters 32 | parnames <- substr(rownames(par.group), 6, 100) 33 | if (select[1] == "all") { 34 | select <- parnames 35 | } else { 36 | if (!all(select %in% parnames)) { 37 | stop( 38 | "Check arguments: Not all parameters in 'select' are included in the MPT model!\n", 39 | "Parameters are: ", paste(parnames, collapse = ", ") 40 | ) 41 | } 42 | par.group <- par.group[paste0("mean_", select), , drop = FALSE] 43 | } 44 | dims <- dim(par.ind) 45 | S <- nrow(par.group) # parameters 46 | N <- dims[2] # persons 47 | means <- par.group[, stat] 48 | 49 | plot(1:S, means, 50 | ylim = 0:1, xlim = c(.5, S + .5), pch = 19, xaxt = "n", # size=3, 51 | xlab = "MPT Parameters", 52 | ylab = paste0("Estimate (", estimate, "s)"), col = 2, 53 | main = paste0( 54 | "Group-level ", estimate, "s + 95% CI (red)", 55 | ifelse(includeIndividual, 56 | paste0(" and individual ", estimate, "s (gray)"), 57 | "" 58 | ) 59 | ), ... 60 | ) 61 | axis(side = 1, at = 1:S, labels = select) 62 | if (includeIndividual) { 63 | for (i in 1:N) { 64 | if (addLines) { 65 | lines(1:S + .05, par.ind[select, i, stat], 66 | col = adjustcolor(col = "black", alpha.f = .5) 67 | ) 68 | points(1:S + .05, par.ind[select, i, stat], 69 | cex = .9, pch = 16, 70 | col = adjustcolor(col = "black", alpha.f = .5) 71 | ) 72 | } else { 73 | points(1:S + seq(-.2, .2, length.out = N)[i], 74 | col = adjustcolor(col = "black", alpha.f = .5), # col=rainbow(N, alpha=.4)[i], 75 | pch = 16, 76 | par.ind[select, i, stat], cex = .9 77 | ) 78 | } 79 | } 80 | points(1:S, means, cex = 1.3, col = 2, pch = 19) 81 | } 82 | segments( 83 | x0 = 1:S, y0 = par.group[, 3], 84 | y1 = par.group[, 5], lwd = 2, col = 2 85 | ) 86 | } 87 | -------------------------------------------------------------------------------- /R/genDataCheck.R: -------------------------------------------------------------------------------- 1 | ################### HELPER FUNCTIONS #################################### 2 | 3 | checkNumItems <- function(numItems, treeLabels) { 4 | if (any(sort(treeLabels) != sort(names(numItems)))) { 5 | stop( 6 | "Names for numItems do not match the tree labels in EQN file:\n ", 7 | paste(substr(treeLabels, 3, 100), collapse = ", ") 8 | ) 9 | } 10 | if (length(numItems) != length(treeLabels)) { 11 | stop("Argument numItems has the wrong length (should be", length(treeLabels), ")") 12 | } 13 | numItems[treeLabels] 14 | } 15 | 16 | checkThetaNames <- function(theta, thetaNames) { 17 | if (any(sort(thetaNames) != sort(colnames(theta)))) { 18 | stop( 19 | "Column names of theta do not match parameters in EQN file:\n ", 20 | paste(thetaNames, collapse = ", ") 21 | ) 22 | } 23 | theta[, thetaNames, drop = FALSE] 24 | } 25 | 26 | checkNamingMatrix <- function(S, thetaNames, matrix, 27 | matrixName = "rho", warning = TRUE) { 28 | if (any(S != dim(matrix))) { 29 | stop("Dimensions of matrix '", matrixName, "' not correct, should be ", S, "x", S) 30 | } 31 | 32 | if (is.null(dimnames(matrix))) { 33 | if (warning) { 34 | warning( 35 | "Matrix '", matrixName, "' not named. Internal order of parameters is used.\n", 36 | "See ?readMultiTree and check parameters by generatedData$parameters" 37 | ) 38 | } 39 | dimnames(matrix) <- list(thetaNames, thetaNames) 40 | } else if (any(sort(thetaNames) != sort(rownames(matrix)))) { 41 | stop("Row names of matrix '", matrixName, "' do not match parameter labels in eqn file.") 42 | } else if (any(sort(thetaNames) != sort(colnames(matrix)))) { 43 | stop("Column names of matrix '", matrixName, "' do not match parameter labels in eqn file.") 44 | } else { 45 | matrix <- matrix[thetaNames, , drop = FALSE] 46 | matrix <- matrix[, thetaNames, drop = FALSE] 47 | } 48 | 49 | if (any(diag(matrix) != 1)) { 50 | stop("Diagonal must have ones!") 51 | } 52 | 53 | if (any(abs(matrix - t(matrix)) > 1e-10)) { 54 | stop("Matrix ", matrixName, " must be symmetric!") 55 | } 56 | 57 | if (any(matrix < -1 | matrix > 1)) { 58 | stop("'", matrixName, "' cannot be negative!") 59 | } 60 | 61 | return(matrix) 62 | } 63 | 64 | checkNaming <- function(S, thetaNames, vector, vectorName, 65 | interval = c(0, Inf), warning = TRUE) { 66 | if (S != length(vector)) { 67 | stop("Length of '", vectorName, "' not correct, should be ", S) 68 | } 69 | if (is.null(names(vector))) { 70 | if (warning) { 71 | warning( 72 | "Vector '", vectorName, "' not named. Internal order of parameters", 73 | " is used, see ?readMultiTree and check parameters by generatedData$parameters" 74 | ) 75 | } 76 | names(vector) <- thetaNames 77 | } else if (any(sort(thetaNames) != sort(names(vector)))) { 78 | stop("Parameter names of vector '", vectorName, "' do not match parameter labels in eqn file.") 79 | } else { 80 | vector <- vector[thetaNames] 81 | } 82 | 83 | if (any(vector < interval[1] | vector > interval[2])) { 84 | stop("'", vectorName, "' cannot be below ", interval[1], " or above ", interval[2], ".") 85 | } 86 | 87 | return(vector) 88 | } 89 | -------------------------------------------------------------------------------- /R/within_subject_EQN.R: -------------------------------------------------------------------------------- 1 | #' Generate EQN Files for Within-Subject Designs 2 | #' 3 | #' Replicates an MPT model multiple times with different tree, category, and 4 | #' parameter labels for within-subject factorial designs. 5 | #' 6 | #' @inheritParams betaMPT 7 | #' @param labels a character vector defining the labels that are added to the 8 | #' parameters in each within-subject condition 9 | #' @param constant optional: a character vector defining which parameters are 10 | #' constrained to be constant across within-conditions 11 | #' @param save optional: path to an EQN output file. By default, the model is 12 | #' return as a string character 13 | #' 14 | #' @examples 15 | #' # Example: Standard Two-High-Threshold Model (2HTM) 16 | #' EQNfile <- system.file("MPTmodels/2htm.eqn", 17 | #' package = "TreeBUGS" 18 | #' ) 19 | #' withinSubjectEQN(EQNfile, c("high", "low"), constant = c("g")) 20 | #' @export 21 | withinSubjectEQN <- function( 22 | eqnfile, 23 | labels, 24 | constant, 25 | save 26 | ) { 27 | tree <- readEQN(eqnfile) 28 | param <- colnames(readEQN(eqnfile, parse = TRUE)$a) 29 | if (!missing(constant)) { 30 | param <- setdiff(param, constant) 31 | } 32 | 33 | if (length(unique(labels)) != length(labels)) { 34 | stop("The within-subject 'labels' must be unique!") 35 | } 36 | tree.list <- list(tree)[rep(1, length(labels))] 37 | 38 | for (w in 1:length(labels)) { 39 | tree.list[[w]]$Tree <- paste0(labels[w], "_", substr(tree$Tree, 3, 999)) 40 | tree.list[[w]]$Category <- paste0(labels[w], "_", tree$Category) 41 | for (b in 1:nrow(tree)) { 42 | for (p in 1:length(param)) { 43 | # look behind mechanism: check for dots in parameter labels via (?!\\.) 44 | # https://stackoverflow.com/questions/23094532/java-regular-expression-word-without-ending-with-dot 45 | # requires perl=TRUE 46 | 47 | tree.list[[w]]$Equation[b] <- gsub(paste0("\\b", param[p], "\\b(?!\\.)"), 48 | paste0(param[p], "_", labels[w]), 49 | tree.list[[w]]$Equation[b], 50 | perl = TRUE 51 | ) 52 | 53 | # tree.list[[w]]$Equation[b] <- ifelse(tree.list[[w]]$Equation[b] == param[p], 54 | # paste0(param[p],"_",labels[w]), 55 | # tree.list[[w]]$Equation[b]) 56 | # tree.list[[w]]$Equation[b] <- gsub(paste0("1-",param[p]), 57 | # paste0("1-",param[p],"_",labels[w]), 58 | # tree.list[[w]]$Equation[b],fixed=TRUE) 59 | # tree.list[[w]]$Equation[b] <- gsub(paste0("+",param[p]), 60 | # paste0("+",param[p],"_",labels[w]), 61 | # tree.list[[w]]$Equation[b],fixed=TRUE) 62 | # tree.list[[w]]$Equation[b] <- gsub(paste0("*",param[p]), 63 | # paste0("*",param[p],"_",labels[w]), 64 | # tree.list[[w]]$Equation[b],fixed=TRUE) 65 | } 66 | } 67 | } 68 | 69 | res <- do.call("rbind", tree.list) 70 | res$EQN <- NULL 71 | if (!missing(save)) { 72 | write.table(res, file = save, quote = FALSE, row.names = FALSE, sep = " ") 73 | } 74 | print(res, quote = FALSE, row.names = FALSE, sep = " ") 75 | } 76 | -------------------------------------------------------------------------------- /man/correlationPosterior.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/correlationBayesMCMC.R 3 | \name{correlationPosterior} 4 | \alias{correlationPosterior} 5 | \title{Posterior Distribution for Correlations} 6 | \usage{ 7 | correlationPosterior( 8 | fittedModel, 9 | r, 10 | N, 11 | kappa = 1, 12 | ci = 0.95, 13 | M = 1000, 14 | precision = 0.005, 15 | maxiter = 10000, 16 | plot = TRUE, 17 | nCPU = 4 18 | ) 19 | } 20 | \arguments{ 21 | \item{fittedModel}{a fitted \link{betaMPT} or \link{traitMPT} model with 22 | covariates (added during fitting by the argument \code{covData})} 23 | 24 | \item{r}{optional: a vector of posterior correlations (instead of 25 | \code{fittedModel})} 26 | 27 | \item{N}{only if \code{r} is used: the number of participants the correlation 28 | is based on} 29 | 30 | \item{kappa}{parameter for the prior of the correlation, that is, a scaled 31 | beta distribution: Beta(1/kappa, 1/kappa). The default \code{kappa=1} 32 | defines a uniform distribution on [-1,1], whereas \code{kappa<1} defines a 33 | unimodal prior centered around zero.} 34 | 35 | \item{ci}{credibility interval} 36 | 37 | \item{M}{number of subsamples from the fitted model} 38 | 39 | \item{precision}{precision on the interval [-1,1] to approximate the 40 | posterior density} 41 | 42 | \item{maxiter}{maximum number of iterations in 43 | \code{\link[hypergeo]{genhypergeo}}. Higher values might be necessary to 44 | increase numerical stability for large correlations (r>.95).} 45 | 46 | \item{plot}{whether to plot (a) the unadjusted posterior correlations (gray 47 | histogram) and (b) the corrected posterior (black line with red credibility 48 | intervals)} 49 | 50 | \item{nCPU}{number of CPUs used for parallel computation of posterior 51 | distribution} 52 | } 53 | \description{ 54 | Adjusts the posterior distribution of correlations for the sampling error of 55 | a population correlation according to the sample size (i.e., the number of 56 | participants; Ly, Marsman, & Wagenmakers, 2018). 57 | } 58 | \details{ 59 | This function (1) uses all posterior samples of a correlation to (2) 60 | derive the posterior of the correlation corrected for sampling error and (3) 61 | averages these densities across the posterior samples. Thereby, the method 62 | accounts for estimation uncertainty of the MPT model (due to the use of the 63 | posterior samples) and also for sampling error of the population correlation 64 | due to sample size (cf. Ly, Boehm, Heathcote, Turner, Forstmann, Marsman, & 65 | Matzke, 2016). 66 | } 67 | \examples{ 68 | # test effect of number of participants: 69 | set.seed(123) 70 | cors <- rbeta(50, 100, 70) 71 | correlationPosterior(r = cors, N = 10, nCPU = 1) 72 | correlationPosterior(r = cors, N = 100, nCPU = 1) 73 | 74 | } 75 | \references{ 76 | Ly, A., Marsman, M., & Wagenmakers, E.-J. (2018). Analytic 77 | posteriors for Pearson’s correlation coefficient. \emph{Statistica 78 | Neerlandica, 72}, 4–13. \doi{10.1111/stan.12111} 79 | 80 | Ly, A., Boehm, U., Heathcote, A., Turner, B. M. , Forstmann, B., Marsman, 81 | M., and Matzke, D. (2017). A flexible and efficient hierarchical Bayesian 82 | approach to the exploration of individual differences in 83 | cognitive-model-based neuroscience. \url{https://osf.io/evsyv/}. 84 | \doi{10.1002/9781119159193} 85 | } 86 | \author{ 87 | Daniel W. Heck, Alexander Ly 88 | } 89 | -------------------------------------------------------------------------------- /R/probitInverse.R: -------------------------------------------------------------------------------- 1 | #' Probit-Inverse of Group-Level Normal Distribution 2 | #' 3 | #' Transform latent group-level normal distribution (latent-trait MPT) into mean 4 | #' and SD on probability scale. 5 | #' 6 | #' @param mu latent-probit mean of normal distribution 7 | #' @param sigma latent-probit SD of normal distribution 8 | #' @param fittedModel optional: fitted \link{traitMPT} model. If provided, the 9 | #' bivariate inverse-probit transform is applied to all MCMC samples (and 10 | #' \code{mu} and \code{sigma} are ignored). 11 | #' 12 | #' @return implied mean and SD on probability scale 13 | #' 14 | #' @examples 15 | #' ####### compare bivariate vs. univariate transformation 16 | #' probitInverse(mu = 0.8, sigma = c(0.25, 0.5, 0.75, 1)) 17 | #' pnorm(0.8) 18 | #' 19 | #' # full distribution 20 | #' prob <- pnorm(rnorm(10000, mean = 0.8, sd = 0.7)) 21 | #' hist(prob, 80, col = "gray", xlim = 0:1) 22 | #' 23 | #' \dontrun{ 24 | #' # transformation for fitted model 25 | #' mean_sd <- probitInverse(fittedModel = fit) 26 | #' summarizeMCMC(mean_sd) 27 | #' } 28 | #' @importFrom coda varnames 29 | #' @importFrom stats integrate 30 | #' @export 31 | probitInverse <- function( 32 | mu, 33 | sigma, 34 | fittedModel = NULL 35 | ) { 36 | 37 | probitInverseVec <- Vectorize( 38 | function(mu, sigma) { 39 | mp <- vp <- NA 40 | try({ 41 | mp <- integrate( 42 | function(x) { 43 | pnorm(x) * dnorm(x, mu, sigma) 44 | }, 45 | # -Inf, Inf)$value 46 | mu - 5 * sigma, mu + 5 * sigma 47 | )$value 48 | vp <- integrate( 49 | function(x) { 50 | (pnorm(x) - mp)^2 * dnorm(x, mu, sigma) 51 | }, 52 | # -Inf, Inf)$value 53 | mu - 5 * sigma, mu + 5 * sigma 54 | )$value 55 | }) 56 | if (!is.na(vp) && vp < 0) { 57 | vp <- NA 58 | } else if (is.na(vp)) { 59 | mp <- NA 60 | } 61 | return(c(mean = mp, sd = sqrt(vp))) 62 | }, c("mu", "sigma") 63 | ) 64 | 65 | if (missing(fittedModel) || is.null(fittedModel)) { 66 | res <- t(probitInverseVec(mu, sigma)) 67 | if (any(is.na(res))) { 68 | cat("Transformation resulted in NAs for:\n") 69 | print(cbind(mu = mu, sigma = sigma, res)[apply(is.na(res), 1, any), ]) 70 | } 71 | return(res) 72 | } else { 73 | if (!inherits(fittedModel, "traitMPT")) { 74 | stop("'fittedModel' must be a latent-trait MPT model.") 75 | } 76 | 77 | samp <- fittedModel$runjags$mcmc[, c()] 78 | thetaNames <- fittedModel$mptInfo$thetaUnique 79 | sel.mu <- grep("mu", varnames(fittedModel$runjags$mcmc)) 80 | sel.sig <- grep("sigma", varnames(fittedModel$runjags$mcmc)) 81 | s.mu <- fittedModel$runjags$mcmc[, sel.mu] 82 | s.sig <- fittedModel$runjags$mcmc[, sel.sig] 83 | # cl <- makeCluster(nCPU) 84 | # clusterExport(cl, c("probitInverseVec","s.mu","s.sig", "thetaNames")) 85 | for (cc in 1:length(s.mu)) { 86 | for (s in 1:ncol(s.mu[[cc]])) { 87 | res <- probitInverseVec(mu = s.mu[[cc]][, s], sigma = s.sig[[cc]][, s]) 88 | rownames(res) <- paste0(c("mean_", "sd_"), thetaNames[s]) 89 | samp[[cc]] <- cbind(samp[[cc]], t(res)) 90 | } 91 | samp[[cc]] <- mcmc(samp[[cc]]) 92 | attr(samp[[cc]], "mcpar") <- attr(fittedModel$runjags$mcmc[[cc]], "mcpar") 93 | } 94 | return(as.mcmc.list(samp)) 95 | } 96 | } 97 | -------------------------------------------------------------------------------- /man/genBetaMPT.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/genDataBeta.R 3 | \name{genBetaMPT} 4 | \alias{genBetaMPT} 5 | \title{Generate Data for Beta MPT Models} 6 | \usage{ 7 | genBetaMPT( 8 | N, 9 | numItems, 10 | eqnfile, 11 | restrictions, 12 | mean = NULL, 13 | sd = NULL, 14 | alpha = NULL, 15 | beta = NULL, 16 | warning = TRUE 17 | ) 18 | } 19 | \arguments{ 20 | \item{N}{number of participants} 21 | 22 | \item{numItems}{number of responses per tree (a named vector with tree 23 | labels)} 24 | 25 | \item{eqnfile}{The (relative or full) path to the file that specifies the MPT 26 | model (standard .eqn syntax). Note that category labels must start with a 27 | letter (different to multiTree) and match the column names of \code{data}. 28 | Alternatively, the EQN-equations can be provided within R as a character 29 | value (cf. \code{\link{readEQN}}). Note that the first line of an .eqn-file 30 | is reserved for comments and always ignored.} 31 | 32 | \item{restrictions}{Specifies which parameters should be (a) constant (e.g., 33 | \code{"a=b=.5"}) or (b) constrained to be identical (e.g., \code{"Do=Dn"}) 34 | or (c) treated as fixed effects (i.e., identical for all participants; 35 | \code{"a=b=FE"}). Either given as the path to a text file with restrictions 36 | per row or as a list of restrictions, e.g., \code{list("D1=D2","g=0.5")}. 37 | Note that numbers in .eqn-equations (e.g., \code{d*(1-g)*.50}) are directly 38 | interpreted as equality constraints.} 39 | 40 | \item{mean}{Named vector of true group means of individual MPT parameters. If 41 | the vector is not named, the internal order of parameters is used (can be 42 | obtained using \code{\link{readEQN}}).} 43 | 44 | \item{sd}{named vector of group standard deviations of individual MPT 45 | parameters.} 46 | 47 | \item{alpha}{Alternative specification of the group-level distribution using 48 | the shape parameters of the beta distribution (see \link{dbeta}).} 49 | 50 | \item{beta}{see \code{alpha}} 51 | 52 | \item{warning}{whether to show warning in case the naming of data-generating 53 | parameters are unnamed or do not match} 54 | } 55 | \value{ 56 | a list including the generated frequencies (\code{data}) and the 57 | true, underlying parameters (\code{parameters}) on the group and individual 58 | level. 59 | } 60 | \description{ 61 | Generating a data file with known parameter structure using the Beta-MPT. 62 | Useful for simulations and robustness checks. 63 | } 64 | \details{ 65 | Data are generated in a two-step procedure. First, person parameters 66 | are sampled from the specified beta distributions for each paramter (either 67 | based on mean/sd or based on alpha/beta). In a second step, response 68 | frequencies are sampled for each person using \code{\link{genMPT}}. 69 | } 70 | \examples{ 71 | # Example: Standard Two-High-Threshold Model (2HTM) 72 | EQNfile <- system.file("MPTmodels/2htm.eqn", package = "TreeBUGS") 73 | genDat <- genBetaMPT( 74 | N = 100, 75 | numItems = c(Target = 250, Lure = 250), 76 | eqnfile = EQNfile, 77 | mean = c(Do = .7, Dn = .5, g = .5), 78 | sd = c(Do = .1, Dn = .1, g = .05) 79 | ) 80 | head(genDat$data, 3) 81 | plotFreq(genDat$data, eqn = EQNfile) 82 | } 83 | \references{ 84 | Smith, J. B., & Batchelder, W. H. (2010). Beta-MPT: Multinomial 85 | processing tree models for addressing individual differences. Journal of 86 | Mathematical Psychology, 54, 167-183. 87 | } 88 | \seealso{ 89 | \code{\link{genMPT}} 90 | } 91 | -------------------------------------------------------------------------------- /R/plotFit.R: -------------------------------------------------------------------------------- 1 | #' Plot Posterior Predictive Mean Frequencies 2 | #' 3 | #' Plots observed means/covariances of individual frequencies against the 4 | #' means/covariances sampled from the posterior distribution (posterior 5 | #' predictive distribution). 6 | #' 7 | #' @inheritParams posteriorPredictive 8 | #' @param stat whether to plot mean frequencies (\code{"mean"}) or covariances 9 | #' of individual frequencies (\code{"cov"}) 10 | #' @param ... arguments passed to \code{\link{boxplot}} 11 | #' 12 | #' @details If posterior predictive p-values were computed when fitting the 13 | #' model (e.g., by adding the argument \code{traitMPT(...,ppp=1000)} ), the 14 | #' stored posterior samples are re-used for plotting. Note that the last 15 | #' category in each MPT tree is dropped, because one category per multinomial 16 | #' distribution is fixed. 17 | #' 18 | #' @examples 19 | #' \dontrun{ 20 | #' # add posterior predictive samples to fitted model (optional step) 21 | #' fittedModel$postpred$freq.pred <- 22 | #' posteriorPredictive(fittedModel, M = 1000) 23 | #' 24 | #' # plot model fit 25 | #' plotFit(fittedModel, stat = "mean") 26 | #' } 27 | #' @export 28 | plotFit <- function( 29 | fittedModel, 30 | M = 1000, 31 | stat = "mean", 32 | ... 33 | ) { 34 | stat <- match.arg(stat, c("mean", "cov")) 35 | 36 | # get information about model: 37 | tree <- fittedModel$mptInfo$MPT$Tree 38 | cats <- fittedModel$mptInfo$MPT$Category 39 | dat <- fittedModel$mptInfo$dat[, cats] 40 | TreeNames <- unique(tree) 41 | 42 | # free categories (drop last category per tree): 43 | free_cats <- unlist(tapply( 44 | X = cats, INDEX = tree, 45 | FUN = function(cat) cat[-length(cat)] 46 | )) 47 | 48 | # get posterior predictive: 49 | if (is.null(fittedModel$postpred) | M != 1000) { 50 | freq.list <- posteriorPredictive(fittedModel, M = M) 51 | } else { 52 | freq.list <- fittedModel$postpred$freq.pred 53 | } 54 | 55 | if (stat == "mean") { 56 | # Plot mean frequencies: 57 | 58 | pred <- t(sapply(freq.list, colMeans)) 59 | boxplot(pred[, free_cats], 60 | xaxt = "n", col = "gray", 61 | main = "Observed (red) and predicted (boxplot) mean frequencies", las = 1, ... 62 | ) 63 | axis(1, seq_along(free_cats), labels = free_cats) 64 | 65 | xx <- by(seq_along(free_cats), tree[cats %in% free_cats], mean) 66 | axis(1, xx, TreeNames, tick = F, line = NA, mgp = c(3, 2.5, 0)) 67 | points(1:length(free_cats), colMeans(dat)[free_cats], 68 | col = "red", cex = 1.4, pch = 17 69 | ) 70 | abline(v = cumsum(table(tree) - 1)[1:(length(TreeNames) - 1)] + .5, col = "gray") 71 | } else if (stat == "cov") { 72 | # Plot covariance of frequencies: 73 | 74 | nams <- outer(free_cats, free_cats, paste, sep = "-") 75 | sel_cov <- nams[upper.tri(nams, diag = TRUE)] 76 | K <- length(sel_cov) 77 | 78 | # observed/predicted 79 | c.obs <- cov(dat[, free_cats]) 80 | c.pred <- sapply(freq.list, function(xx) { 81 | cc <- cov(xx[, free_cats]) 82 | cc[upper.tri(cc, diag = TRUE)] 83 | }) 84 | 85 | boxplot(t(c.pred), 86 | col = "gray", ylab = "Covariance", 87 | main = "Observed (red) and predicted (gray) covariances", 88 | xaxt = "n", las = 1, ... 89 | ) 90 | abline(h = 0, lty = 1, col = "gray") 91 | axis(1, 1:K, labels = nams[upper.tri(nams, diag = TRUE)], las = 2) 92 | points(1:K, c.obs[upper.tri(c.obs, diag = TRUE)], col = 2, pch = 17) 93 | abline(v = cumsum(seq(nrow(c.obs), 2, -1)) + .5, col = "lightgray") 94 | } 95 | } 96 | -------------------------------------------------------------------------------- /man/WAIC.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/WAIC.R 3 | \name{WAIC} 4 | \alias{WAIC} 5 | \alias{print.waic} 6 | \alias{print.waic_difference} 7 | \alias{-.waic} 8 | \title{WAIC: Widely Applicable Information Criterion} 9 | \usage{ 10 | WAIC( 11 | fittedModel, 12 | n.adapt = 1000, 13 | n.chains = 3, 14 | n.iter = 10000, 15 | n.thin = 1, 16 | summarize = FALSE 17 | ) 18 | 19 | \method{print}{waic}(x, ...) 20 | 21 | \method{print}{waic_difference}(x, ...) 22 | 23 | \method{-}{waic}(e1, e2) 24 | } 25 | \arguments{ 26 | \item{fittedModel}{fitted latent-trait or beta MPT model (\code{\link{traitMPT}}, \code{\link{betaMPT}})} 27 | 28 | \item{n.adapt}{number of adaptation samples.} 29 | 30 | \item{n.chains}{number of chains (no parallel computation).} 31 | 32 | \item{n.iter}{number of iterations after burnin.} 33 | 34 | \item{n.thin}{Thinning rate.} 35 | 36 | \item{summarize}{deprecated argument only available for backwards compatibility} 37 | 38 | \item{x}{An object of class \code{waic} or \code{waic_difference} to be printed.} 39 | 40 | \item{...}{Further arguments that may be passed to print methods.} 41 | 42 | \item{e1, e2}{Two objects of class \code{waic} to be compared.} 43 | } 44 | \value{ 45 | Function \code{WAIC()} returns an object of class \code{waic}, which is basically 46 | a list containing three vectors \code{p_waic}, \code{deviance}, and \code{waic}, with 47 | separate values for each observed node 48 | (i.e., for all combinations of persons and free categories). 49 | 50 | For these objects, a \code{print()} method exists, which 51 | also calculates the standard error of the estimate of WAIC. 52 | 53 | For backwards compatibility, if \code{WAIC()} is called with \code{summarize = TRUE}, 54 | a vector with values \code{p_waic}, \code{deviance}, \code{waic}, and \code{se_waic} is returned. 55 | 56 | WAIC values from two models can be compared by using the \code{-} operator; 57 | the result is an object of class \code{waic_difference}. 58 | } 59 | \description{ 60 | Implementation of the WAIC for model comparison. 61 | } 62 | \details{ 63 | WAIC provides an approximation of predictive accuracy with respect 64 | to out-of-sample deviance. The uncertainty of the WAIC for the given number 65 | of observed nodes (i.e., number of free categories times the number of 66 | participants) is quantified by the standard error of WAIC \code{"se_waic"} 67 | (cf. Vehtari et al., 2017). In contrast, to assess whether the approximation 68 | uncertainty due to MCMC sampling (not sample size) is sufficiently low, it is 69 | a good idea to fit each model twice and compute WAIC again to assess the 70 | stability of the WAIC values. 71 | 72 | For more details, see Vehtari et al. (2017) and the following discussion 73 | about the JAGS implementation (which is currently an experimental feature of 74 | JAGS 4.3.0): 75 | 76 | \url{https://sourceforge.net/p/mcmc-jags/discussion/610036/thread/8211df61/} 77 | } 78 | \examples{ 79 | \dontrun{ 80 | 81 | #### WAIC for a latent-trait MPT model: 82 | fit <- traitMPT(...) 83 | WAIC(fit) 84 | 85 | 86 | #### pairwise comparison of two models: 87 | 88 | # (1) compute WAIC per model 89 | waic1 <- WAIC(fit1) 90 | waic2 <- WAIC(fit2) 91 | 92 | # (2) WAIC difference 93 | waic1 - waic2 94 | } 95 | 96 | 97 | } 98 | \references{ 99 | Vehtari, A., Gelman, A., & Gabry, J. (2017). Practical Bayesian 100 | model evaluation using leave-one-out cross-validation and WAIC. Statistics 101 | and Computing, 27(5), 1413–1432. doi:10.1007/s11222-016-9696-4 102 | } 103 | -------------------------------------------------------------------------------- /R/plotDistribution.R: -------------------------------------------------------------------------------- 1 | #' Plot Distribution of Individual Estimates 2 | #' 3 | #' Plots histograms of the posterior-means of individual MPT parameters against 4 | #' the group-level distribution given by the posterior-mean of the hierarchical 5 | #' parameters (e.g., the beta distribution in case of the beta-MPT) 6 | #' 7 | #' @param fittedModel fitted latent-trait or beta MPT model 8 | #' (\code{\link{traitMPT}}, \code{\link{betaMPT}}) 9 | #' @param scale only for latent-trait MPT: should estimates be plotted on the 10 | #' \code{"latent"} or the \code{"probability"} scale (i.e., as MPT 11 | #' parameters). Can be abbreviated by \code{"l"} and \code{"p"}. 12 | #' @param ... further arguments passed to \code{\link{hist}} (e.g., 13 | #' \code{breaks=50} to get a more fine-grained histogram) 14 | #' 15 | #' @details For the latent-trait MPT, differences due to continuous predictors 16 | #' or discrete factors are currently not considered in the group-level 17 | #' predictions (red density). Under such a model, individual estimates are not 18 | #' predicted to be normally distributed on the latent scale as shown in the 19 | #' plot. 20 | #' 21 | #' @seealso \code{\link{plot.traitMPT}} 22 | #' @export 23 | plotDistribution <- function( 24 | fittedModel, 25 | scale = "probability", 26 | ... 27 | ) { 28 | mfrow <- par()$mfrow 29 | mar <- par()$mar 30 | scale <- match.arg(scale, c("probability", "latent")) 31 | 32 | means <- fittedModel$summary$groupParameters$mean[, 1] 33 | parnames <- names(fittedModel$summary$individParameters[, 1, 1]) 34 | 35 | S <- length(means) 36 | nrow <- floor(sqrt(S)) 37 | ncol <- ceiling(sqrt(S)) 38 | par(mfrow = c(min(4, nrow), min(6, ncol)), mar = c(2, 2, 3, .3)) 39 | 40 | for (idx in 1:S) { 41 | indEsts <- fittedModel$summary$individParameters[idx, , 1] 42 | if (all(is.na(indEsts))) 43 | stop("No MCMC samples for the individual-level MPT parameters (theta) were stored. \n", 44 | "Please re-fit model with the argument: monitorIndividual = TRUE") 45 | 46 | if (inherits(fittedModel, "traitMPT")) { 47 | sigma <- fittedModel$summary$groupParameters$sigma[, "Mean"] 48 | # sigma <- fittedModel$mcmc$BUGSoutput$mean$sigma 49 | 50 | # values on latent scale: 51 | xx <- seq(-10, 10, length.out = 3000) 52 | if (scale == "latent") { 53 | hist(qnorm(indEsts), 54 | freq = F, main = paste0("Parameter ", parnames[idx]), 55 | col = "gray", xlab = "Latent scale", las = 1, ... 56 | ) 57 | lines(xx, dnorm(xx, qnorm(means[idx]), sigma[idx]), col = 2) 58 | } else { 59 | hist(indEsts, 60 | freq = F, main = paste0("Parameter ", parnames[idx]), xlim = 0:1, 61 | col = "gray", xlab = "Probability scale", las = 1, ... 62 | ) 63 | # values on probability scale: 64 | xx.p <- pnorm(xx) 65 | # discrete approximation to density on latent scale: 66 | p.diff <- diff(c(pnorm(xx, qnorm(means[idx]), sigma[idx]), 1)) 67 | lines(xx.p, p.diff / diff(c(xx.p, 1)), col = 2) 68 | } 69 | } else if (inherits(fittedModel, "betaMPT")) { 70 | alpha <- fittedModel$summary$groupParameters$alpha[, 1] 71 | beta <- fittedModel$summary$groupParameters$beta[, 1] 72 | 73 | hist(indEsts, 74 | freq = F, main = paste0("Parameter ", parnames[idx]), xlim = 0:1, 75 | col = "gray", xlab = "Probability scale", las = 1, ... 76 | ) 77 | xx <- seq(0, 1, length.out = 1000) 78 | lines(xx, dbeta(xx, alpha[idx], beta[idx]), col = 2) 79 | } 80 | } 81 | 82 | par(mfrow = mfrow, mar = mar) 83 | } 84 | -------------------------------------------------------------------------------- /R/TreeBUGS-package.R: -------------------------------------------------------------------------------- 1 | #' TreeBUGS: Hierarchical Multinomial Processing Tree Modeling 2 | #' 3 | #' @description{ 4 | #' \if{html}{\figure{TreeBUGS.png}{options: width='120' alt='logo' style='float: right'}} 5 | #' \if{latex}{\figure{TreeBUGS.png}{options: width=0.5in}} 6 | #' 7 | #' Uses standard MPT files in the .eqn-format (Moshagen, 2010) to fit 8 | #' hierarchical Bayesian MPT models. Note that the software JAGS is required 9 | #' (\url{https://mcmc-jags.sourceforge.io/}). } 10 | #' 11 | #' 12 | #' The core functions either fit a Beta-MPT model (\code{\link{betaMPT}}; Smith 13 | #' & Batchelder, 2010) or a latent-trait MPT model (\code{\link{traitMPT}}; 14 | #' Klauer, 2010). A fitted model can be inspected using convenient summary and 15 | #' plot functions tailored to hierarchical MPT models. 16 | #' 17 | #' Detailed explanations and examples can be found in the package vignette, 18 | #' accessible via \code{vignette("TreeBUGS")} 19 | #' 20 | #' @author Daniel W. Heck, Denis Arnold, & Nina Arnold 21 | #' @docType package 22 | #' 23 | #' @importFrom runjags run.jags extract autoextend.jags extend.jags 24 | #' @importFrom coda gelman.diag effectiveSize as.mcmc.list as.mcmc 25 | #' @importFrom utils read.csv write.table write.csv capture.output count.fields 26 | #' @importFrom graphics axis plot points segments abline boxplot curve hist 27 | #' lines par 28 | #' @importFrom grDevices rainbow adjustcolor 29 | #' @importFrom stats pnorm rnorm runif sd qnorm dnorm dbeta quantile rWishart 30 | #' ave pchisq window rbinom var 31 | #' @importFrom parallel parSapply 32 | #' @importFrom Rcpp evalCpp sourceCpp 33 | #' @importFrom MASS fitdistr 34 | #' @useDynLib "TreeBUGS", .registration=TRUE 35 | #' 36 | #' 37 | #' @section Citation: 38 | #' 39 | #' If you use TreeBUGS, please cite the software as follows: 40 | #' 41 | #' Heck, D. W., Arnold, N. R., & Arnold, D. (2018). 42 | #' TreeBUGS: An R package for hierarchical multinomial-processing-tree modeling. 43 | #' \emph{Behavior Research Methods, 50}, 264–284. 44 | #' \doi{10.3758/s13428-017-0869-7} 45 | #' 46 | #' 47 | #' @section Tutorial: 48 | #' 49 | #' For a tutorial on MPT modeling (including hierarchical modeling in TreeBUGS), see: 50 | #' 51 | #' Schmidt, O., Erdfelder, E., & Heck, D. W. (2023). 52 | #' How to develop, test, and extend multinomial processing tree models: A tutorial. 53 | #' \emph{Psychological Methods}. 54 | #' \doi{10.1037/met0000561}. 55 | #' (Preprint: \url{https://osf.io/preprints/psyarxiv/gh8md/}) 56 | #' 57 | #' 58 | #' @references 59 | #' 60 | #' Klauer, K. C. (2010). Hierarchical multinomial processing tree models: 61 | #' A latent-trait approach. 62 | #' \emph{Psychometrika, 75}, 70-98. 63 | #' \doi{10.1007/s11336-009-9141-0} 64 | #' 65 | #' Matzke, D., Dolan, C. V., Batchelder, W. H., & Wagenmakers, E.-J. (2015). 66 | #' Bayesian estimation of multinomial processing tree models with heterogeneity 67 | #' in participants and items. 68 | #' \emph{Psychometrika, 80}, 205-235. 69 | #' \doi{10.1007/s11336-013-9374-9} 70 | #' 71 | #' Moshagen, M. (2010). 72 | #' multiTree: A computer program for the analysis of multinomial processing 73 | #' tree models. 74 | #' \emph{Behavior Research Methods, 42}, 42-54. 75 | #' \doi{10.3758/BRM.42.1.42} 76 | #' 77 | #' Smith, J. B., & Batchelder, W. H. (2008). 78 | #' Assessing individual differences in categorical data. 79 | #' \emph{Psychonomic Bulletin & Review, 15}, 713-731. 80 | #' \doi{10.3758/PBR.15.4.713} 81 | #' 82 | #' Smith, J. B., & Batchelder, W. H. (2010). 83 | #' Beta-MPT: Multinomial processing tree models for addressing 84 | #' individual differences. 85 | #' \emph{Journal of Mathematical Psychology, 54}, 167-183. 86 | #' \doi{10.1016/j.jmp.2009.06.007} 87 | #' 88 | "_PACKAGE" 89 | -------------------------------------------------------------------------------- /man/priorPredictive.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/priorPredictive.R 3 | \name{priorPredictive} 4 | \alias{priorPredictive} 5 | \title{Prior Predictive Samples} 6 | \usage{ 7 | priorPredictive( 8 | prior, 9 | eqnfile, 10 | restrictions, 11 | numItems, 12 | level = "data", 13 | N = 1, 14 | M = 100, 15 | nCPU = 4 16 | ) 17 | } 18 | \arguments{ 19 | \item{prior}{a named list defining the priors. For the \link{traitMPT}, the 20 | default is \code{list(mu = "dnorm(0,1)", xi="dunif(0,10)", V=diag(S), 21 | df=S+1)}, where S is the number of free parameters. For the \link{betaMPT}, 22 | the default is \code{list(alpha ="dgamma(1,.1)", beta = "dgamma(1,.1)")}. 23 | Note that the normal distribution \code{"dnorm(mu,prec)"} is parameterized 24 | as in JAGS by the mean and precision (= 1/variance).} 25 | 26 | \item{eqnfile}{The (relative or full) path to the file that specifies the MPT 27 | model (standard .eqn syntax). Note that category labels must start with a 28 | letter (different to multiTree) and match the column names of \code{data}. 29 | Alternatively, the EQN-equations can be provided within R as a character 30 | value (cf. \code{\link{readEQN}}). Note that the first line of an .eqn-file 31 | is reserved for comments and always ignored.} 32 | 33 | \item{restrictions}{Specifies which parameters should be (a) constant (e.g., 34 | \code{"a=b=.5"}) or (b) constrained to be identical (e.g., \code{"Do=Dn"}) 35 | or (c) treated as fixed effects (i.e., identical for all participants; 36 | \code{"a=b=FE"}). Either given as the path to a text file with restrictions 37 | per row or as a list of restrictions, e.g., \code{list("D1=D2","g=0.5")}. 38 | Note that numbers in .eqn-equations (e.g., \code{d*(1-g)*.50}) are directly 39 | interpreted as equality constraints.} 40 | 41 | \item{numItems}{vector with the number of items per MPT tree (either named or 42 | assigned to alphabetically ordered tree labels)} 43 | 44 | \item{level}{either \code{"data"} (returns individual frequencies) or 45 | \code{"parameter"} (returns group-level MPT parameters; \code{M} and 46 | \code{numItems} are ignored)} 47 | 48 | \item{N}{number of participants per replication} 49 | 50 | \item{M}{number of prior predictive samples (i.e., data sets with \code{N} 51 | participants).} 52 | 53 | \item{nCPU}{number of CPUs used for parallel sampling. For large models and 54 | many participants, this may require a lot of memory.} 55 | } 56 | \value{ 57 | a list of \code{M} matrices with individual frequencies 58 | (rows=participants, columns=MPT categories). A single matrix is returned if 59 | \code{M=1} or \code{level="parameter"}. 60 | } 61 | \description{ 62 | Samples full data sets (i.e., individual response frequencies) or group-level 63 | MPT parameters based on prior distribution for group-level parameters. 64 | } 65 | \examples{ 66 | eqnfile <- system.file("MPTmodels/2htm.eqn", 67 | package = "TreeBUGS" 68 | ) 69 | ### beta-MPT: 70 | prior <- list( 71 | alpha = "dgamma(1,.1)", 72 | beta = "dgamma(1,.1)" 73 | ) 74 | 75 | ### prior-predictive frequencies: 76 | priorPredictive(prior, eqnfile, 77 | restrictions = list("g=.5", "Do=Dn"), 78 | numItems = c(50, 50), N = 10, M = 1, nCPU = 1 79 | ) 80 | 81 | ### prior samples of group-level parameters: 82 | priorPredictive(prior, eqnfile, 83 | level = "parameter", 84 | restrictions = list("g=.5", "Do=Dn"), 85 | M = 5, nCPU = 1 86 | ) 87 | 88 | ### latent-trait MPT 89 | priorPredictive( 90 | prior = list( 91 | mu = "dnorm(0,1)", xi = "dunif(0,10)", 92 | df = 3, V = diag(2) 93 | ), 94 | eqnfile, restrictions = list("g=.5"), 95 | numItems = c(50, 50), N = 10, M = 1, nCPU = 1 96 | ) 97 | 98 | } 99 | -------------------------------------------------------------------------------- /src/RcppExports.cpp: -------------------------------------------------------------------------------- 1 | // Generated by using Rcpp::compileAttributes() -> do not edit by hand 2 | // Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393 3 | 4 | #include 5 | #include 6 | 7 | using namespace Rcpp; 8 | 9 | #ifdef RCPP_USE_GLOBAL_ROSTREAM 10 | Rcpp::Rostream& Rcpp::Rcout = Rcpp::Rcpp_cout_get(); 11 | Rcpp::Rostream& Rcpp::Rcerr = Rcpp::Rcpp_cerr_get(); 12 | #endif 13 | 14 | // betampt 15 | List betampt(int M, int L, int nthin, arma::mat H, arma::mat a, arma::mat b, arma::vec c, arma::vec map, arma::vec shape, arma::vec rate); 16 | RcppExport SEXP _TreeBUGS_betampt(SEXP MSEXP, SEXP LSEXP, SEXP nthinSEXP, SEXP HSEXP, SEXP aSEXP, SEXP bSEXP, SEXP cSEXP, SEXP mapSEXP, SEXP shapeSEXP, SEXP rateSEXP) { 17 | BEGIN_RCPP 18 | Rcpp::RObject rcpp_result_gen; 19 | Rcpp::RNGScope rcpp_rngScope_gen; 20 | Rcpp::traits::input_parameter< int >::type M(MSEXP); 21 | Rcpp::traits::input_parameter< int >::type L(LSEXP); 22 | Rcpp::traits::input_parameter< int >::type nthin(nthinSEXP); 23 | Rcpp::traits::input_parameter< arma::mat >::type H(HSEXP); 24 | Rcpp::traits::input_parameter< arma::mat >::type a(aSEXP); 25 | Rcpp::traits::input_parameter< arma::mat >::type b(bSEXP); 26 | Rcpp::traits::input_parameter< arma::vec >::type c(cSEXP); 27 | Rcpp::traits::input_parameter< arma::vec >::type map(mapSEXP); 28 | Rcpp::traits::input_parameter< arma::vec >::type shape(shapeSEXP); 29 | Rcpp::traits::input_parameter< arma::vec >::type rate(rateSEXP); 30 | rcpp_result_gen = Rcpp::wrap(betampt(M, L, nthin, H, a, b, c, map, shape, rate)); 31 | return rcpp_result_gen; 32 | END_RCPP 33 | } 34 | // simplempt 35 | List simplempt(int M, int L, int nthin, arma::mat H, arma::mat a, arma::mat b, arma::vec c, arma::vec map, arma::vec alpha, arma::vec beta); 36 | RcppExport SEXP _TreeBUGS_simplempt(SEXP MSEXP, SEXP LSEXP, SEXP nthinSEXP, SEXP HSEXP, SEXP aSEXP, SEXP bSEXP, SEXP cSEXP, SEXP mapSEXP, SEXP alphaSEXP, SEXP betaSEXP) { 37 | BEGIN_RCPP 38 | Rcpp::RObject rcpp_result_gen; 39 | Rcpp::RNGScope rcpp_rngScope_gen; 40 | Rcpp::traits::input_parameter< int >::type M(MSEXP); 41 | Rcpp::traits::input_parameter< int >::type L(LSEXP); 42 | Rcpp::traits::input_parameter< int >::type nthin(nthinSEXP); 43 | Rcpp::traits::input_parameter< arma::mat >::type H(HSEXP); 44 | Rcpp::traits::input_parameter< arma::mat >::type a(aSEXP); 45 | Rcpp::traits::input_parameter< arma::mat >::type b(bSEXP); 46 | Rcpp::traits::input_parameter< arma::vec >::type c(cSEXP); 47 | Rcpp::traits::input_parameter< arma::vec >::type map(mapSEXP); 48 | Rcpp::traits::input_parameter< arma::vec >::type alpha(alphaSEXP); 49 | Rcpp::traits::input_parameter< arma::vec >::type beta(betaSEXP); 50 | rcpp_result_gen = Rcpp::wrap(simplempt(M, L, nthin, H, a, b, c, map, alpha, beta)); 51 | return rcpp_result_gen; 52 | END_RCPP 53 | } 54 | // loglikMPT 55 | arma::vec loglikMPT(arma::mat theta, arma::vec h, arma::mat a, arma::mat b, arma::vec c, arma::vec map); 56 | RcppExport SEXP _TreeBUGS_loglikMPT(SEXP thetaSEXP, SEXP hSEXP, SEXP aSEXP, SEXP bSEXP, SEXP cSEXP, SEXP mapSEXP) { 57 | BEGIN_RCPP 58 | Rcpp::RObject rcpp_result_gen; 59 | Rcpp::RNGScope rcpp_rngScope_gen; 60 | Rcpp::traits::input_parameter< arma::mat >::type theta(thetaSEXP); 61 | Rcpp::traits::input_parameter< arma::vec >::type h(hSEXP); 62 | Rcpp::traits::input_parameter< arma::mat >::type a(aSEXP); 63 | Rcpp::traits::input_parameter< arma::mat >::type b(bSEXP); 64 | Rcpp::traits::input_parameter< arma::vec >::type c(cSEXP); 65 | Rcpp::traits::input_parameter< arma::vec >::type map(mapSEXP); 66 | rcpp_result_gen = Rcpp::wrap(loglikMPT(theta, h, a, b, c, map)); 67 | return rcpp_result_gen; 68 | END_RCPP 69 | } 70 | -------------------------------------------------------------------------------- /man/simpleMPT.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/fitSimpleMPT.R 3 | \name{simpleMPT} 4 | \alias{simpleMPT} 5 | \title{C++ Sampler for Standard (Nonhierarchical) MPT Models} 6 | \usage{ 7 | simpleMPT( 8 | eqnfile, 9 | data, 10 | restrictions, 11 | n.iter = 2000, 12 | n.burnin = 500, 13 | n.thin = 3, 14 | n.chains = 3, 15 | ppp = 0, 16 | alpha = 1, 17 | beta = 1, 18 | parEstFile, 19 | posteriorFile, 20 | cores = 1 21 | ) 22 | } 23 | \arguments{ 24 | \item{eqnfile}{The (relative or full) path to the file that specifies the MPT 25 | model (standard .eqn syntax). Note that category labels must start with a 26 | letter (different to multiTree) and match the column names of \code{data}. 27 | Alternatively, the EQN-equations can be provided within R as a character 28 | value (cf. \code{\link{readEQN}}). Note that the first line of an .eqn-file 29 | is reserved for comments and always ignored.} 30 | 31 | \item{data}{The (relative or full) path to the .csv file with the data (comma 32 | separated; category labels in first row). Alternatively: a data frame or 33 | matrix (rows=individuals, columns = individual category frequencies, 34 | category labels as column names)} 35 | 36 | \item{restrictions}{Specifies which parameters should be (a) constant (e.g., 37 | \code{"a=b=.5"}) or (b) constrained to be identical (e.g., \code{"Do=Dn"}) 38 | or (c) treated as fixed effects (i.e., identical for all participants; 39 | \code{"a=b=FE"}). Either given as the path to a text file with restrictions 40 | per row or as a list of restrictions, e.g., \code{list("D1=D2","g=0.5")}. 41 | Note that numbers in .eqn-equations (e.g., \code{d*(1-g)*.50}) are directly 42 | interpreted as equality constraints.} 43 | 44 | \item{n.iter}{Number of iterations per chain (including burnin samples). See 45 | \code{\link[runjags]{run.jags}} for details.} 46 | 47 | \item{n.burnin}{Number of samples for burnin (samples will not be stored and 48 | removed from n.iter)} 49 | 50 | \item{n.thin}{Thinning rate.} 51 | 52 | \item{n.chains}{number of MCMC chains (sampled in parallel, which can be 53 | changed via the additional argument \code{n.sim = 1}).} 54 | 55 | \item{ppp}{number of samples to compute posterior predictive p-value (see 56 | \code{\link{posteriorPredictive}})} 57 | 58 | \item{alpha}{first shape parameter(s) for the beta prior-distribution of the 59 | MPT parameters \eqn{\theta_s} (can be a named vector to use a different 60 | prior for each MPT parameter)} 61 | 62 | \item{beta}{second shape parameter(s)} 63 | 64 | \item{parEstFile}{Name of the file to with the estimates should be stored 65 | (e.g., "parEstFile.txt")} 66 | 67 | \item{posteriorFile}{path to RData-file where to save the model including 68 | MCMC posterior samples (an object named \code{fittedModel}; e.g., 69 | \code{posteriorFile="mcmc.RData"})} 70 | 71 | \item{cores}{number of CPUs to be used} 72 | } 73 | \description{ 74 | Fast Gibbs sampler in C++ that is tailored to the standard fixed-effects MPT 75 | model (i.e., fixed-effects, non-hierarchical MPT). Assumes independent 76 | parameters per person if a matrix of frequencies per person is supplied. 77 | } 78 | \details{ 79 | Beta distributions with fixed shape parameters \eqn{\alpha} and 80 | \eqn{\beta} are used. The default \eqn{\alpha=1} and \eqn{\beta=1} assumes 81 | uniform priors for all MPT parameters. 82 | } 83 | \examples{ 84 | \dontrun{ 85 | # fit nonhierarchical MPT model for aggregated data (see ?arnold2013): 86 | EQNfile <- system.file("MPTmodels/2htsm.eqn", package = "TreeBUGS") 87 | d.encoding <- subset(arnold2013, group == "encoding", select = -(1:4)) 88 | fit <- simpleMPT(EQNfile, colSums(d.encoding), 89 | restrictions = list("D1=D2=D3", "d1=d2", "a=g") 90 | ) 91 | # convergence 92 | plot(fit) 93 | summary(fit) 94 | } 95 | } 96 | \author{ 97 | Daniel Heck 98 | } 99 | -------------------------------------------------------------------------------- /R/parseRestrictions.R: -------------------------------------------------------------------------------- 1 | 2 | 3 | parseRestrictions <- function(mpt, restrictions) { 4 | # thetaNames <- data.frame(Parameter = colnames(mpt$a), 5 | # theta=1:nrow(mpt$a)) 6 | 7 | mpt$c <- rep(1, nrow(mpt$a)) 8 | 9 | ############################### constraints in MPT file (e.g., .5*Do ) 10 | 11 | suppressWarnings(parConst <- as.numeric(colnames(mpt$a))) 12 | numConst <- sum(!is.na(parConst)) 13 | if (numConst > 0) { 14 | idx <- which(!is.na(parConst)) 15 | for (s in 1:numConst) { 16 | mpt$c <- mpt$c * 17 | parConst[idx[s]]^mpt$a[, idx[s]] * 18 | (1 - parConst[idx[s]])^mpt$b[, idx[s]] 19 | } 20 | mpt$a <- mpt$a[, -idx, drop = FALSE] 21 | mpt$b <- mpt$b[, -idx, drop = FALSE] 22 | } 23 | 24 | ############################### Contraints in list "restrictions" 25 | 26 | parLabels <- colnames(mpt$a) 27 | 28 | if (!is.null(restrictions)) { 29 | # restrictions given as a list 30 | if (is.list(restrictions)) { 31 | restrVector <- as.vector(unlist(restrictions)) 32 | # restrictions given as a model file 33 | } else { 34 | restrVector <- read.csv(restrictions, header = F, stringsAsFactors = F)$V1 35 | restrictions <- as.list(restrVector) 36 | } 37 | restrVector <- gsub(" ", "", restrVector, fixed = TRUE) 38 | 39 | 40 | for (k in 1:length(restrVector)) { 41 | splitRestr <- strsplit(restrVector[k], "=")[[1]] 42 | if (length(splitRestr) == 1) { 43 | warning("Restriction not well defined: Equality sign '=' missing in:\n ", splitRestr) 44 | } else { 45 | ######### equality constraints 46 | 47 | index <- match(splitRestr, colnames(mpt$a)) 48 | suppressWarnings(consts <- as.numeric(splitRestr)) 49 | 50 | if (all(is.na(consts))) { 51 | # only parameters without constants 52 | if (any(is.na(index))) { 53 | error <- paste0( 54 | "Restriction contains parameters not contained in the model:\n ", 55 | paste(splitRestr, collapse = "=") 56 | ) 57 | stop(error) 58 | } 59 | 60 | # thetaNames$theta[index[2:length(index)]] <- index[1] 61 | 62 | # replace index 63 | # mpt$a[,index[1]] <- rowSums(mpt$a[,index]) 64 | # mpt$b[,index[1]] <- rowSums(mpt$b[,index]) 65 | # mpt$a <- mpt$a[,-index[2:length(index)],drop =FALSE] 66 | # mpt$b <- mpt$b[,-index[2:length(index)],drop =FALSE] 67 | mpt$a[, min(index)] <- rowSums(mpt$a[, index]) 68 | mpt$b[, min(index)] <- rowSums(mpt$b[, index]) 69 | mpt$a <- mpt$a[, -index[-which.min(index)], drop = FALSE] 70 | mpt$b <- mpt$b[, -index[-which.min(index)], drop = FALSE] 71 | } else if (sum(!is.na(consts)) == 1) { 72 | # contrained to a single constant value 73 | CONST <- consts[!is.na(consts)] 74 | if (CONST < 0 | CONST > 1) { 75 | error <- paste0( 76 | "Check parameter restrictions. Constants are not in the interval [0,1]: ", 77 | restrVector[k] 78 | ) 79 | warning(error) 80 | } 81 | 82 | mpt$c <- mpt$c * 83 | apply(CONST^mpt$a[, index[!is.na(index)], drop = FALSE] * 84 | (1 - CONST)^mpt$b[, index[!is.na(index)], drop = FALSE], 1, prod) 85 | 86 | mpt$a <- mpt$a[, -index[!is.na(index)], drop = FALSE] 87 | mpt$b <- mpt$b[, -index[!is.na(index)], drop = FALSE] 88 | 89 | # thetaNames <- thetaNames[,] $theta[index[2:length(index)]] <- index[1] 90 | } else { 91 | stop("Restrictions should not contain more than one constant!") 92 | } 93 | } 94 | } 95 | } 96 | # mpt$thetaNames <- thetaNames 97 | 98 | mpt 99 | } 100 | -------------------------------------------------------------------------------- /R/transformedParModelfile.R: -------------------------------------------------------------------------------- 1 | 2 | 3 | # get quantities of interest / transformed parameters 4 | 5 | # returns the vector of parameters that needs to be sampled and the appropriate model string for JAGS 6 | 7 | ##### deprecated: model: either "betaMPT" or "traitMPT" 8 | # thetaNames: matrix which assigns parameter labels (first column) to the parameter index (second column) 9 | # transformedParameters: either string with file location or list with transformed parameters 10 | getTransformed <- function(thetaNames, transformedParameters = NULL, 11 | mergeString = TRUE) { 12 | if (is.null(transformedParameters)) { 13 | return(list( 14 | transformedParameters = NULL, 15 | modelstring = "\n### No tranformed parameters specified # \n" 16 | )) 17 | } 18 | transformedParameters <- readTransformedParam(transformedParameters) 19 | splitEqual <- sapply(transformedParameters, strsplit, split = "=", fixed = TRUE) 20 | pars <- sapply(splitEqual, function(x) x[1]) 21 | 22 | S <- length(pars) 23 | selCriticalName <- pars %in% c( 24 | thetaNames, 25 | "mu", "sd", "mu", "sigma", 26 | "beta", "alpha", "rho", "theta", "xi" 27 | ) 28 | if (any(selCriticalName)) { 29 | error <- paste0( 30 | "Use different label for transformed parameters:\n ", 31 | paste(pars[selCriticalName], collapse = ", ") 32 | ) 33 | stop(error) 34 | } 35 | 36 | if (length(unique(pars)) != S) { 37 | stop("The argument 'transformedParameters' does not specifcy unique names for the transformed parameters") 38 | } 39 | 40 | index_by_length <- order(sapply(thetaNames$Parameter, nchar), decreasing = TRUE) 41 | modelstring <- ifelse(mergeString, "### Transformed Parameters (on group level) ###\n", "") 42 | for (i in 1:S) { 43 | replacedString <- splitEqual[[i]][2] 44 | for (k in 1:nrow(thetaNames)) { 45 | replacedString <- gsub( 46 | pattern = paste0("\\b", thetaNames[index_by_length[k], 1], "\\b"), 47 | replacement = paste0("XXXXXXXXXXXXXX[", thetaNames[index_by_length[k], 2], "]"), 48 | x = replacedString 49 | ) 50 | } 51 | # test whether transformed parameters are proper function: (not working at the moment) 52 | test <- try(eval( 53 | parse(text = replacedString), 54 | list("XXXXXXXXXXXXXX" = runif(nrow(thetaNames))) 55 | ), silent = TRUE) 56 | if (inherits(test, "try-error")) { 57 | error <- paste0( 58 | "Check transformedParameter: ", pars[i], 59 | ".\n Function may contain an invalid equation or unknown model parameters.", 60 | "\n Currently, it is defined as: \n ", 61 | gsub("XXXXXXXXXXXXXX", "mean", replacedString) 62 | ) 63 | warning(error) 64 | } 65 | if (mergeString) { 66 | modelstring <- paste(modelstring, "\n", pars[i], "<-", replacedString) 67 | } else { 68 | modelstring[i] <- replacedString 69 | } 70 | } 71 | if (mergeString) { 72 | modelstring <- paste(modelstring, "\n") 73 | } 74 | modelstring <- gsub("XXXXXXXXXXXXXX", "mean", modelstring) 75 | 76 | list( 77 | transformedParameters = pars, 78 | modelstring = modelstring 79 | ) 80 | } 81 | 82 | 83 | 84 | readTransformedParam <- function(transformedParameters) { 85 | if (is.character(transformedParameters)) { 86 | # read file: 87 | try(tmp <- readLines(transformedParameters, skipNul = TRUE)) 88 | transformedParameters <- as.list(tmp[tmp != "" & !grepl("#", tmp)]) 89 | } else if (!is.list(transformedParameters)) { 90 | warning( 91 | "The argument 'transformedParameters' must either be a list\n", 92 | "of parameter transformations or the path to such a file." 93 | ) 94 | } 95 | transformedParameters <- lapply( 96 | transformedParameters, 97 | function(xx) gsub(" ", "", xx, fixed = TRUE) 98 | ) 99 | 100 | transformedParameters 101 | } 102 | -------------------------------------------------------------------------------- /R/getParam.R: -------------------------------------------------------------------------------- 1 | #' Get Parameter Posterior Statistics 2 | #' 3 | #' Returns posterior statistics (e.g., mean, median) for the parameters of a 4 | #' hierarchical MPT model. 5 | #' 6 | #' @param fittedModel a fitted latent-trait MPT model (see 7 | #' \code{\link{traitMPT}}) or beta MPT model (see \code{\link{betaMPT}}) 8 | #' @param parameter which parameter(s) of the (hierarchical) MPT model should be 9 | #' returned? (see details in \code{\link{getParam}}). 10 | #' @param stat whether to get the posterior \code{"mean"}, \code{"median"}, 11 | #' \code{"sd"}, or \code{"summary"} (includes mean, SD, and 95\% credibility 12 | #' interval) 13 | #' @param file filename to export results in .csv format (e.g., 14 | #' \code{file="est_param.csv"}) 15 | #' 16 | #' @details This function is a convenient way to get the information stored in 17 | #' \code{fittedModel$mcmc.summ}. 18 | #' 19 | #' The latent-trait MPT includes the following parameters: 20 | #' \itemize{ 21 | #' \item \code{"mean"} (group means on probability scale) 22 | #' \item \code{"mu"} (group means on probit scale) 23 | #' \item \code{"sigma"} (SD on probit scale) 24 | #' \item \code{"rho"} (correlations on probit scale) 25 | #' \item \code{"theta"} (individual MPT parameters) 26 | #' } 27 | #' 28 | #' The beta MPT includes the following parameters: 29 | #' \itemize{ 30 | #' \item \code{"mean"} (group means on probability scale) 31 | #' \item \code{"sd"} (SD on probability scale) 32 | #' \item \code{"alph"},\code{"bet"} (group parameters of beta distribution) 33 | #' \item \code{"theta"} (individual MPT parameters) 34 | #' } 35 | #' 36 | #' @author Daniel Heck 37 | #' @seealso \code{\link{getGroupMeans}} mean group estimates 38 | #' 39 | #' @examples 40 | #' \dontrun{ 41 | #' # mean estimates per person: 42 | #' getParam(fittedModel, parameter = "theta") 43 | #' 44 | #' # save summary of individual estimates: 45 | #' getParam(fittedModel, 46 | #' parameter = "theta", 47 | #' stat = "summary", file = "ind_summ.csv" 48 | #' ) 49 | #' } 50 | #' @export 51 | getParam <- function( 52 | fittedModel, 53 | parameter = "mean", 54 | stat = "mean", 55 | file = NULL 56 | ) { 57 | if (!inherits(fittedModel, c("betaMPT", "traitMPT"))) { 58 | stop("Only for hierarchical MPT models (see ?traitMPT & ?betaMPT).") 59 | } 60 | 61 | thetaUnique <- fittedModel$mptInfo$thetaUnique 62 | S <- length(thetaUnique) 63 | summ <- fittedModel$mcmc.summ # summary(fittedModel$mcmc) 64 | allnam <- rownames(summ) 65 | select <- setdiff(grep(parameter, allnam), grep(".pred", allnam)) 66 | if (length(select) == 0) { 67 | stop("parameter not found.") 68 | } 69 | 70 | label <- c("Mean", "SD", "2.5%", "97.5%") 71 | sel.stat <- switch(stat, 72 | "mean" = "Mean", 73 | "sd" = "SD", 74 | "median" = "50%", 75 | "summary" = label, 76 | stop("statistic not supported.") 77 | ) 78 | par <- summ[select, sel.stat, drop = FALSE] 79 | 80 | if (stat != "summary") { 81 | if (length(par) == S) { 82 | rownames(par) <- paste0( 83 | grep(parameter, allnam, value = TRUE), 84 | names(par), "_", thetaUnique 85 | ) 86 | } else if (parameter == "theta") { 87 | par <- matrix(par, ncol = S, byrow = TRUE) 88 | colnames(par) <- thetaUnique 89 | rownames(par) <- rownames(fittedModel$mptInfo$data) 90 | } else if (parameter == "rho") { 91 | par <- getRhoMatrix(thetaUnique, par) 92 | } 93 | } else { 94 | if (length(select) == S) { 95 | rownames(par) <- paste0( 96 | grep(parameter, allnam, value = TRUE), 97 | rownames(par), "_", thetaUnique 98 | ) 99 | } else if (parameter == "theta") { 100 | par <- matrix(t(par), ncol = S * 4, byrow = TRUE) 101 | colnames(par) <- paste0(rep(thetaUnique, each = 4), "_", label) 102 | } 103 | } 104 | 105 | if (!is.null(file)) { 106 | if (is.null(dim(par))) par <- t(par) 107 | write.csv(par, file = file, row.names = FALSE) 108 | } 109 | 110 | par 111 | } 112 | -------------------------------------------------------------------------------- /man/readEQN.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/readEQN.R 3 | \name{readEQN} 4 | \alias{readEQN} 5 | \title{Read multiTree files} 6 | \usage{ 7 | readEQN(file, restrictions = NULL, paramOrder = FALSE, parse = FALSE) 8 | } 9 | \arguments{ 10 | \item{file}{The (full path to the) file that specifies the MPT model 11 | (standard .eqn syntax). Note that category labels must start with a letter 12 | (different to multiTree) and match the column names of \code{data}. 13 | Alternatively, the EQN-equations can be provided within R as a character 14 | value (see examples). Note that the first line of an .eqn-file is reserved 15 | for comments and always ignored.} 16 | 17 | \item{restrictions}{Specifies which parameters should be (a) constant (e.g., 18 | \code{"a=b=.5"}) or (b) constrained to be identical (e.g., \code{"Do=Dn"}) 19 | or (c) treated as fixed effects (i.e., identical for all participants; 20 | \code{"a=b=FE"}). Either given as the path to a text file with restrictions 21 | per row or as a list of restrictions, e.g., \code{list("D1=D2","g=0.5")}. 22 | Note that numbers in .eqn-equations (e.g., \code{d*(1-g)*.50}) are directly 23 | interpreted as equality constraints.} 24 | 25 | \item{paramOrder}{if TRUE, the order of MPT parameters as interally used is 26 | printed.} 27 | 28 | \item{parse}{whether to return a parsed MPT model description in terms of the 29 | matrices \eqn{a} and \eqn{b} (the powers of the \eqn{\theta} and 30 | \eqn{(1-\theta)}, respectively, and the vector of constants \eqn{c}. Each 31 | branch probability is then given as \eqn{c_{i} \prod_{s} 32 | \theta^{a_{i,s}}(1-\theta)^{b_{i,s}})}} 33 | } 34 | \value{ 35 | for the default setting \code{parse = FALSE}, the function returns a \code{data.frame} with the following columns: 36 | \itemize{ 37 | \item \code{Tree}: the tree label 38 | \item \code{Category}: the category label (must match the columns in the data set) 39 | \item \code{Equation}: the model equation without parameter restrictions 40 | \item \code{EQN}: the model equation with restricted parameters replaced 41 | } 42 | } 43 | \description{ 44 | Function to import MPT models from standard .eqn model files as used, for 45 | instance, by multiTree (Moshagen, 2010). 46 | } 47 | \details{ 48 | The file format should adhere to the standard .eqn-syntax (note that 49 | the first line is skipped and can be used for comments). In each line, a 50 | separate branch of the MPT model is specified using the tree label, 51 | category label, and the model equations in full form (multiplication sign 52 | \code{*} required; not abbreviations such as \code{a^2} allowed). 53 | 54 | As an example, the standard two-high threshold model (2HTM) is defined as 55 | follows: 56 | 57 | \tabular{lllll}{ 58 | \code{Target } \tab \tab \code{Hit} \tab \tab \code{Do} \cr 59 | \code{Target} \tab \tab \code{Hit} \tab \tab \code{(1-Do)*g} \cr 60 | \code{Target} \tab \tab \code{Miss} \tab \tab \code{(1-Do)*(1-g)} \cr 61 | \code{Lure} \tab \tab \code{FalseAlarm} \tab \tab \code{(1-Dn)*g} \cr 62 | \code{Lure} \tab \tab \code{CorrectReject} \tab \tab \code{(1-Dn)*(1-g)} \cr 63 | \code{Lure} \tab \tab \code{CorrectReject } \tab \tab \code{Dn} 64 | } 65 | } 66 | \examples{ 67 | # Example: Standard Two-High-Threshold Model (2HTM) 68 | EQNfile <- system.file("MPTmodels/2htm.eqn", 69 | package = "TreeBUGS" 70 | ) 71 | readEQN(file = EQNfile, paramOrder = TRUE) 72 | 73 | # with equality constraint: 74 | readEQN( 75 | file = EQNfile, restrictions = list("Dn = Do", "g = 0.5"), 76 | paramOrder = TRUE 77 | ) 78 | 79 | # define MPT model directly within R 80 | model <- 81 | "2-High Threshold Model (2HTM) 82 | old hit d 83 | old hit (1-d)*g 84 | old miss (1-d)*(1-g) 85 | new fa (1-d)*g 86 | new cr (1-d)*(1-g) 87 | new cr d" 88 | readEQN(model, paramOrder = TRUE) 89 | } 90 | \references{ 91 | Moshagen, M. (2010). multiTree: A computer program for the 92 | analysis of multinomial processing tree models. Behavior Research Methods, 93 | 42, 42-54. 94 | } 95 | \author{ 96 | Daniel Heck, Denis Arnold, Nina Arnold 97 | } 98 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2: do not edit by hand 2 | 3 | S3method("-",waic) 4 | S3method(plot,betaMPT) 5 | S3method(plot,simpleMPT) 6 | S3method(plot,traitMPT) 7 | S3method(print,betaMPT) 8 | S3method(print,betweenMPT) 9 | S3method(print,postPredP) 10 | S3method(print,simpleMPT) 11 | S3method(print,summary.betaMPT) 12 | S3method(print,summary.simpleMPT) 13 | S3method(print,summary.traitMPT) 14 | S3method(print,traitMPT) 15 | S3method(print,waic) 16 | S3method(print,waic_difference) 17 | S3method(summary,betaMPT) 18 | S3method(summary,simpleMPT) 19 | S3method(summary,traitMPT) 20 | export(BayesFactorMPT) 21 | export(BayesFactorSlope) 22 | export(PPP) 23 | export(WAIC) 24 | export(betaMPT) 25 | export(betaMPTcpp) 26 | export(betweenSubjectMPT) 27 | export(correlationPosterior) 28 | export(extendMPT) 29 | export(genBetaMPT) 30 | export(genMPT) 31 | export(genTraitMPT) 32 | export(getGroupMeans) 33 | export(getParam) 34 | export(getSamples) 35 | export(marginalMPT) 36 | export(plotDistribution) 37 | export(plotFit) 38 | export(plotFreq) 39 | export(plotParam) 40 | export(plotPrior) 41 | export(plotPriorPost) 42 | export(posteriorPredictive) 43 | export(priorPredictive) 44 | export(probitInverse) 45 | export(readEQN) 46 | export(simpleMPT) 47 | export(summarizeMCMC) 48 | export(summarizeMPT) 49 | export(testHetChi) 50 | export(testHetPerm) 51 | export(traitMPT) 52 | export(transformedParameters) 53 | export(withinSubjectEQN) 54 | import(rjags) 55 | importFrom(MASS,fitdistr) 56 | importFrom(MASS,mvrnorm) 57 | importFrom(Rcpp,evalCpp) 58 | importFrom(Rcpp,sourceCpp) 59 | importFrom(coda,acfplot) 60 | importFrom(coda,as.mcmc) 61 | importFrom(coda,as.mcmc.list) 62 | importFrom(coda,autocorr.plot) 63 | importFrom(coda,crosscorr.plot) 64 | importFrom(coda,densplot) 65 | importFrom(coda,effectiveSize) 66 | importFrom(coda,gelman.diag) 67 | importFrom(coda,gelman.plot) 68 | importFrom(coda,mcmc) 69 | importFrom(coda,mcmc.list) 70 | importFrom(coda,nchain) 71 | importFrom(coda,niter) 72 | importFrom(coda,nvar) 73 | importFrom(coda,traceplot) 74 | importFrom(coda,varnames) 75 | importFrom(grDevices,adjustcolor) 76 | importFrom(grDevices,rainbow) 77 | importFrom(graphics,abline) 78 | importFrom(graphics,axis) 79 | importFrom(graphics,boxplot) 80 | importFrom(graphics,curve) 81 | importFrom(graphics,hist) 82 | importFrom(graphics,lines) 83 | importFrom(graphics,par) 84 | importFrom(graphics,plot) 85 | importFrom(graphics,points) 86 | importFrom(graphics,segments) 87 | importFrom(hypergeo,genhypergeo) 88 | importFrom(hypergeo,hypergeo) 89 | importFrom(logspline,dlogspline) 90 | importFrom(logspline,logspline) 91 | importFrom(parallel,clusterEvalQ) 92 | importFrom(parallel,clusterExport) 93 | importFrom(parallel,clusterMap) 94 | importFrom(parallel,clusterSplit) 95 | importFrom(parallel,detectCores) 96 | importFrom(parallel,makeCluster) 97 | importFrom(parallel,parApply) 98 | importFrom(parallel,parLapply) 99 | importFrom(parallel,parSapply) 100 | importFrom(parallel,stopCluster) 101 | importFrom(rjags,coda.samples) 102 | importFrom(rjags,jags.model) 103 | importFrom(rjags,jags.samples) 104 | importFrom(rjags,load.module) 105 | importFrom(runjags,autoextend.jags) 106 | importFrom(runjags,extend.jags) 107 | importFrom(runjags,extract) 108 | importFrom(runjags,run.jags) 109 | importFrom(stats,ave) 110 | importFrom(stats,cor) 111 | importFrom(stats,cov) 112 | importFrom(stats,cov2cor) 113 | importFrom(stats,dbeta) 114 | importFrom(stats,dcauchy) 115 | importFrom(stats,density) 116 | importFrom(stats,dnorm) 117 | importFrom(stats,integrate) 118 | importFrom(stats,pchisq) 119 | importFrom(stats,pnorm) 120 | importFrom(stats,qnorm) 121 | importFrom(stats,quantile) 122 | importFrom(stats,rWishart) 123 | importFrom(stats,rbeta) 124 | importFrom(stats,rbinom) 125 | importFrom(stats,rmultinom) 126 | importFrom(stats,rnorm) 127 | importFrom(stats,runif) 128 | importFrom(stats,sd) 129 | importFrom(stats,var) 130 | importFrom(stats,window) 131 | importFrom(utils,capture.output) 132 | importFrom(utils,combn) 133 | importFrom(utils,count.fields) 134 | importFrom(utils,read.csv) 135 | importFrom(utils,write.csv) 136 | importFrom(utils,write.table) 137 | useDynLib("TreeBUGS", .registration=TRUE) 138 | -------------------------------------------------------------------------------- /R/genDataMPT.R: -------------------------------------------------------------------------------- 1 | #' Generate MPT Frequencies 2 | #' 3 | #' Uses a matrix of individual MPT parameters to generate MPT frequencies. 4 | #' 5 | #' @param theta matrix of MPT parameters (rows: individuals; columns: 6 | #' parameters). Parameters are assigned by column names of the matrix. all of 7 | #' the parameters in the model file need to be included. 8 | #' @param numItems number of responses per tree (a named vector with tree 9 | #' labels) 10 | #' @inheritParams betaMPT 11 | #' @param warning whether to show warning in case the naming of data-generating 12 | #' parameters are unnamed or do not match 13 | #' @seealso \code{\link{genTraitMPT}} and \code{\link{genBetaMPT}} to generate 14 | #' data for latent normal/beta hierarchical distributions. 15 | #' 16 | #' @examples 17 | #' # Example: Standard Two-High-Threshold Model (2HTM) 18 | #' EQNfile <- system.file("MPTmodels/2htm.eqn", package = "TreeBUGS") 19 | #' theta <- matrix( 20 | #' c( 21 | #' .8, .4, .5, 22 | #' .6, .3, .4 23 | #' ), 24 | #' nrow = 2, byrow = TRUE, 25 | #' dimnames = list(NULL, c("Do", "Dn", "g")) 26 | #' ) 27 | #' genDat <- genMPT( 28 | #' theta, c(Target = 250, Lure = 250), 29 | #' EQNfile 30 | #' ) 31 | #' genDat 32 | #' @export 33 | genMPT <- function( 34 | theta, 35 | numItems, 36 | eqnfile, 37 | restrictions, 38 | warning = TRUE 39 | ) { 40 | if (missing(restrictions)) { 41 | restrictions <- NULL 42 | } 43 | 44 | # read EQN 45 | # REMINDER 2024-04: restrictions were ineffective in readEQN(); only processed by thetaHandling 46 | Tree <- readEQN(eqnfile) 47 | mergedTree <- mergeBranches(Tree) 48 | Tree.restr <- thetaHandling(mergedTree, restrictions) 49 | thetaNames <- Tree.restr$SubPar[, 1:2] 50 | thetaNames <- thetaNames[rownames(unique(thetaNames[2])), ]$Parameter 51 | treeLabels <- unique(mergedTree$Tree) 52 | 53 | # get number of parmaeters/number of participants 54 | S <- length(thetaNames) 55 | if (is.vector(theta)) { 56 | theta <- matrix(theta, 1, dimnames = list(NULL, names(theta))) 57 | } 58 | N <- nrow(theta) 59 | 60 | ################### check input + default values 61 | if (is.null(colnames(theta))) { 62 | if (warning) { 63 | warning( 64 | "Colnames for theta are missing. Parameters are assigned by default as:\n ", 65 | paste(thetaNames, collapse = ", ") 66 | ) 67 | } 68 | colnames(theta) <- thetaNames 69 | } 70 | if (is.null(names(numItems))) { 71 | if (warning) { 72 | warning( 73 | "Tree labels for numitems are missing. Tree labels are assigned by default as:\n ", 74 | paste(treeLabels, collapse = ", ") 75 | ) 76 | } 77 | names(numItems) <- treeLabels 78 | } else { 79 | names(numItems) <- paste0("T_", names(numItems)) 80 | } 81 | theta <- checkThetaNames(theta, thetaNames) 82 | numItems <- checkNumItems(numItems, treeLabels) 83 | 84 | 85 | # matrix of response frequencies 86 | freq <- matrix(NA, N, nrow(mergedTree), 87 | dimnames = list(NULL, mergedTree$Category) 88 | ) 89 | # consts <- Tree.restr$constants$sub 90 | # if(length(consts)>0) 91 | # names(consts) <- Tree.restr$constants$Parameter 92 | colnames(theta) <- paste0("theta[", 1:S, "]") 93 | eq <- gsub(",n", "", Tree.restr$mergedTree$Equation, fixed = TRUE) 94 | for (n in 1:N) { 95 | mergedTree$prob <- sapply(eq, function(ff) { 96 | eval( 97 | parse(text = ff), 98 | list(theta = theta[n, ]) 99 | ) 100 | }) 101 | 102 | numTrees <- length(unique(mergedTree$Tree)) 103 | for (k in 1:numTrees) { 104 | sel <- mergedTree$Tree %in% names(numItems)[k] 105 | # cat <- findInterval(runif(numItems[k]), cumsum(mergedTree$prob[sel]))+1 106 | # catLabel <- mergedTree$Category[sel][cat] 107 | freq[n, mergedTree$Category[sel]] <- rmultinom(1, 108 | size = numItems[k], 109 | prob = mergedTree$prob[sel] 110 | ) 111 | # table(factor(catLabel, 112 | # levels=mergedTree$Category[sel]), 113 | # exclude=NA) 114 | } 115 | } 116 | 117 | return(freq) 118 | } 119 | -------------------------------------------------------------------------------- /R/plotFrequencies.R: -------------------------------------------------------------------------------- 1 | #' Plot Raw Frequencies 2 | #' 3 | #' Plot observed individual and mean frequencies. 4 | #' 5 | #' @param x either a fitted hierarchical MPT model (see \code{\link{traitMPT}}, 6 | #' \code{\link{betaMPT}}); or a matrix/data frame of response frequencies (can 7 | #' be provided as a path to a .csv-file with individual frequencies). 8 | #' @param freq whether to plot absolute frequencies or relative frequencies 9 | #' (which sum up to one within each tree; only if \code{x} is a hierarchical 10 | #' model or if \code{eqnfile} is provided) 11 | #' @param select a numeric vector with participant indices to select which raw 12 | #' frequencies to plot (default: \code{"all"}) 13 | #' @param boxplot if \code{FALSE}, lines and points are drawn instead of 14 | #' boxplots 15 | #' @param eqnfile optional: EQN description of an MPT model, that is, either the 16 | #' path to an EQN file or as a character string (only used if \code{x} refers 17 | #' to a matrix/data frame or .csv-file) 18 | #' @param ... further arguments passed to \code{boxplot} and \code{plot} 19 | #' 20 | #' @examples 21 | #' # get frequency data and EQN file 22 | #' freq <- subset(arnold2013, group == "encoding", select = -(1:4)) 23 | #' eqn <- system.file("MPTmodels/2htsm.eqn", package = "TreeBUGS") 24 | #' plotFreq(freq, eqnfile = eqn) 25 | #' plotFreq(freq, freq = FALSE, eqnfile = eqn) 26 | #' @export 27 | plotFreq <- function( 28 | x, 29 | freq = TRUE, 30 | select = "all", 31 | boxplot = TRUE, 32 | eqnfile, 33 | ... 34 | ) { 35 | if (inherits(x, c("betaMPT", "traitMPT"))) { 36 | dat <- x$mptInfo$data 37 | } else if (inherits(x, "character")) { 38 | dat <- read.csv(x) 39 | } else { 40 | try(dat <- as.data.frame(x)) 41 | } 42 | 43 | if (inherits(x, c("betaMPT", "traitMPT"))) { 44 | treeNames <- x$mptInfo$MPT$Tree 45 | treeLabels <- unique(treeNames) 46 | } else if (!missing(eqnfile)) { 47 | tmp <- unique(readEQN(eqnfile)[, 1:2]) 48 | treeNames <- tmp$Tree 49 | treeLabels <- unique(treeNames) 50 | try(dat <- dat[, colnames(dat) %in% tmp$Category]) 51 | } else { 52 | treeNames <- rep("", ncol(dat)) 53 | treeLabels <- "" 54 | } 55 | 56 | K <- ncol(dat) 57 | N <- nrow(dat) 58 | 59 | if (select == "all") { 60 | select <- 1:N 61 | } else { 62 | if (!is.numeric(select) || any(select != round(select))) { 63 | stop("Please use an integer vector to select participants.") 64 | } 65 | dat <- dat[select, , drop = FALSE] 66 | N <- nrow(dat) 67 | } 68 | 69 | # absolute frequencies 70 | if (!freq) { 71 | # relative frequencies (per tree) 72 | for (t in 1:length(treeLabels)) { 73 | sel <- treeNames == treeLabels[t] 74 | dat[, sel] <- dat[, sel] / rep(rowSums(dat[, sel]), each = sum(sel)) 75 | } 76 | } 77 | 78 | means <- colMeans(dat) 79 | 80 | if (boxplot == TRUE) { 81 | boxplot(dat, 82 | ylab = ifelse(freq, "Absolute frequency", "Relative frequency (per tree)"), 83 | xlab = "", main = ifelse(freq, "Absolute frequency", "Relative frequency (per tree)"), las = 1, ... 84 | ) 85 | lines(1:K, means, col = "red", lwd = 2) 86 | } else { 87 | plot(1:K, rep(NA, K), 88 | ylim = c(0, max(dat)), col = 1, lwd = 3, pch = 16, xaxt = "n", las = 1, ..., 89 | ylab = ifelse(freq, "Absolute frequency", "Relative frequency (per tree)"), 90 | xlab = "", main = ifelse(freq, "Absolute frequency", "Relative frequency (per tree)") 91 | ) 92 | axis(1, 1:K, colnames(dat)) 93 | for (treelab in treeLabels) { 94 | sel <- treeNames == treelab 95 | for (i in 1:N) { 96 | lines((1:K)[sel], dat[i, sel], col = rainbow(N, alpha = .4)[i]) 97 | points((1:K)[sel], dat[i, sel], col = rainbow(N, alpha = .6)[i], pch = 16) 98 | } 99 | lines((1:K)[sel], means[sel], col = 1, lwd = 3) 100 | } 101 | } 102 | 103 | xt <- .5 104 | for (k in 2:K) { 105 | if (treeNames[k] != treeNames[k - 1]) { 106 | abline(v = k - .5) 107 | xt <- c(xt, k - .5) 108 | } 109 | } 110 | xt <- c(xt, K + .5) 111 | axis(1, xt[1:(length(xt) - 1)] + diff(xt) / 2, 112 | treeLabels, 113 | mgp = c(100, 3, 10) 114 | ) 115 | } 116 | -------------------------------------------------------------------------------- /R/plotConvergence.R: -------------------------------------------------------------------------------- 1 | 2 | #### wrappers for convenient convergence plots 3 | 4 | #' @export 5 | #' @describeIn plot Plot convergence for beta MPT 6 | plot.betaMPT <- function(x, parameter = "mean", type = "default", ...) { 7 | plot.traitMPT(x, parameter = parameter, type = type, ...) 8 | } 9 | 10 | #' @export 11 | #' @describeIn plot Plot convergence for nonhierarchical MPT model 12 | plot.simpleMPT <- function(x, type = "default", ...) { 13 | plot.traitMPT(x, parameter = "theta", type = type, ...) 14 | } 15 | 16 | 17 | #' Plot Convergence for Hierarchical MPT Models 18 | #' 19 | #' @param x fitted hierarchical MPT model (\code{\link{traitMPT}}, \code{\link{betaMPT}}) 20 | #' @param parameter which parameter to plot (e.g., \code{"theta"}, 21 | #' \code{"mean"}, \code{"rho"}, \code{"slope"}). 22 | #' Parameters are matched partially, in order to plot all entries of vector 23 | #' valued parameters (see \code{\link{getParam}} to get a list of parameters). 24 | #' Moreover, parameter labels can be used, e.g., \code{"theta[D]"} or \code{"rho[D,g]"} 25 | #' @param type type of convergence plot. Can be one of \code{"default"} 26 | #' (trace+density), \code{"acf"} (auto-correlation function), 27 | #' \code{"trace"}, \code{"autocorr"}, \code{"crosscorr"},\code{"density"}, 28 | #' \code{"gelman"}. See plotting functions in the \code{coda} package 29 | #' (\code{\link[coda]{plot.mcmc.list}}, 30 | #' \code{\link[coda]{acfplot}}, 31 | #' \code{\link[coda]{traceplot}}, 32 | #' \code{\link[coda]{autocorr.plot}}, 33 | #' \code{\link[coda]{crosscorr.plot}}, 34 | #' \code{\link[coda]{densplot}}, 35 | #' \code{\link[coda]{gelman.plot}} 36 | #' ). 37 | #' @param ... further arguments passed to the plotting functions in coda 38 | #' @export 39 | #' @describeIn plot Plot convergence for latent-trait MPT 40 | #' @importFrom coda traceplot acfplot gelman.plot as.mcmc.list varnames crosscorr.plot autocorr.plot densplot 41 | plot.traitMPT <- function(x, parameter = "mean", type = "default", ...) { 42 | mcmc <- x$runjags$mcmc 43 | allnam <- varnames(mcmc) 44 | thetaUnique <- x$mptInfo$thetaUnique 45 | S <- length(thetaUnique) 46 | parameter <- gsub(" ", "", parameter, fixed = TRUE) 47 | 48 | # unnecessary rho-parameters 49 | if (parameter == "rho") { 50 | rho.idx <- outer(1:S, 1:S, paste, sep = ",") 51 | rho.double <- paste0("rho[", rho.idx[lower.tri(rho.idx, diag = TRUE)], "]") 52 | allnam <- setdiff(allnam, rho.double) 53 | mcmc <- mcmc[, allnam] 54 | } 55 | parameter <- name2idx(parameter, thetaUnique) 56 | 57 | idx <- setdiff( 58 | grep(parameter, allnam, fixed = TRUE), 59 | grep(".pred", allnam, fixed = TRUE) 60 | ) 61 | if (length(idx) <= 0) { 62 | stop("Parameter not found in MCMC object.") 63 | } 64 | if (parameter == "theta") { 65 | allnam[idx] <- paste0(allnam[idx], rep(thetaUnique, "_", length(idx) / 2)) 66 | } else { 67 | allnam <- idx2name(allnam, thetaUnique) 68 | } 69 | coda::varnames(mcmc) <- allnam 70 | 71 | switch(type, 72 | "trace" = traceplot(mcmc[, idx], ...), 73 | "acf" = acfplot(mcmc[, idx], ...), 74 | "gelman" = gelman.plot(mcmc[, idx], ...), 75 | "crosscorr" = crosscorr.plot(mcmc[, idx], ...), 76 | "autocorr" = autocorr.plot(mcmc[, idx], ...), 77 | "density" = densplot(mcmc[, idx], ...), 78 | "default" = plot(mcmc[, idx], ...), 79 | stop("Check 'type' for possible plots.") 80 | ) 81 | } 82 | 83 | idx2name <- function(parnames, thetaUnique) { 84 | for (i in seq_along(thetaUnique)) { 85 | parnames <- gsub(paste0("(\\[", i, ")(,|\\])"), 86 | paste0("[", thetaUnique[i], "\\2"), 87 | parnames 88 | ) 89 | parnames <- gsub(paste0(",", i, "\\]"), 90 | paste0(",", thetaUnique[i], "\\]"), 91 | parnames) 92 | } 93 | parnames 94 | } 95 | 96 | name2idx <- function(parnames, thetaUnique) { 97 | for (i in seq_along(thetaUnique)) { 98 | parnames <- gsub(paste0("(\\[", thetaUnique[i], ")(,|\\])"), 99 | paste0("[", i, "\\2"), 100 | parnames 101 | ) 102 | parnames <- gsub(paste0(",", thetaUnique[i], "\\]"), 103 | paste0(",", i, "\\]"), 104 | parnames 105 | ) 106 | } 107 | parnames 108 | } 109 | -------------------------------------------------------------------------------- /man/genTraitMPT.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/genDataTrait.R 3 | \name{genTraitMPT} 4 | \alias{genTraitMPT} 5 | \title{Generate Data for Latent-Trait MPT Models} 6 | \usage{ 7 | genTraitMPT( 8 | N, 9 | numItems, 10 | eqnfile, 11 | restrictions, 12 | mean, 13 | mu, 14 | sigma, 15 | rho, 16 | warning = TRUE 17 | ) 18 | } 19 | \arguments{ 20 | \item{N}{number of participants} 21 | 22 | \item{numItems}{number of responses per tree (a named vector with tree 23 | labels)} 24 | 25 | \item{eqnfile}{The (relative or full) path to the file that specifies the MPT 26 | model (standard .eqn syntax). Note that category labels must start with a 27 | letter (different to multiTree) and match the column names of \code{data}. 28 | Alternatively, the EQN-equations can be provided within R as a character 29 | value (cf. \code{\link{readEQN}}). Note that the first line of an .eqn-file 30 | is reserved for comments and always ignored.} 31 | 32 | \item{restrictions}{Specifies which parameters should be (a) constant (e.g., 33 | \code{"a=b=.5"}) or (b) constrained to be identical (e.g., \code{"Do=Dn"}) 34 | or (c) treated as fixed effects (i.e., identical for all participants; 35 | \code{"a=b=FE"}). Either given as the path to a text file with restrictions 36 | per row or as a list of restrictions, e.g., \code{list("D1=D2","g=0.5")}. 37 | Note that numbers in .eqn-equations (e.g., \code{d*(1-g)*.50}) are directly 38 | interpreted as equality constraints.} 39 | 40 | \item{mean}{named vector of data-generating group means of the individual MPT 41 | parameters on the probability scale. If the vector is not named, the 42 | internal order of parameters is used (can be obtained using 43 | \code{\link{readEQN}}).} 44 | 45 | \item{mu}{an alternative way to define the group-level means on the 46 | latent-probit scale (i.e., \code{mu = qnorm(mean)} or equivalently, 47 | \code{mean = pnorm(mu)}).} 48 | 49 | \item{sigma}{(named) vector of group standard deviations of individual MPT 50 | parameters on the latent probit scale. Default is zero (no person 51 | heterogeneity).} 52 | 53 | \item{rho}{(named) correlation matrix for individual MPT parameters on the 54 | latent probit scale. Must be symmetric and positive definite (e.g., no 55 | correlations of 1 or -1 allowed). Default: a diagonal matrix (i.e., zero 56 | correlations).} 57 | 58 | \item{warning}{whether to show warning in case the naming of data-generating 59 | parameters are unnamed or do not match} 60 | } 61 | \value{ 62 | a list including the generated frequencies per person (\code{data}) 63 | and the sampled individual parameters (\code{parameters}) on the probit and 64 | probability scale (\code{thetaLatent} and \code{theta}, respectively). 65 | } 66 | \description{ 67 | Generating a data set with known parameter structure using the Trait-MPT. 68 | Useful for simulations and robustness checks. 69 | } 70 | \details{ 71 | This functions implements a two-step sampling procedure. First, the 72 | person parameters on the latent probit-scale are sampled from the 73 | multivariate normal distribution (based on the mean \code{mu = qnorm(mean)}, 74 | the standard deviations \code{sigma}, and the correlation matrix \code{rho}). 75 | These person parameters are then transformed to the probability scale using 76 | the probit-link. In a last step, observed frequencies are sampled for each 77 | person using the MPT equations. 78 | 79 | Note that the user can generate more complex structures for the latent person 80 | parameters, and then supply these person parameters to the function 81 | \code{\link{genMPT}}. 82 | } 83 | \examples{ 84 | # Example: Standard Two-High-Threshold Model (2HTM) 85 | EQNfile <- system.file("MPTmodels/2htm.eqn", package = "TreeBUGS") 86 | rho <- matrix(c( 87 | 1, .8, .2, 88 | .8, 1, .1, 89 | .2, .1, 1 90 | ), nrow = 3) 91 | colnames(rho) <- rownames(rho) <- c("Do", "Dn", "g") 92 | genDat <- genTraitMPT( 93 | N = 100, 94 | numItems = c(Target = 250, Lure = 250), 95 | eqnfile = EQNfile, 96 | mean = c(Do = .7, Dn = .7, g = .5), 97 | sigma = c(Do = .3, Dn = .3, g = .15), 98 | rho = rho 99 | ) 100 | head(genDat$data, 3) 101 | plotFreq(genDat$data, eqn = EQNfile) 102 | } 103 | \references{ 104 | Klauer, K. C. (2010). Hierarchical multinomial processing tree 105 | models: A latent-trait approach. Psychometrika, 75, 70-98. 106 | } 107 | \seealso{ 108 | \code{\link{genMPT}} 109 | } 110 | -------------------------------------------------------------------------------- /R/genDataBeta.R: -------------------------------------------------------------------------------- 1 | #' Generate Data for Beta MPT Models 2 | #' 3 | #' Generating a data file with known parameter structure using the Beta-MPT. 4 | #' Useful for simulations and robustness checks. 5 | #' 6 | #' @inheritParams betaMPT 7 | #' @inheritParams genMPT 8 | #' @param N number of participants 9 | #' @param mean Named vector of true group means of individual MPT parameters. If 10 | #' the vector is not named, the internal order of parameters is used (can be 11 | #' obtained using \code{\link{readEQN}}). 12 | #' @param sd named vector of group standard deviations of individual MPT 13 | #' parameters. 14 | #' @param alpha Alternative specification of the group-level distribution using 15 | #' the shape parameters of the beta distribution (see \link{dbeta}). 16 | #' @param beta see \code{alpha} 17 | #' 18 | #' @details Data are generated in a two-step procedure. First, person parameters 19 | #' are sampled from the specified beta distributions for each paramter (either 20 | #' based on mean/sd or based on alpha/beta). In a second step, response 21 | #' frequencies are sampled for each person using \code{\link{genMPT}}. 22 | #' 23 | #' @return a list including the generated frequencies (\code{data}) and the 24 | #' true, underlying parameters (\code{parameters}) on the group and individual 25 | #' level. 26 | #' @seealso \code{\link{genMPT}} 27 | #' @references Smith, J. B., & Batchelder, W. H. (2010). Beta-MPT: Multinomial 28 | #' processing tree models for addressing individual differences. Journal of 29 | #' Mathematical Psychology, 54, 167-183. 30 | #' 31 | #' @examples 32 | #' # Example: Standard Two-High-Threshold Model (2HTM) 33 | #' EQNfile <- system.file("MPTmodels/2htm.eqn", package = "TreeBUGS") 34 | #' genDat <- genBetaMPT( 35 | #' N = 100, 36 | #' numItems = c(Target = 250, Lure = 250), 37 | #' eqnfile = EQNfile, 38 | #' mean = c(Do = .7, Dn = .5, g = .5), 39 | #' sd = c(Do = .1, Dn = .1, g = .05) 40 | #' ) 41 | #' head(genDat$data, 3) 42 | #' plotFreq(genDat$data, eqn = EQNfile) 43 | #' @importFrom stats rbeta 44 | #' @export 45 | genBetaMPT <- function( 46 | N, 47 | numItems, 48 | eqnfile, 49 | restrictions, 50 | mean = NULL, 51 | sd = NULL, 52 | alpha = NULL, 53 | beta = NULL, 54 | warning = TRUE 55 | ) { 56 | if (missing(restrictions)) { 57 | restrictions <- NULL 58 | } 59 | 60 | # REMINDER 2024-04: restrictions were ineffective in readEQN(); only processed by thetaHandling 61 | Tree <- readEQN(eqnfile) 62 | mergedTree <- mergeBranches(Tree) 63 | Tree.restr <- thetaHandling(mergedTree, restrictions) 64 | thetaNames <- Tree.restr$SubPar[, 1:2] 65 | thetaNames <- thetaNames[rownames(unique(thetaNames[2])), ]$Parameter 66 | treeLabels <- unique(mergedTree$Tree) 67 | S <- length(thetaNames) 68 | 69 | 70 | if (!is.null(mean) && !is.null(sd)) { 71 | mean <- checkNaming(S, thetaNames, mean, "mean", 72 | interval = c(0, 1), warning = warning 73 | ) 74 | sd <- checkNaming(S, thetaNames, sd, "sd", 75 | interval = c(0, Inf), warning = warning 76 | ) 77 | 78 | alpha <- ((1 - mean) / sd^2 - 1 / mean) * mean^2 79 | beta <- alpha * (1 / mean - 1) 80 | if (any(alpha <= 0) | any(beta <= 0)) { 81 | stop( 82 | "Check numerical values for mean and sd, result in negative alpha/beta\n", 83 | "parameters of beta-hyperprior distribution." 84 | ) 85 | } 86 | } else if (!is.null(alpha) && !is.null(beta)) { 87 | alpha <- checkNaming(S, thetaNames, alpha, "alpha", 88 | interval = c(0, Inf), warning = warning 89 | ) 90 | beta <- checkNaming(S, thetaNames, beta, "beta", 91 | interval = c(0, Inf), warning = warning 92 | ) 93 | } else { 94 | stop("Either 'mean'/'sd' or 'alpha'/'beta' must be provided.") 95 | } 96 | 97 | # individual parameters, drawn from hierarchical distribution: 98 | theta <- c() 99 | for (s in 1:S) { 100 | if (!is.null(sd) && sd[s] == 0) { 101 | theta <- cbind(theta, rep(mean[s], N)) 102 | } else { 103 | theta <- cbind(theta, rbeta(N, shape1 = alpha[s], shape2 = beta[s])) 104 | } 105 | } 106 | colnames(theta) <- thetaNames 107 | 108 | # response frequencies: 109 | freq <- genMPT(theta, numItems, eqnfile, restrictions, warning = warning) 110 | list( 111 | data = freq, 112 | parameters = list(theta = theta, mean = mean, sd = sd, alpha = alpha, beta = beta) 113 | ) 114 | } 115 | -------------------------------------------------------------------------------- /R/testHetChi.R: -------------------------------------------------------------------------------- 1 | #' Chi-Square Test of Heterogeneity 2 | #' 3 | #' Tests whether whether participants (items) are homogeneous under the 4 | #' assumption of item (participant) homogeneity. 5 | #' 6 | #' @param freq matrix with observed frequencies (rows: persons/items; columns: 7 | #' categories). Can also be the path to a .csv file with frequencies 8 | #' (comma-separated; first line defines category labels) 9 | #' @param tree a vector defining which columns of x belong to separate 10 | #' multinomial distributions (i.e., MPT trees). For instance, if \code{x} has 11 | #' five categories from two MPT trees: \code{tree=c(1,1,2,2,2)} or 12 | #' \code{tree=c("t1","t1","t2","t2","t2")} 13 | #' 14 | #' @details If an item/person has zero frequencies on all categories in an MPT 15 | #' tree, these zeros are neglected when computing mean frequencies per column. 16 | #' As an example, consider a simple recognition test with a fixed assignments of 17 | #' words to the learn/test list. In such an experiment, all learned words will 18 | #' result in hits or misses (i.e., the MPT tree of old items), whereas new words 19 | #' are always false alarms/correct rejections and thus belong to the MPT tree of 20 | #' new items (this is not necessarily the case if words are assigned randomly). 21 | #' 22 | #' Note that the test assumes independence of observations and item homogeneity 23 | #' when testing participant heterogeneity. The latter assumption can be dropped 24 | #' when using a permutation test (\code{\link{testHetPerm}}). 25 | #' @seealso \code{\link{testHetPerm}}, \code{\link{plotFreq}} 26 | #' @author Daniel W. Heck 27 | #' @references Smith, J. B., & Batchelder, W. H. (2008). Assessing individual 28 | #' differences in categorical data. Psychonomic Bulletin & Review, 15, 29 | #' 713-731. \doi{10.3758/PBR.15.4.713} 30 | #' 31 | #' @examples 32 | #' # some made up frequencies: 33 | #' freq <- matrix( 34 | #' c( 35 | #' 13, 16, 11, 13, 36 | #' 15, 21, 18, 13, 37 | #' 21, 14, 16, 17, 38 | #' 19, 20, 21, 18 39 | #' ), 40 | #' ncol = 4, byrow = TRUE 41 | #' ) 42 | #' # for a product-binomial distribution: 43 | #' # (categories 1 and 2 and categories 3 and 4 are binomials) 44 | #' testHetChi(freq, tree = c(1, 1, 2, 2)) 45 | #' # => no significant deviation from homogeneity (low power!) 46 | #' @export 47 | testHetChi <- function( 48 | freq, 49 | tree 50 | ) { 51 | # gen2htm <- genBetaMPT(24, c(Target=100,Lure=100), htm, 52 | # mean=c(Do=.7, Dn=.7, g=.4), 53 | # sd=c(Do=0.05, Dn=0.05, g=0.05)) 54 | # freq <- gen2htm$data #matrix(round(runif(items*subjs, .5, 14.49)),subjs, 10) 55 | # tree <- c(1,1,2,2) # c(rep(1,6), 2,2,3,3) 56 | 57 | if (is.character(freq)) { 58 | freq <- read.csv(file = freq) 59 | } 60 | 61 | freq <- as.matrix(freq) 62 | 63 | if (any(is.character(freq) | freq != round(freq))) { 64 | stop("The data ('freq') may only contain frequencies!") 65 | } 66 | if (missing(tree)) { 67 | warning( 68 | "It is assumed that all columns of 'freq' stem from one multinomial distribution", 69 | "\n (i.e., from a single MPT tree)" 70 | ) 71 | tree <- rep(1, ncol(freq)) 72 | } 73 | 74 | if (length(tree) != ncol(freq)) { 75 | stop("Length of vector 'tree' must be identical to number of columns of 'freq'.") 76 | } 77 | 78 | # number of participants/items: 79 | N <- nrow(freq) 80 | # numer of items per person/tree: 81 | if (length(unique(tree)) == 1) { 82 | M <- matrix(rowSums(freq)) 83 | colnames(M) <- unique(tree) 84 | } else { 85 | M <- t(apply(freq, 1, function(xx) tapply(xx, tree, sum))) 86 | } 87 | M[M == 0] <- NA 88 | # number of categories per tree: 89 | K <- tapply(freq[1, ], tree, length) 90 | 91 | # compute mean frequencies across proportions 92 | # (not raw frequencies: different M!) 93 | prop <- freq / M[, tree] 94 | mu <- colMeans(prop, na.rm = TRUE) 95 | 96 | freq.exp <- M[, tree] * matrix(mu, nrow(M), length(mu), byrow = TRUE) 97 | 98 | # for(t in seq_along(tree)){ 99 | # sel <- rowSums(freq[ , tree == tree[t] ]) == 0 100 | # if(any(sel)) 101 | # freq.exp[sel , tree == tree[t] ] <- NA 102 | # } 103 | 104 | # freq.exp <- matrix(mu, N, sum(K), byrow = TRUE) 105 | chi <- sum((freq - freq.exp)^2 / freq.exp, na.rm = TRUE) 106 | 107 | df <- sum(K - 1) * (N - 1) 108 | list( 109 | chisq = chi, df = df, 110 | prob = pchisq(chi, df, lower.tail = FALSE) 111 | ) 112 | } 113 | -------------------------------------------------------------------------------- /man/betaMPTcpp.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/fitBetaMPTcpp.R 3 | \name{betaMPTcpp} 4 | \alias{betaMPTcpp} 5 | \title{C++ Sampler for Hierarchical Beta-MPT Model} 6 | \usage{ 7 | betaMPTcpp( 8 | eqnfile, 9 | data, 10 | restrictions, 11 | covData, 12 | corProbit = FALSE, 13 | n.iter = 20000, 14 | n.burnin = 2000, 15 | n.thin = 5, 16 | n.chains = 3, 17 | ppp = 0, 18 | shape = 1, 19 | rate = 0.1, 20 | parEstFile, 21 | posteriorFile, 22 | cores = 1 23 | ) 24 | } 25 | \arguments{ 26 | \item{eqnfile}{The (relative or full) path to the file that specifies the MPT 27 | model (standard .eqn syntax). Note that category labels must start with a 28 | letter (different to multiTree) and match the column names of \code{data}. 29 | Alternatively, the EQN-equations can be provided within R as a character 30 | value (cf. \code{\link{readEQN}}). Note that the first line of an .eqn-file 31 | is reserved for comments and always ignored.} 32 | 33 | \item{data}{The (relative or full) path to the .csv file with the data (comma 34 | separated; category labels in first row). Alternatively: a data frame or 35 | matrix (rows=individuals, columns = individual category frequencies, 36 | category labels as column names)} 37 | 38 | \item{restrictions}{Specifies which parameters should be (a) constant (e.g., 39 | \code{"a=b=.5"}) or (b) constrained to be identical (e.g., \code{"Do=Dn"}) 40 | or (c) treated as fixed effects (i.e., identical for all participants; 41 | \code{"a=b=FE"}). Either given as the path to a text file with restrictions 42 | per row or as a list of restrictions, e.g., \code{list("D1=D2","g=0.5")}. 43 | Note that numbers in .eqn-equations (e.g., \code{d*(1-g)*.50}) are directly 44 | interpreted as equality constraints.} 45 | 46 | \item{covData}{Data that contains covariates, for which correlations with 47 | individual MPT parameters will be sampled. Either the path to a .csv file 48 | (comma-separated: rows=individuals in the same order as \code{data}; first 49 | row must contain covariate labels). Alternatively: a data frame or matrix 50 | (rows=individuals, columns = variables; covariate labels as column names). 51 | Note that in \code{betaMPT}, correlations are computed for discrete 52 | variables that are coded numerically (in \code{traitMPT}, this can be 53 | suppressed by using \code{predType="f"})} 54 | 55 | \item{corProbit}{whether to use probit-transformed MPT parameters to compute 56 | correlations (probit-values of \code{+Inf} are truncated to 57 | \code{max(5,max(probit))}; similarly for \code{-Inf}). Default for 58 | beta-MPT: MPT parameters are used on the probability scale [0,1].} 59 | 60 | \item{n.iter}{Number of iterations per chain (including burnin samples). See 61 | \code{\link[runjags]{run.jags}} for details.} 62 | 63 | \item{n.burnin}{Number of samples for burnin (samples will not be stored and 64 | removed from n.iter)} 65 | 66 | \item{n.thin}{Thinning rate.} 67 | 68 | \item{n.chains}{number of MCMC chains (sampled in parallel, which can be 69 | changed via the additional argument \code{n.sim = 1}).} 70 | 71 | \item{ppp}{number of samples to compute posterior predictive p-value (see 72 | \code{\link{posteriorPredictive}})} 73 | 74 | \item{shape}{shape parameter(s) of Gamma-hyperdistribution for the 75 | hierarchical beta-parameters \eqn{\alpha_s} and \eqn{\beta_s} (can be a 76 | named vector to provide different hyperpriors for each parameter)} 77 | 78 | \item{rate}{rate parameter(s) of Gamma-hyperdistribution} 79 | 80 | \item{parEstFile}{Name of the file to with the estimates should be stored 81 | (e.g., "parEstFile.txt")} 82 | 83 | \item{posteriorFile}{path to RData-file where to save the model including 84 | MCMC posterior samples (an object named \code{fittedModel}; e.g., 85 | \code{posteriorFile="mcmc.RData"})} 86 | 87 | \item{cores}{number of CPUs to be used} 88 | } 89 | \description{ 90 | Fast Gibbs sampler in C++ that is tailored to the beta-MPT model. 91 | } 92 | \examples{ 93 | \dontrun{ 94 | # fit beta-MPT model for encoding condition (see ?arnold2013): 95 | EQNfile <- system.file("MPTmodels/2htsm.eqn", package = "TreeBUGS") 96 | d.encoding <- subset(arnold2013, group == "encoding", select = -(1:4)) 97 | fit <- betaMPTcpp(EQNfile, d.encoding, 98 | n.thin = 5, 99 | restrictions = list("D1=D2=D3", "d1=d2", "a=g") 100 | ) 101 | # convergence 102 | plot(fit, parameter = "mean", type = "default") 103 | summary(fit) 104 | } 105 | } 106 | \author{ 107 | Daniel Heck 108 | } 109 | -------------------------------------------------------------------------------- /R/plotPrior.R: -------------------------------------------------------------------------------- 1 | #' Plot Prior Distributions 2 | #' 3 | #' Plots prior distributions for group means, standard deviation, and 4 | #' correlations of MPT parameters across participants. 5 | #' 6 | #' @param M number of random samples to approximate priors of group-level 7 | #' parameters 8 | #' @param probitInverse which latent-probit parameters (for 9 | #' \code{\link{traitMPT}} model) to transform to probability scale. Either 10 | #' \code{"none"}, \code{"mean"} (simple transformation \eqn{\Phi(\mu)}), or 11 | #' \code{"mean_sd"} (see \code{\link{probitInverse}}) 12 | #' @param ... further arguments passed to \code{plot} 13 | #' @inheritParams priorPredictive 14 | #' 15 | #' @details This function samples from a set of hyperpriors (either for 16 | #' hierarchical traitMPT or betaMPT structure) to approximate the implied 17 | #' prior distributions on the parameters of interest (group-level mean, SD, 18 | #' and correlations of MPT parameters). Note that the normal distribution 19 | #' \code{"dnorm(mu,prec)"} is parameterized as in JAGS by the mean and 20 | #' precision (= 1/variance). 21 | #' @seealso \code{\link{priorPredictive}} 22 | #' 23 | #' @examples 24 | #' \dontrun{ 25 | #' # default priors for traitMPT: 26 | #' plotPrior(list( 27 | #' mu = "dnorm(0, 1)", 28 | #' xi = "dunif(0, 10)", 29 | #' V = diag(2), 30 | #' df = 2 + 1 31 | #' ), M = 4000) 32 | #' 33 | #' # default priors for betaMPT: 34 | #' plotPrior(list( 35 | #' alpha = "dgamma(1, 0.1)", 36 | #' beta = "dgamma(1, 0.1)" 37 | #' ), M = 4000) 38 | #' } 39 | #' @export 40 | plotPrior <- function( 41 | prior, 42 | probitInverse = "mean", 43 | M = 5000, 44 | nCPU = 3, 45 | ... 46 | ) { 47 | ############### prior samples 48 | samples <- sampleHyperprior(prior, M, # S=1, 49 | probitInverse = probitInverse, truncSig = .995, nCPU = nCPU 50 | ) 51 | model <- attr(samples, "model") 52 | S <- ncol(samples$mean) 53 | if (model == "traitMPT") { 54 | S.plot <- ifelse(S > 1 && (max(length(prior$xi), length(prior$mu)) > 1 | 55 | any(prior$V != diag(S))), S, 1) 56 | } else { 57 | S.plot <- ifelse(S > 1 && (max(length(prior$alpha), length(prior$beta)) > 1), S, 1) 58 | } 59 | 60 | ################# plotting 61 | 62 | mfrow <- par()$mfrow 63 | qq <- seq(0, 1, .05) 64 | bins <- min(60, round(M / 40)) 65 | histcol <- adjustcolor("gray", alpha.f = .7) 66 | par(mfrow = c(2, ifelse(model == "traitMPT", 2, 1))) 67 | 68 | ######################## MEAN 69 | for (s in 1:S.plot) { 70 | hist(samples$mean[, s], bins, 71 | freq = FALSE, col = histcol, 72 | main = paste0( 73 | "Prior on group mean: ", 74 | ifelse(model == "traitMPT", 75 | paste0("mu=", ifelse(length(prior$mu) == 1, prior$mu[1], prior$mu[s])), 76 | paste0("alpha=", ifelse(length(prior$alpha) == 1, prior$alpha[1], prior$alpha[s])) 77 | ) 78 | ), 79 | xlab = paste0( 80 | "Group mean", 81 | ifelse(model == "traitMPT" && probitInverse == "none", 82 | " (probit scale)", 83 | " (probability scale)" 84 | ) 85 | ), 86 | border = histcol, las = 1, ... 87 | ) 88 | } 89 | 90 | ######################## SD 91 | for (s in 1:S.plot) { 92 | hist(samples$sd[, s], bins, 93 | freq = FALSE, col = histcol, 94 | xlim = c(0, max(max(samples$sd, na.rm = TRUE), .5)), 95 | main = paste0( 96 | "Prior on group SD: ", 97 | ifelse(model == "traitMPT", 98 | paste0("xi=", ifelse(length(prior$xi) == 1, prior$xi[1], prior$xi[s])), 99 | paste0("beta=", ifelse(length(prior$beta) == 1, prior$beta[1], prior$beta[s])) 100 | ) 101 | ), 102 | xlab = paste0( 103 | "Group SD", 104 | ifelse(model == "betaMPT" || probitInverse == "mean_sd", 105 | " (probability scale)", 106 | " (probit scale)" 107 | ) 108 | ), 109 | border = histcol, las = 1, ... 110 | ) 111 | } 112 | 113 | ######################## CORRELATION 114 | if (model == "traitMPT" && S > 1) { 115 | for (s1 in 1:(S - 1)) { 116 | for (s2 in (s1 + 1):S) { 117 | hist(samples$rho[s1, s2, ], bins, 118 | freq = FALSE, col = histcol, 119 | main = paste0("Correlation (", s1, " and ", s2, "): df=", prior$df), 120 | xlab = "Correlation (probit scale)", border = histcol, las = 1, ... 121 | ) 122 | } 123 | } 124 | } 125 | 126 | par(mfrow = mfrow) 127 | } 128 | -------------------------------------------------------------------------------- /tests/testthat/test_genMPT.R: -------------------------------------------------------------------------------- 1 | # Test data-generating functions 2 | 3 | eqnfile <- system.file("MPTmodels/2htm.eqn", package = "TreeBUGS") 4 | model <- "# 2HTM 5 | Target Hit Do 6 | Target Hit (1-Do)*g 7 | Target Miss (1-Do)*(1-g) 8 | Lure FA (1-Dn)*g 9 | Lure CR (1-Dn)*(1-g) 10 | Lure CR Dn 11 | " 12 | 13 | n <- 1e7 14 | par <- c(Do = .6, Dn = .4, g = .55) 15 | # undebug(genMPT) 16 | 17 | 18 | test_that("genData generates expected frequencies for simple models", { 19 | exp <- c( 20 | (1 - par["Dn"]) * par["g"], # FA 21 | par["Do"] + (1 - par["Do"]) * par["g"] 22 | ) # Hit 23 | names(exp) <- NULL 24 | 25 | # EQN file 26 | d <- genMPT(par, c(Lure = n, Target = n), eqnfile) 27 | expect_equal(d[2:3] / n, exp, tolerance = .01) 28 | 29 | # string model 30 | d <- genMPT(par, c(Lure = n, Target = n), model) 31 | expect_equal(d[2:3] / n, exp, tolerance = .01) 32 | 33 | # naming errors expected: 34 | expect_warning(genMPT(par, c(n, n), model)) 35 | expect_warning(genMPT(c(.1, .4, .2), c(Lure = n, Target = n), model)) 36 | 37 | # errors due to misspecifiation: 38 | expect_error(genMPT(c(.1, .4), c(Lure = n, Target = n), model, warning = FALSE)) 39 | expect_error(genMPT(c(.1, .4, .4), c(Lure = n), model, warning = FALSE)) 40 | }) 41 | 42 | 43 | test_that("genData generates expected frequencies for constrained models", { 44 | e2 <- c( 45 | (1 - par["Dn"]) * .5, # FA 46 | par["Dn"] + (1 - par["Dn"]) * .5 47 | ) # Hit 48 | names(e2) <- NULL 49 | d <- genMPT(par["Dn"], c(Lure = n, Target = n), 50 | eqnfile, 51 | restrictions = list("g=.5", "Dn=Do") 52 | ) 53 | expect_equal(d[2:3] / n, e2, tolerance = .05) 54 | 55 | # naming errors expected: 56 | expect_warning(genMPT(c(.1, .4), c(Lure = n, Target = n), 57 | model, 58 | restrictions = list("g=.5") 59 | )) 60 | 61 | # errors due to misspecifiation: 62 | expect_error(genMPT(c(.1), c(Lure = n, Target = n), model, 63 | restrictions = list("Dn=Do"), warning = FALSE 64 | )) 65 | expect_error(genMPT(c(.1, .2), c(Lure = n, Target = n), model, 66 | restrictions = list("Dn=sdsa"), warning = FALSE 67 | )) 68 | expect_error(suppressWarnings(genMPT(c(.1, .2), c(Lure = n, Target = n), model, 69 | restrictions = list("Dn=1.3"), warning = FALSE 70 | ))) 71 | expect_error(suppressWarnings(genMPT(c(.1, .2), c(Lure = n, Target = n), model, 72 | restrictions = list("Dn=-1"), warning = FALSE 73 | ))) 74 | expect_error(genMPT(c(.1), c(Lure = n), model, warning = FALSE)) 75 | expect_error(genMPT(c(.1, .2, .4), c(Lure = n), model, 76 | restrictions = list("g=.5"), warning = FALSE 77 | )) 78 | }) 79 | 80 | 81 | test_that("genTraitMPT generates proper data", { 82 | N <- 100 83 | mean <- c(Dn = .3, Do = .6) 84 | sigma <- c(Dn = .2, Do = .5) 85 | rho <- matrix(c(1, .4, .4, 1), 2, 86 | dimnames = list(c("Dn", "Do"), c("Dn", "Do")) 87 | ) 88 | Sigma <- rho * (sigma %*% t(sigma)) 89 | gen <- genTraitMPT( 90 | N = N, numItems = c(Target = 1000, Lure = 1000), 91 | eqnfile = model, restrictions = list("g=.5"), 92 | mean = mean, sigma = sigma, rho = rho 93 | ) 94 | 95 | expect_equal(cov(gen$parameters$thetaLatent), 96 | Sigma, 97 | tolerance = .2 98 | ) 99 | expect_equal(colMeans(gen$parameters$theta), mean, tolerance = .2) 100 | 101 | 102 | # est <- simpleMPT(model, gen$data[,], restrictions=list("g=.5"), 103 | # n.iter = 1500, n.burnin = 800, n.thin=2) 104 | # expect_equal(cov(qnorm(t(est$summary$individParameters[,,"Mean"]))), 105 | # Sigma, tolerance=.1) 106 | # expect_equal(rowMeans(est$summary$individParameters[,,"Mean"]), 107 | # mean, tolerance=.1) 108 | }) 109 | 110 | 111 | test_that("genBetaMPT generates proper data", { 112 | N <- 100 113 | mean <- c(Dn = .5) 114 | sd <- c(Dn = .15) 115 | gen <- genBetaMPT( 116 | N = N, numItems = c(Target = 1000, Lure = 1000), 117 | eqnfile = model, restrictions = list("g=.5", "Dn=Do"), 118 | mean = mean, sd = sd 119 | ) 120 | expect_equal(c(Dn = sd(gen$parameters$theta)), sd, tolerance = .2) 121 | expect_equal(colMeans(gen$parameters$theta), mean, tolerance = .2) 122 | 123 | # est <- simpleMPT(model, gen$data[,], restrictions=list("g=.5","Dn=Do"), 124 | # n.iter = 1500, n.burnin = 800, n.thin=2) 125 | # expect_equal(c(Dn=sd(est$summary$individParameters[,,"Mean"])), 126 | # sd, tolerance=.1) 127 | # expect_equal(rowMeans(est$summary$individParameters[,,"Mean",drop=FALSE]), 128 | # mean, tolerance=.1) 129 | }) 130 | -------------------------------------------------------------------------------- /R/correlationBayes.R: -------------------------------------------------------------------------------- 1 | ############################################################################### 2 | ### Posterior distribution for Pearson's correlation coefficient 3 | ### 4 | ### Code by Alexander Ly 5 | ### * https://github.com/AlexanderLyNL/jasp-desktop/blob/development/JASP-Engine/JASP/R/correlationbayesian.R#L1581 6 | ### 7 | ### * Ly, A., Marsman, M., Wagenmakers, E.-J. (2015). 8 | ### Analytic Posteriors for Pearson's Correlation Coefficient. 9 | ### Manuscript submitted for publication. https://arxiv.org/abs/1510.01188 10 | ### 11 | ### * Alexander Ly, Udo Boehm, Andrew Heathcote, Brandon M. Turner, Birte Forstmann, 12 | ### Maarten Marsman, and Dora Matzke (2016). 13 | ### A flexible and efficient hierarchical Bayesian approach to the exploration of 14 | ### individual differences in cognitive-model-based neuroscience. https://osf.io/evsyv/ 15 | ### 16 | ############################################################################### 17 | 18 | # require("hypergeo") 19 | #' @importFrom hypergeo hypergeo genhypergeo 20 | 21 | ## Auxilary functions ------------------------------------------------------------ 22 | # 0. Prior specification 23 | .scaledBeta <- function(rho, alpha, beta) { 24 | result <- 1 / 2 * dbeta((rho + 1) / 2, alpha, beta) 25 | return(result) 26 | } 27 | 28 | 29 | .priorRho <- function(rho, kappa = 1) { 30 | .scaledBeta(rho, 1 / kappa, 1 / kappa) 31 | } 32 | 33 | # 1.0. Built-up for likelihood functions 34 | .aFunction <- function(n, r, rho, maxiter = 2000) { 35 | hyper.term <- Re(genhypergeo(U = c((n - 1) / 2, (n - 1) / 2), L = (1 / 2), z = (r * rho)^2, maxiter = maxiter)) 36 | result <- (1 - rho^2)^((n - 1) / 2) * hyper.term 37 | return(result) 38 | } 39 | 40 | .bFunction <- function(n, r, rho, maxiter = 2000) { 41 | hyper.term <- Re(genhypergeo(U = c(n / 2, n / 2), L = (3 / 2), z = (r * rho)^2, maxiter = maxiter)) 42 | log.term <- 2 * (lgamma(n / 2) - lgamma((n - 1) / 2)) + ((n - 1) / 2) * log(1 - rho^2) 43 | result <- 2 * r * rho * exp(log.term) * hyper.term 44 | return(result) 45 | } 46 | 47 | .hFunction <- function(n, r, rho, maxiter = 2000) { 48 | result <- .aFunction(n, r, rho, maxiter = maxiter) + .bFunction(n, r, rho, maxiter = maxiter) 49 | return(result) 50 | } 51 | 52 | .jeffreysApproxH <- function(n, r, rho) { 53 | result <- ((1 - rho^(2))^(0.5 * (n - 1))) / ((1 - rho * r)^(n - 1 - 0.5)) 54 | return(result) 55 | } 56 | 57 | 58 | # 59 | # 2.1 Two-sided main Bayes factor ---------------------------------------------- 60 | .bf10Exact <- function(n, r, kappa = 1, maxiter = 2000) { 61 | # Ly et al 2015 62 | # This is the exact result with symmetric beta prior on rho 63 | # with parameter alpha. If kappa = 1 then uniform prior on rho 64 | # 65 | # 66 | if (n <= 2) { 67 | return(1) 68 | } else if (any(is.na(r))) { 69 | return(NaN) 70 | } 71 | # TODO: use which 72 | check.r <- abs(r) >= 1 # check whether |r| >= 1 73 | if (kappa >= 1 && n > 2 && check.r) { 74 | return(Inf) 75 | } 76 | # log.hyper.term <- log(hypergeo(((n-1)/2), ((n-1)/2), ((n+2/kappa)/2), r^2)) 77 | log.hyper.term <- log(genhypergeo(U = c((n - 1) / 2, (n - 1) / 2), L = ((n + 2 / kappa) / 2), z = r^2, maxiter = maxiter)) 78 | log.result <- log(2^(1 - 2 / kappa)) + 0.5 * log(pi) - lbeta(1 / kappa, 1 / kappa) + 79 | lgamma((n + 2 / kappa - 1) / 2) - lgamma((n + 2 / kappa) / 2) + log.hyper.term 80 | real.result <- exp(Re(log.result)) 81 | # return(realResult) 82 | return(real.result) 83 | } 84 | 85 | # 2.2 Two-sided secondairy Bayes factor 86 | .bf10JeffreysIntegrate <- function(n, r, kappa = 1, maxiter = 2000) { 87 | # Jeffreys' test for whether a correlation is zero or not 88 | # Jeffreys (1961), pp. 289-292 89 | # This is the exact result, see EJ 90 | ## 91 | if (n <= 2) { 92 | return(1) 93 | } else if (any(is.na(r))) { 94 | return(NaN) 95 | } 96 | 97 | # TODO: use which 98 | if (n > 2 && abs(r) == 1) { 99 | return(Inf) 100 | } 101 | hyper.term <- Re(genhypergeo(U = c((2 * n - 3) / 4, (2 * n - 1) / 4), L = (n + 2 / kappa) / 2, z = r^2, maxiter = maxiter)) 102 | log.term <- lgamma((n + 2 / kappa - 1) / 2) - lgamma((n + 2 / kappa) / 2) - lbeta(1 / kappa, 1 / kappa) 103 | result <- sqrt(pi) * 2^(1 - 2 / kappa) * exp(log.term) * hyper.term 104 | return(result) 105 | } 106 | 107 | 108 | # 4.1 Two-sided 109 | .posteriorRho <- function(n, r, rho, kappa = 1, maxiter = 2000) { 110 | if (!is.na(r) && !r == 0) { 111 | return(1 / .bf10Exact(n, r, kappa) * .hFunction(n, r, rho, maxiter = maxiter) * .priorRho(rho, kappa)) 112 | } else if (!is.na(r) && r == 0) { 113 | return(1 / .bf10JeffreysIntegrate(n, r, kappa, maxiter = maxiter) * .jeffreysApproxH(n, r, rho) * .priorRho(rho, kappa)) 114 | } 115 | } 116 | -------------------------------------------------------------------------------- /R/plotPriorPost.R: -------------------------------------------------------------------------------- 1 | #' Plot Prior vs. Posterior Distribution 2 | #' 3 | #' Allows to judge how much the data informed the parameter posterior 4 | #' distributions compared to the prior. 5 | #' 6 | #' @inheritParams plotFit 7 | #' @inheritParams priorPredictive 8 | #' @inheritParams plotPrior 9 | #' @param M number of random samples to approximate prior distributions 10 | #' @param ci credibility interval indicated by vertical red lines 11 | #' 12 | #' @details Prior distributions are shown as blue, dashed lines, whereas 13 | #' posterior distributions are shown as solid, black lines. 14 | #' @export 15 | plotPriorPost <- function( 16 | fittedModel, 17 | probitInverse = "mean", 18 | M = 2e5, 19 | ci = .95, 20 | nCPU = 3, 21 | ... 22 | ) { 23 | mfrow <- par()$mfrow 24 | 25 | S <- length(fittedModel$mptInfo$thetaUnique) 26 | samples <- sampleHyperprior(fittedModel$mptInfo$hyperprior, 27 | M = M, S = S, 28 | probitInverse = probitInverse, nCPU = nCPU 29 | ) 30 | 31 | for (s in 1:S) { 32 | label <- ifelse(S == 1, "", paste0("[", s, "]")) 33 | mean.post <- unlist(fittedModel$runjags$mcmc[, paste0("mean", label)]) 34 | d.mean <- density(mean.post, from = 0, to = 1, na.rm = TRUE) 35 | prior.mean <- density(samples$mean[, s], from = 0, to = 1, na.rm = TRUE) 36 | ci.mean <- quantile(mean.post, c((1 - ci) / 2, 1 - (1 - ci) / 2)) 37 | 38 | if (fittedModel$mptInfo$model == "betaMPT") { 39 | sd.post <- unlist(fittedModel$runjags$mcmc[, paste0("sd", label)]) 40 | ci.sd <- quantile(sd.post, c((1 - ci) / 2, 1 - (1 - ci) / 2)) 41 | d.sd <- density(sd.post, from = 0, to = .5, na.rm = TRUE) 42 | prior.sd <- density(samples$sd[, s], from = 0, to = .5, na.rm = TRUE) 43 | xlab.sd <- "Group SD (probability)" 44 | 45 | ####### traitMPT 46 | } else { 47 | sig.post <- unlist(fittedModel$runjags$mcmc[, paste0("sigma", label)]) 48 | if (probitInverse == "mean_sd") { 49 | mean_sd <- probitInverse(qnorm(mean.post), sig.post) 50 | d.mean <- density(mean_sd[, "mean"], from = 0, to = 1, na.rm = TRUE) 51 | d.sd <- density(mean_sd[, "sd"], from = 0, to = .5, na.rm = TRUE) 52 | ci.sd <- quantile(mean_sd[, "sd"], c((1 - ci) / 2, 1 - (1 - ci) / 2)) 53 | ci.mean <- quantile(mean_sd[, "mean"], c((1 - ci) / 2, 1 - (1 - ci) / 2)) 54 | prior.sd <- density(samples$sd[, s], from = 0, to = .5, na.rm = TRUE) 55 | } else { 56 | prior.sd <- density(samples$sd[, s], from = 0, na.rm = TRUE) 57 | d.sd <- density(sig.post, from = 0, na.rm = TRUE) 58 | ci.sd <- quantile(sig.post, c((1 - ci) / 2, 1 - (1 - ci) / 2)) 59 | if (probitInverse == "none") { 60 | d.mean <- density(qnorm(mean.post), na.rm = TRUE) 61 | ci.mean <- quantile(qnorm(mean.post), c((1 - ci) / 2, 1 - (1 - ci) / 2)) 62 | prior.mean <- density(samples$mean[, s], na.rm = TRUE) 63 | } 64 | } 65 | 66 | xlab.sd <- ifelse(probitInverse == "mean_sd", 67 | "Group SD (probability scale)", 68 | "Group SD (probit scale)" 69 | ) 70 | } 71 | 72 | par(mfrow = 1:2) 73 | tmp <- readline(prompt = "Press to show the next plot.") 74 | plot(d.mean, 75 | main = paste0("Group mean of ", fittedModel$mptInfo$thetaUnique[s]), 76 | xlab = "Group mean", las = 1, ... 77 | ) 78 | lines(prior.mean, col = "blue", lty = "dashed") 79 | abline(v = ci.mean, col = "red") 80 | plot(d.sd, 81 | main = paste0("Group SD of ", fittedModel$mptInfo$thetaUnique[s]), 82 | xlab = xlab.sd, las = 1, ... 83 | ) 84 | lines(prior.sd, col = "blue", lty = "dashed") 85 | abline(v = ci.sd, col = "red") 86 | } 87 | 88 | if (fittedModel$mptInfo$model == "traitMPT" & S > 1) { 89 | cnt <- 0 90 | for (s1 in 1:(S - 1)) { 91 | for (s2 in (s1 + 1):S) { 92 | d.cor <- density(unlist(fittedModel$runjags$mcmc[, paste0("rho[", s1, ",", s2, "]")]), 93 | from = -1, to = 1 94 | ) 95 | prior.cor <- density(samples$rho[s1, s2, ], from = -1, to = 1) 96 | if (cnt / 2 == round(cnt / 2)) { 97 | tmp <- readline(prompt = "Press to show the next plot.") 98 | } 99 | cnt <- cnt + 1 100 | plot(d.cor, 101 | main = paste0( 102 | "Correlation between ", 103 | fittedModel$mptInfo$thetaUnique[s1], " and ", 104 | fittedModel$mptInfo$thetaUnique[s2] 105 | ), 106 | xlab = "Correlation (on latent probit scale)", las = 1, ... 107 | ) 108 | lines(prior.cor, col = "blue", lty = "dashed") 109 | abline(v = quantile( 110 | unlist(fittedModel$runjags$mcmc[, paste0("rho[", s1, ",", s2, "]")]), 111 | c((1 - ci) / 2, 1 - (1 - ci) / 2) 112 | ), col = "red") 113 | } 114 | } 115 | } 116 | 117 | par(mfrow = mfrow) 118 | } 119 | --------------------------------------------------------------------------------