├── .Rbuildignore ├── .gitignore ├── DESCRIPTION ├── NAMESPACE ├── R ├── RcppExports.R ├── analysis.R ├── diagnosis.R ├── model-class.R ├── model.R ├── plotting.R ├── prior.R ├── random.R ├── sampling.R └── utils.R ├── README.md ├── cleanup ├── configure ├── configure.ac ├── docs └── ggdmc_0.2.8.1.tar.gz ├── ggdmc.Rproj ├── inst └── include │ ├── RcppArmadilloConfigGenerated.h.in │ ├── ggdmc.hpp │ └── ggdmc │ ├── CDDM.hpp │ ├── Design.hpp │ ├── FCalculator.hpp │ ├── LBA.hpp │ ├── Likelihood.hpp │ ├── Parameters.hpp │ ├── Phi.hpp │ ├── Prior.hpp │ ├── Sampler.hpp │ ├── tnorm.hpp │ └── vonmises.hpp ├── man ├── BuildDMI.Rd ├── BuildModel.Rd ├── BuildPrior.Rd ├── DIC-methods.Rd ├── GetNsim.Rd ├── GetPNames.Rd ├── GetParameterMatrix.Rd ├── PickStuck-methods.Rd ├── StartNewsamples.Rd ├── TableParameters.Rd ├── ac.Rd ├── autocorr.Rd ├── check_pvec.Rd ├── dbeta_lu.Rd ├── dcauchy_l.Rd ├── dcircle.Rd ├── dconstant.Rd ├── deviance_model.Rd ├── dgamma_l.Rd ├── dlnorm_l.Rd ├── dmi-class.Rd ├── dtnorm.Rd ├── effectiveSize-methods.Rd ├── gelman-methods.Rd ├── get_os.Rd ├── ggdmc.Rd ├── hyper-class.Rd ├── iseffective.Rd ├── likelihood.Rd ├── logLik-methods.Rd ├── model-class.Rd ├── names-methods.Rd ├── plot-methods.Rd ├── posterior-class.Rd ├── print-methods.Rd ├── prior-class.Rd ├── random.Rd ├── rlba_norm.Rd ├── rprior-methods.Rd ├── rvonmises.Rd ├── simulate-methods.Rd ├── summary-methods.Rd ├── trial_loglik_hier.Rd └── unstick_one.Rd └── src ├── CDDM.cpp ├── Density.cpp ├── FCalculator.cpp ├── Initialise.cpp ├── LBA.cpp ├── Makevars.in ├── Makevars.win ├── Parameters.cpp ├── Prior.cpp ├── RcppExports.cpp ├── pda.cpp ├── tnorm.cpp └── vonmises.cpp /.Rbuildignore: -------------------------------------------------------------------------------- 1 | ^.*\.Rproj$ 2 | ^\.Rproj\.user$ 3 | tests 4 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .Rproj.user 2 | .Rhistory 3 | .RData 4 | .Ruserdata 5 | src/*.o 6 | *~ 7 | src/*.so 8 | src/*.dll 9 | src/Makevars 10 | config.* 11 | inst/include/RcppArmadilloConfigGenerated.h 12 | inst/extdata/* 13 | inst/docs/* 14 | .Rproj.user/* 15 | tests/* 16 | .Rbuildignore 17 | configure 18 | rm -rf autom4te.cache/ 19 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: ggdmc 2 | Type: Package 3 | Title: Cognitive Models 4 | Version: 0.2.8.1 5 | Date: 2022-06-13 6 | Author: Yi-Shin Lin [aut, cre], Andrew Heathcote [aut] 7 | Maintainer: Yi-Shin Lin 8 | Description: The package provides tools to fit the LBA, DDM, PM and 2-D diffusion models, using the population-based Markov Chain Monte Carlo. 9 | License: GPL-2 10 | URL: https://github.com/yxlin/ggdmc 11 | BugReports: https://github.com/yxlin/ggdmc/issues 12 | LazyData: TRUE 13 | Imports: Rcpp (>= 0.12.10), stats, utils, ggplot2, matrixStats, data.table (>= 1.10.4), loo (>= 2.1.0) 14 | Depends: R (>= 3.3.0) 15 | LinkingTo: Rcpp (>= 0.12.10), RcppArmadillo (>= 0.7.100.3.0) 16 | Suggests: testthat 17 | RoxygenNote: 6.1.1 18 | Encoding: UTF-8 19 | NeedsCompilation: yes 20 | Repository: CRAN 21 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2: do not edit by hand 2 | 3 | export(BuildDMI) 4 | export(BuildModel) 5 | export(BuildPrior) 6 | export(DIC) 7 | export(GetNsim) 8 | export(GetPNames) 9 | export(GetParameterMatrix) 10 | export(PickStuck) 11 | export(StartNewsamples) 12 | export(TableParameters) 13 | export(ac) 14 | export(autocorr) 15 | export(check_pvec) 16 | export(dbeta_lu) 17 | export(dcauchy_l) 18 | export(dcircle) 19 | export(dcircle300) 20 | export(dconstant) 21 | export(deviance_model) 22 | export(dgamma_l) 23 | export(dlnorm_l) 24 | export(dtnorm) 25 | export(dvonmises) 26 | export(effectiveSize) 27 | export(gelman) 28 | export(get_os) 29 | export(iseffective) 30 | export(isflat) 31 | export(ismixed) 32 | export(isstuck) 33 | export(likelihood) 34 | export(logLik) 35 | export(plot) 36 | export(print) 37 | export(ptnorm) 38 | export(pvonmises) 39 | export(r1d) 40 | export(random) 41 | export(rcircle) 42 | export(rcircle_process) 43 | export(rlba_norm) 44 | export(rprior) 45 | export(rtnorm) 46 | export(run) 47 | export(rvonmises) 48 | export(summary) 49 | export(trial_loglik_hier) 50 | export(unstick_one) 51 | exportClasses(dmi) 52 | exportClasses(hyper) 53 | exportClasses(model) 54 | exportClasses(posterior) 55 | exportClasses(prior) 56 | exportMethods(names) 57 | exportMethods(simulate) 58 | import(ggplot2) 59 | importFrom(Rcpp,evalCpp) 60 | importFrom(data.table,data.table) 61 | importFrom(data.table,is.data.table) 62 | importFrom(data.table,melt.data.table) 63 | importFrom(graphics,abline) 64 | importFrom(graphics,hist) 65 | importFrom(loo,compare) 66 | importFrom(loo,loo.matrix) 67 | importFrom(loo,waic.matrix) 68 | importFrom(matrixStats,colMeans2) 69 | importFrom(matrixStats,colSums2) 70 | importFrom(matrixStats,colVars) 71 | importFrom(matrixStats,rowMaxs) 72 | importFrom(matrixStats,rowMeans2) 73 | importFrom(matrixStats,rowMins) 74 | importFrom(matrixStats,rowSds) 75 | importFrom(parallel,makeCluster) 76 | importFrom(parallel,mclapply) 77 | importFrom(parallel,parLapply) 78 | importFrom(parallel,stopCluster) 79 | importFrom(stats,IQR) 80 | importFrom(stats,ar) 81 | importFrom(stats,dbeta) 82 | importFrom(stats,dcauchy) 83 | importFrom(stats,density) 84 | importFrom(stats,dgamma) 85 | importFrom(stats,dlnorm) 86 | importFrom(stats,dunif) 87 | importFrom(stats,lm) 88 | importFrom(stats,median) 89 | importFrom(stats,qf) 90 | importFrom(stats,residuals) 91 | importFrom(stats,sd) 92 | importFrom(stats,var) 93 | importFrom(utils,glob2rx) 94 | useDynLib(ggdmc) 95 | -------------------------------------------------------------------------------- /R/diagnosis.R: -------------------------------------------------------------------------------- 1 | ##' Unstick posterios samples (One subject) 2 | ##' 3 | ##' @param x posterior samples 4 | ##' @param bad a numeric vector, indicating which chains to remove 5 | ##' @export 6 | unstick_one <- function(x, bad) { 7 | 8 | if (length(bad) > 0) 9 | { 10 | if (!all(bad %in% 1:x@nchain)) 11 | stop(paste("Index of bad chains must be in 1 to ", x@nchain)) 12 | 13 | x@theta <- x@theta[,-bad,] 14 | x@summed_log_prior <- x@summed_log_prior[-bad,] 15 | x@log_likelihoods <- x@log_likelihoods[-bad,] 16 | x@nchain <- x@nchain - length(bad) 17 | } 18 | return(x) 19 | } 20 | 21 | 22 | ##' Model checking functions 23 | ##' 24 | ##' The function tests whether we have drawn enough samples. 25 | ##' 26 | ##' @param x posterior samples 27 | ##' @param minN specify the size of minimal effective samples 28 | ##' @param nfun specify to use the \code{mean} or \code{median} function to 29 | ##' calculate effective samples 30 | ##' @param verbose print more information 31 | ##' @export 32 | iseffective <- function(x, minN, nfun, verbose = FALSE) { 33 | n <- do.call(nfun, list(effectiveSize(x, verbose = verbose))) 34 | fail <- n < minN 35 | if (verbose) { 36 | cat("Length check") 37 | if (!fail) cat(": OK\n") else cat(paste(":",n,"\n")) 38 | } 39 | fail 40 | } 41 | 42 | ##' @rdname PickStuck-methods 43 | CheckConverged <- function(x) 44 | { 45 | stuck <- isstuck(x, verbose = FALSE, cut = 10) 46 | flat <- isflat(x, p1 = 1/3, p2 = 1/3, 47 | cut_location = 0.25, cut_scale = Inf, verbose = FALSE) 48 | mix <- ismixed(x, cut = 1.05, verbose = FALSE) 49 | size <- iseffective(x, minN = 500, nfun = "mean", FALSE) 50 | isstuck <- TRUE 51 | if (stuck == 0) isstuck <- FALSE 52 | 53 | out <- c(isstuck, flat, mix, size) 54 | names(out) <- c("Stuck", "Flat", "Mix", "ES") 55 | return(out) 56 | } 57 | 58 | 59 | -------------------------------------------------------------------------------- /R/random.R: -------------------------------------------------------------------------------- 1 | ######### r-functions ----------------------------------- 2 | rdiffusion <- function (n, 3 | a, v, z = 0.5*a, d = 0, sz = 0, sv = 0, t0 = 0, st0 = 0, 4 | s = 1, precision = 3, stop_on_error = TRUE) 5 | { 6 | ## @author Underlying C code by Jochen Voss and Andreas Voss. Porting and R 7 | ## wrapping by Matthew Gretton, Andrew Heathcote, Scott Brown, and Henrik 8 | ## Singmann. 9 | ## \code{qdiffusion} by Henrik Singmann. This function is extracted from 10 | ## rtdists written by the above authors. 11 | 12 | if(any(missing(a), missing(v), missing(t0))) 13 | stop("a, v, and/or t0 must be supplied") 14 | 15 | s <- rep(s, length.out = n) 16 | a <- rep(a, length.out = n) 17 | v <- rep(v, length.out = n) 18 | z <- rep(z, length.out = n) 19 | z <- z/a # transform z from absolute to relative scale (which is currently required by the C code) 20 | d <- rep(d, length.out = n) 21 | sz <- rep(sz, length.out = n) 22 | sz <- sz/a # transform sz from absolute to relative scale (which is currently required by the C code) 23 | sv <- rep(sv, length.out = n) 24 | t0 <- rep(t0, length.out = n) 25 | st0 <- rep(st0, length.out = n) 26 | 27 | # Build parameter matrix (and divide a, v, and sv, by s) 28 | params <- cbind (a, v, z, d, sz, sv, t0, st0, s) 29 | 30 | # Check for illegal parameter values 31 | if(ncol(params)<8) 32 | stop("Not enough parameters supplied: probable attempt to pass NULL values?") 33 | if(!is.numeric(params)) 34 | stop("Parameters need to be numeric.") 35 | if (any(is.na(params)) || !all(is.finite(params))) 36 | stop("Parameters need to be numeric and finite.") 37 | 38 | randRTs <- vector("numeric",length=n) 39 | randBounds <- vector("numeric",length=n) 40 | 41 | parameter_char <- apply(params, 1, paste0, collapse = "\t") 42 | parameter_factor <- factor(parameter_char, levels = unique(parameter_char)) 43 | parameter_indices <- split(seq_len(n), f = parameter_factor) 44 | 45 | for (i in seq_len(length(parameter_indices))) 46 | { 47 | ok_rows <- parameter_indices[[i]] 48 | 49 | # Calculate n for this row 50 | current_n <- length(ok_rows) 51 | 52 | out <- r_fastdm (current_n, 53 | params[ok_rows[1],1:9], 54 | precision, 55 | stop_on_error=stop_on_error) 56 | #current_n, uniques[i,1:8], precision, stop_on_error=stop_on_error) 57 | 58 | randRTs[ok_rows] <- out$rt 59 | randBounds[ok_rows] <- out$boundary 60 | } 61 | response <- factor(randBounds, levels = 0:1, labels = c("lower", "upper")) 62 | data.frame(rt = randRTs, response) 63 | } 64 | 65 | ######### Generic functions ----------------------------------- 66 | ##' Random number generation 67 | ##' 68 | ##' A wrapper function for generating random numbers from different model types, 69 | ##' \code{rd}, \code{norm}, \code{norm_pda}, \code{norm_pda_gpu}, or 70 | ##' \code{cddm}. \code{pmat} is generated usually by \code{TableParameter}. 71 | ##' 72 | ##' Note PM model uses \code{norm} type. 73 | ##' 74 | ##' @param type a character string of the model type 75 | ##' @param pmat a matrix of response x parameter 76 | ##' @param n number of observations. This must be an integer. 77 | ##' @param seed an integer specifying a random seed 78 | ##' @param ... other arguments 79 | ##' @examples 80 | ##' model <- BuildModel( 81 | ##' p.map = list(a = "1", v="1", z="1", d="1", sz="1", sv="1", t0="1", st0="1"), 82 | ##' match.map = list(M = list(s1 = "r1", s2 = "r2")), 83 | ##' factors = list(S = c("s1", "s2")), 84 | ##' responses = c("r1","r2"), 85 | ##' constants = c(st0 = 0, d = 0, sv = 0, sz = 0), 86 | ##' type = "rd") 87 | ##' 88 | ##' p.vector <- c(a=1, v=1.5, z=0.6, t0=.15) 89 | ##' 90 | ##' pmat <- TableParameters(p.vector, 1, model, FALSE) 91 | ##' type <- model@type; 92 | ##' res1 <- random(type, pmat, 1) 93 | ##' res2 <- random(type, pmat, 10) 94 | ##' 95 | ##' model <- BuildModel( 96 | ##' p.map = list(A = "1", B = "R", t0 = "1", mean_v = c("D", "M"), 97 | ##' sd_v = "M", st0 = "1"), 98 | ##' match.map = list(M = list(s1 = 1, s2 = 2)), 99 | ##' factors = list(S = c("s1", "s2"), D = c("d1", "d2")), 100 | ##' constants = c(sd_v.false = 1, st0 = 0), 101 | ##' responses = c("r1", "r2"), 102 | ##' type = "norm") 103 | ##' 104 | ##' p.vector <- c(A=.51, B.r1=.69, B.r2=.88, t0=.24, mean_v.d1.true=1.1, 105 | ##' mean_v.d2.true=1.0, mean_v.d1.false=.34, mean_v.d2.false=.02, 106 | ##' sd_v.true=.11) 107 | ##' 108 | ##' pmat <- TableParameters(p.vector, 1, model, FALSE) 109 | ##' type <- model@type; 110 | ##' res1 <- random(type, pmat, 1) 111 | ##' res2 <- random(type, pmat, 10) 112 | ##' @export 113 | random <- function(type, pmat, n, seed = NULL, ...) 114 | { 115 | set.seed(seed) 116 | if (type == "rd") { 117 | out <- rdiffusion(n, a = pmat$a[1], v = pmat$v[1], 118 | t0 = pmat$t0[1], 119 | z = pmat$z[1]*pmat$a[1], # convert to absolute 120 | d = pmat$d[1], 121 | sz = pmat$sz[1]*pmat$a[1], 122 | sv = pmat$sv[1], st0 = pmat$st0[1], stop_on_error = TRUE) 123 | 124 | } else if (type %in% c("norm", "norm_pda", "norm_pda_gpu")) { 125 | ## posdrift is always TRUE in simulation 126 | ## pmat: A b t0 mean_v sd_v st0 (nacc) 127 | if (ncol(pmat) == 7) ## PM model 128 | { 129 | ## The only difference is to selectively pick 2 or 3 accumulators. 130 | ## This has been done by BuildModel and p_df. 131 | nacc <- pmat[1,7] 132 | A <- pmat[1:nacc,1] 133 | b <- pmat[1:nacc,2] 134 | t0 <- pmat[1:nacc,3] 135 | mean_v <- pmat[1:nacc,4] 136 | sd_v <- pmat[1:nacc,5] 137 | st0 <- pmat[1:nacc,6] 138 | posdrift <- TRUE 139 | 140 | out <- rlba_norm(n, A, b, mean_v, sd_v, t0, st0, posdrift) 141 | } 142 | else 143 | { 144 | out <- rlba_norm(n, pmat[, 1], pmat[, 2], pmat[, 4], pmat[, 5], 145 | pmat[,3], pmat[1,6], TRUE) 146 | } 147 | 148 | } else if (type=="cddm") { 149 | # nw <- nrow(pmat) 150 | pvec <- as.vector(t(pmat[1,])) 151 | out <- rcircle(n=n, P=pvec[1:8], tmax=pvec[9], h=pvec[10], 152 | nw = nrow(pmat)) 153 | } else { 154 | stop("Model type yet created") 155 | } 156 | 157 | attr(out, "seed") <- seed 158 | return(out) 159 | } 160 | 161 | 162 | #### Post-predictive functions -------------- 163 | # predict_one <- function(object, npost = 100, rand = TRUE, factors = NA, 164 | # xlim = NA, seed = NULL) 165 | # { 166 | # # object <- fit 167 | # # factors = NA 168 | # model <- attributes(object$data)$model 169 | # facs <- names(attr(model, "factors")) 170 | # class(object$data) <- c("data.frame", "list") 171 | # 172 | # if (!is.null(factors)) 173 | # { 174 | # if (any(is.na(factors))) factors <- facs 175 | # if (!all(factors %in% facs)) 176 | # stop(paste("Factors argument must contain one or more of:", 177 | # paste(facs, collapse=","))) 178 | # } 179 | # 180 | # resp <- names(attr(model, "responses")) 181 | # ns <- table(object$data[,facs], dnn = facs) 182 | # npar <- object$n.pars 183 | # nchain <- object$n.chains 184 | # nmc <- object$nmc 185 | # ntsample <- nchain * nmc 186 | # pnames <- object$p.names 187 | # # str(object$theta) ## npar x nchain x nmc 188 | # # str(thetas) ## (nchain x nmc) x npar 189 | # thetas <- matrix(aperm(object$theta, c(3,2,1)), ncol = npar) 190 | # 191 | # # head(thetas) 192 | # # head(object$theta[,,1:2]) 193 | # 194 | # colnames(thetas) <- pnames 195 | # 196 | # if (is.na(npost)) { 197 | # use <- 1:ntsample 198 | # } else { 199 | # if (rand) { 200 | # use <- sample(1:ntsample, npost, replace = F) 201 | # } else { 202 | # use <- round(seq(1, ntsample, length.out = npost)) 203 | # } 204 | # } 205 | # 206 | # npost <- length(use) 207 | # posts <- thetas[use, ] 208 | # nttrial <- sum(ns) ## number of total trials 209 | # 210 | # ## should replace with parallel 211 | # v <- lapply(1:npost, function(i) { 212 | # simulate_one(model, n = ns, ps = posts[i,], seed = seed) 213 | # }) 214 | # out <- data.table::rbindlist(v) 215 | # # names(out) <- names(object$data) 216 | # reps <- rep(1:npost, each = nttrial) 217 | # out <- cbind(reps, out) 218 | # 219 | # if (!any(is.na(xlim))) 220 | # { 221 | # out <- out[RT > xlim[1] & RT < xlim[2]] 222 | # } 223 | # 224 | # attr(out, "data") <- object$data 225 | # return(out) 226 | # } 227 | 228 | ######### Utility functions ----------------------------------- 229 | "%w/o%" <- function(x, y) x[!x %in% y] #-- x without y 230 | 231 | 232 | LabelTheta <- function(dat, response) 233 | { 234 | ## This is a new function for cddm only 235 | nw <- length(response) 236 | w <- 2*pi/nw 237 | theta <- seq(-pi, pi-w, w) 238 | R <- rep(NA, nrow(dat)) 239 | for(i in 1:nw) 240 | { 241 | idx <- which(round(dat$R, 2) == round(theta[i], 2)) 242 | R[idx] <- response[i] 243 | } 244 | 245 | out <- factor(R, levels=response) 246 | return(out) 247 | } -------------------------------------------------------------------------------- /R/sampling.R: -------------------------------------------------------------------------------- 1 | ### Sampling ------------------------------------------------------------------- 2 | 3 | ##' @importFrom parallel parLapply 4 | ##' @importFrom parallel makeCluster 5 | ##' @importFrom parallel mclapply 6 | ##' @importFrom parallel stopCluster 7 | run_many <- function(dmi, prior, nchain, nmc, thin, report, rp, gammamult, 8 | pm0, pm1, block, ncore) 9 | { 10 | 11 | if (get_os() == "windows" & ncore > 1) 12 | { 13 | cl <- parallel::makeCluster(ncore) 14 | message("fits multi-participant in parallel") 15 | out <- parallel::parLapply(cl = cl, X = dmi, 16 | init_new, prior, nchain, nmc, thin, report, 17 | rp, gammamult, pm0, pm1, block) 18 | parallel::stopCluster(cl) 19 | } 20 | else if (ncore > 1) 21 | { 22 | message("fits multi-participant in parallel") 23 | out <- parallel::mclapply(dmi, init_new, prior, nchain, nmc, thin, 24 | report, rp, gammamult, pm0, pm1, block, 25 | mc.cores=getOption("mc.cores", ncore)) 26 | } 27 | else 28 | { 29 | message("fits multi-participant with lapply") 30 | out <- lapply(dmi, init_new, prior, nchain, nmc, thin, report, rp, 31 | gammamult, pm0, pm1, block) 32 | } 33 | 34 | return(out) 35 | } 36 | 37 | ##' @importFrom parallel parLapply 38 | ##' @importFrom parallel makeCluster 39 | ##' @importFrom parallel mclapply 40 | ##' @importFrom parallel stopCluster 41 | rerun_many <- function(samples, nmc, thin, report, rp, gammamult, pm0, pm1, 42 | block, add, ncore) 43 | { 44 | message("Fit multi-participant") 45 | 46 | if (get_os() == "windows" & ncore > 1) 47 | { 48 | cl <- parallel::makeCluster(ncore) 49 | out <- parallel::parLapply(cl = cl, X = samples, 50 | init_old, nmc, thin, report, rp, 51 | gammamult, pm0, pm1, block, add) 52 | parallel::stopCluster(cl) 53 | } 54 | else if (ncore > 1) 55 | { 56 | out <- parallel::mclapply(samples, init_old, nmc, thin, report, rp, 57 | gammamult, pm0, pm1, block, add, 58 | mc.cores=getOption("mc.cores", ncore)) 59 | } 60 | else 61 | { 62 | out <- lapply(samples, init_old, nmc, thin, report, rp, 63 | gammamult, pm0, pm1, block, add) 64 | } 65 | 66 | return(out) 67 | } 68 | 69 | ##' Start new model fits 70 | ##' 71 | ##' Fit a hierarchical or a fixed-effect model, using Bayeisan 72 | ##' optimisation. We use a specific type of pMCMC algorithm, the DE-MCMC. This 73 | ##' particular sampling method includes crossover and two different migration 74 | ##' operators. The migration operators are similar to random-walk algorithm. 75 | ##' They would be less efficient to find the target parameter space, if been 76 | ##' used alone. 77 | ##' 78 | ##' @param dmi a data model instance or a list of data model instances 79 | ##' @param samples posterior samples. 80 | ##' @param prior prior objects. For hierarchical model, this must be a 81 | ##' list with three sets of prior distributions. Each is respectively named, 82 | ##' "pprior", "location", and "scale". 83 | ##' @param nmc number of Monte Carlo samples 84 | ##' @param thin thinning length 85 | ##' @param nchain number of chains 86 | ##' @param report progress report interval 87 | ##' @param rp tuning parameter 1 88 | ##' @param gammamult tuning parameter 2. This is the step size. 89 | ##' @param pm0 probability of migration type 0 (Hu & Tsui, 2010) 90 | ##' @param pm1 probability of migration type 1 (Turner et al., 2013) 91 | ##' @param block Only for hierarchical modeling. A Boolean switch for update one 92 | ##' parameter at a time 93 | ##' @param ncore Only for non-hierarchical, fixed-effect models with many 94 | ##' subjects. 95 | ##' @param add Boolean whether to add new samples 96 | ##' 97 | ##' @export 98 | StartNewsamples <- function(dmi, prior, nmc=2e2, thin=1, nchain=NULL, 99 | report=1e2, rp=.001, gammamult=2.38, pm0=.05, 100 | pm1=.05, block=TRUE, ncore=1) 101 | { 102 | if ( !missingArg(prior) && 103 | all(c("pprior", "location", "scale") %in% names(prior)) && 104 | length(prior) == 3 ) 105 | { 106 | nchain <- CheckHyperDMI(dmi, prior, nchain) 107 | tmp0 <- sapply(dmi, checklba) 108 | 109 | message("Hierarchical model: ", appendLF = FALSE) 110 | t0 <- Sys.time() 111 | out <- init_newhier(prior[[1]], prior[[2]], prior[[3]], dmi, nchain, nmc, 112 | thin, report, rp, gammamult, pm0, pm1, block) 113 | t1 <- Sys.time() 114 | } else if ( class(dmi) == "list" ) { 115 | nchain <- sapply(dmi, CheckDMI, prior=prior, nchain=nchain) 116 | nchain <- unique(nchain) 117 | tmp0 <- sapply(dmi, checklba) 118 | 119 | message("Fixed-effect model ", appendLF=FALSE) 120 | t0 <- Sys.time() 121 | out <- run_many(dmi, prior, nchain, nmc, thin, report, rp, gammamult, pm0, 122 | pm1, block, ncore) 123 | t1 <- Sys.time() 124 | 125 | } else if (class(dmi) == "dmi") { 126 | nchain <- CheckDMI(dmi, prior, nchain) 127 | if(is.null(nchain)) nchain <- 3*slot(prior, "npar") 128 | checklba(dmi) 129 | 130 | message("Fixed-effect model (ncore has no effect): ", appendLF = FALSE) 131 | t0 <- Sys.time() 132 | out <- init_new(dmi, prior, nchain, nmc, thin, report, rp, gammamult, pm0, 133 | pm1, block) 134 | t1 <- Sys.time() 135 | } else { 136 | stop("Class undefined") 137 | } 138 | 139 | proc_time <- difftime(t1, t0, units = "secs")[[1]] 140 | message("Processing time: ", round(proc_time, 2), " secs.") 141 | 142 | return(out) 143 | } 144 | 145 | ##' @rdname StartNewsamples 146 | ##' @export 147 | run <- function(samples, nmc=5e2, thin=1, report=1e2, rp=.001, 148 | gammamult=2.38, pm0=0, pm1=0, block=TRUE, ncore=1, 149 | add=FALSE, prior= NULL) 150 | { 151 | 152 | if ( class(samples) == "hyper" ) 153 | { 154 | t0 <- Sys.time() 155 | out <- init_oldhier(samples, nmc, thin, report, rp, gammamult, pm0, pm1, 156 | block, add) 157 | t1 <- Sys.time() 158 | 159 | } 160 | else if ( is.list(samples) & is.null(prior)) 161 | { 162 | 163 | t0 <- Sys.time() 164 | out <- rerun_many(samples, nmc, thin, report, rp, gammamult, pm0, pm1, 165 | block, add, ncore) 166 | t1 <- Sys.time() 167 | names(out) <- names(samples) 168 | 169 | } 170 | else if (is.list(samples) & !is.null(prior)) 171 | { 172 | t0 <- Sys.time() 173 | out <- init_oldhier_from_fixed_model(samples, prior[[1]], prior[[2]], nmc, 174 | thin, report, rp, gammamult, 175 | pm0, pm1, block, add) 176 | t1 <- Sys.time() 177 | } 178 | else 179 | { 180 | t0 <- Sys.time() 181 | out <- init_old(samples, nmc, thin, report, rp, gammamult, pm0, pm1, 182 | block, add) 183 | t1 <- Sys.time() 184 | } 185 | 186 | proc_time <- difftime(t1, t0, units = "secs")[[1]] 187 | message("Processing time: ", round(proc_time, 2), " secs.") 188 | 189 | return(out) 190 | } 191 | 192 | ## Utilities ------------------------------------------------------------------ 193 | CheckDMI <- function(d = NULL, prior = NULL, nchain=NULL) 194 | { 195 | # data <- dmi 196 | # prior <- p.prior 197 | if (is.null(d)) stop("No data model instance") 198 | if (!is.data.frame(d@data)) stop("Data must be a data frame") 199 | 200 | model <- d@model 201 | priors <- prior@priors 202 | npar <- model@npar 203 | 204 | if (is.null(model)) stop("Must specify a model") 205 | if (is.null(priors)) stop("Must specify prior distributions") 206 | if (prior@npar != npar) 207 | { 208 | stop("data prior incompatible with model") 209 | } 210 | 211 | if (is.null(nchain)) nchain <- 3*npar 212 | return(nchain) 213 | } 214 | 215 | CheckHyperDMI <- function(data, prior = NULL, nchain = NULL) 216 | { 217 | ## data 218 | if (missingArg(data)) stop("No data-model instance") 219 | if (is.data.frame(data)) stop("data must not be a data.frame") 220 | 221 | ## Prior 222 | for (i in 1:3) if (is.null(prior[[i]])) stop("No prior distribution") 223 | if ( prior[[1]]@npar < prior[[2]]@npar ) 224 | stop("Location and scale priors differ in the numbers of parameters") 225 | 226 | model1 <- data[[1]]@model 227 | pnames <- model1@pnames 228 | 229 | isppriorok <- pnames %in% prior[[1]]@pnames 230 | islpriorok <- pnames %in% prior[[2]]@pnames 231 | isspriorok <- pnames %in% prior[[3]]@pnames 232 | 233 | if (!all(isppriorok)) { 234 | cat("Here is the parameter in your model\n") 235 | print(pnames) 236 | cat("Here is the parameter in your data prior\n") 237 | print(slot(prior[[1]], "pnames")) 238 | stop("data prior incompatible with model") 239 | } 240 | if (!all(islpriorok)) stop("location prior incompatible with model") 241 | if (!all(isppriorok)) stop("scale prior incompatible with model") 242 | 243 | ## nchain 244 | if (is.null(nchain)) { 245 | nchain <- 3*length(pnames) 246 | message("Use ", nchain, " chains") 247 | } 248 | 249 | return(nchain) 250 | } 251 | -------------------------------------------------------------------------------- /R/utils.R: -------------------------------------------------------------------------------- 1 | ### Hierarchical tools ------------------------------------------------ 2 | is_multimodel <- function(model, ns = NA) 3 | ## Used in simulate_many 4 | { 5 | if (is.list(model)) 6 | { 7 | if (length(model) != ns) 8 | stop("number of participants not equal to number of models") 9 | out <- TRUE 10 | } 11 | else 12 | { 13 | if (is.na(ns)) stop("Must indicate the number of participants") 14 | out <- FALSE 15 | } 16 | return(out) 17 | } 18 | 19 | ##' Extract trial log likelihoods 20 | ##' 21 | ##' This function simply run trial_loglik to loop through one subject after 22 | ##' another to extracts trial_log_likes from a list of subject fits and 23 | ##' concatanates the result into an array. 24 | ##' 25 | ##' @param samples posterior samples 26 | ##' @param thin thinnng length 27 | ##' @param verbose whether print information 28 | ##' @export 29 | trial_loglik_hier <- function(samples, thin = 1, verbose=FALSE) 30 | { 31 | check <- function(x) { 32 | nmc <- min(x[1,]) 33 | 34 | if ( !all(x[3,1]==x[3,-1]) ) 35 | warning(paste("Subjects do not all have the same number of interations, using first", 36 | nmc,"for all.")) 37 | 38 | if ( !all(x[2,1]==x[2,-1]) ) 39 | stop("Subjects must have the same number of chains") 40 | } 41 | 42 | PrintSize <- function(x, thin) { 43 | 44 | tll <- trial_loglik(x@individuals[[1]], thin) 45 | 46 | nsub <- length(x@snames) 47 | sdim <- dim(tll); ## sdim ## ntrial x nchain x nnmc_thin 48 | size <- sum(nsub * prod(sdim)) 49 | 50 | ## nchain and nmc per subject 51 | nmc_nchain_mat <- sapply(x, function(xx) { dim(xx@log_likelihoods) } ) 52 | 53 | dimnames(nmc_nchain_mat) <- list(c("Chains", "Trials"), names(x)) 54 | message("Log-likelihood dimension") 55 | print(nmc_nchain_mat) 56 | 57 | names(sdim) <- c("Trials","Chains","Iterations") 58 | message("\nSubject 1") 59 | print(sdim) 60 | message("Total log-likelihoods: ", appendLF=FALSE) 61 | cat(round(size/1e6,2), "millions)\n") 62 | return(NULL) 63 | } 64 | 65 | if(verbose) PrintSize(samples, thin) 66 | 67 | tlls <- lapply(samples@individuals, trial_loglik, thin) 68 | 69 | sdims <- sapply(tlls, dim) ## DMC nmc_thin, nchain, ntrial 70 | nmc <- min(sdims[3,]) ## nnmc_thin 71 | check(sdims) 72 | 73 | ### nmc_thin x nchain x (ntrial x nsub) 74 | out <- array(dim=c(nmc, dim(tlls[[1]])[2], sum(sdims[1,]))) 75 | nsub <- length(samples@snames) 76 | 77 | start <- 1; 78 | end <- sdims[1,1] 79 | 80 | for (i in 1:nsub) 81 | { 82 | out[,,start:end] <- aperm(tlls[[i]], c(3, 2, 1)) 83 | if (i < nsub) 84 | { 85 | start <- end+1 86 | end <- start - 1 + sdims[1, i+1] 87 | } 88 | } 89 | return(out) 90 | } 91 | 92 | 93 | ##' Calculate the autocorrelation of a vector 94 | ##' 95 | ##' Calculate the autocorrelation of a vector. 96 | ##' 97 | ##' @param x a vector storing parameter values 98 | ##' @param nLags the maximum number of lags 99 | ##' @return A data.frame 100 | ##' @export 101 | ##' @examples 102 | ##' res <- ac(1:100) 103 | ##' ## List of 2 104 | ##' ## $ Lag : int [1:50] 1 2 3 4 5 6 7 8 9 10 ... 105 | ##' ## $ Autocorrelation: num [1:50] 1 1 1 1 1 1 1 1 1 1 ... 106 | ##' 107 | ##' res <- ac(rnorm(100)) 108 | ##' str(res) 109 | ##' ## List of 2 110 | ##' ## $ Lag : int [1:50] 1 2 3 4 5 6 7 8 9 10 ... 111 | ##' ## $ Autocorrelation: num [1:50] 1 -0.0485 0.0265 -0.1496 0.0437 ... 112 | ac <- function(x, nLags = 50) 113 | { 114 | tmp <- ac_(x, nLags) 115 | return( list(Lag = 1:nLags, Autocorrelation=tmp[,1])) 116 | } 117 | 118 | 119 | ### Generic --------------------------------------------- 120 | ##' Retrieve information of operating system 121 | ##' 122 | ##' A wrapper function to extract system information from \code{Sys.info} 123 | ##' and \code{.Platform} 124 | ##' 125 | ##' @examples 126 | ##' get_os() 127 | ##' ## sysname 128 | ##' ## "linux" 129 | ##' @export 130 | get_os <- function() 131 | { 132 | sysinf <- Sys.info() 133 | ostype <- .Platform$OS.type 134 | 135 | ## Probe using Sys.info: Windows, Linux or Darwin 136 | if (!is.null(sysinf)) { 137 | os <- sysinf["sysname"] 138 | if (os == "Darwin") os <- "osx" 139 | } else { 140 | ## If something gets wrong with Sys.info, probe using .Platform 141 | os <- .Platform$OS.type 142 | if (grepl("^darwin", R.version$os)) os <- "osx" 143 | if (grepl("unix", R.version$os)) os <- "osx" 144 | if (grepl("linux-gnu", R.version$os)) os <- "linux" 145 | if (grepl("mingw32", R.version$os)) os <- "windows" 146 | } 147 | tolower(os) 148 | } 149 | 150 | 151 | 152 | checklba <- function(x) 153 | { 154 | model <- slot(x, "model") 155 | if (slot(model, "type") == "norm" ) 156 | { 157 | parnames <- slot(model, "par.names") 158 | if ( (which(parnames == "A") != 1) | 159 | (which(parnames == "B") != 2) | 160 | (which(parnames == "t0") != 3) | 161 | (which(parnames == "mean_v") != 4) | 162 | (which(parnames == "sd_v") != 5) | 163 | (which(parnames == "st0") != 6) ) 164 | { 165 | cat("Your p.vector is order as: ", parnames, "\n") 166 | message("It must be in the order of: A, B, t0, mean_v, sd_v, & st0.") 167 | stop("Check p.map") 168 | } 169 | } 170 | 171 | } 172 | 173 | ##' Extract parameter names from a model object 174 | ##' 175 | ##' GetPNames will be deprecated. Please extract pnames directly via S4 slot 'model@pnames' 176 | ##' @param x a model object 177 | ##' 178 | ##' @export 179 | GetPNames <- function(x) { 180 | warning("GetPNames will be deprecated. Please extract pnames directly via S4 slot 'model@pnames'") 181 | return(x@pnames) 182 | } 183 | 184 | -------------------------------------------------------------------------------- /cleanup: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | rm -f config.log config.status confdefs.h \ 4 | src/*.o src/*.so src/symbols.rds \ 5 | */*~ *~ \ 6 | inst/include/RcppArmadilloLapack.h \ 7 | inst/include/RcppArmadilloConfigGenerated.h \ 8 | src/Makevars 9 | 10 | rm -rf autom4te.cache/ 11 | -------------------------------------------------------------------------------- /configure.ac: -------------------------------------------------------------------------------- 1 | ## -*- mode: autoconf; autoconf-indentation: 4; -*- 2 | ## 3 | ## RcppArmadillo configure.ac 4 | ## 5 | ## 'Rcpp' Integration for the 'Armadillo' Templated Linear Algebra Library 6 | ## 7 | ## Copyright (C) 2016 - 2018 Dirk Eddelbuettel 8 | ## 9 | ## Licensed under GPL-2 or later 10 | 11 | ## ----------------------------------------------------------------------- 12 | ## This file is from RcppArmadillo 0.9.300.2.0 together with the file, 13 | ## "inst/include/RcppArmadilloConfigGenerated.h.in". configure.ac 14 | ## enables or disables OpenMP on Unix or macOS systems 15 | ## 16 | ## Generate the configure file by entering, 17 | ## "autoconf --output=configure configure.ac" 18 | ## ----------------------------------------------------------------------- 19 | 20 | ## require at least autoconf 2.61 21 | AC_PREREQ(2.61) 22 | 23 | ## Process this file with autoconf to produce a configure script. 24 | ## Note the name of the package is changed from RcppArmadillo to ggdmc 25 | AC_INIT(ggdmc, m4_esyscmd_s([awk -e '/^Version:/ {print $2}' DESCRIPTION])) 26 | 27 | ## Set R_HOME, respecting an environment variable if one is set 28 | : ${R_HOME=$(R RHOME)} 29 | if test -z "${R_HOME}"; then 30 | AC_MSG_ERROR([Could not determine R_HOME.]) 31 | fi 32 | ## Use R to set CXX and CXXFLAGS 33 | CXX=$(${R_HOME}/bin/R CMD config CXX) 34 | CXXFLAGS=$("${R_HOME}/bin/R" CMD config CXXFLAGS) 35 | 36 | ## We are using C++ 37 | AC_LANG(C++) 38 | AC_REQUIRE_CPP 39 | 40 | ## default to not even thinking about OpenMP as Armadillo wants a pragma 41 | ## variant available if and only if C++11 is used with g++ 5.4 or newer 42 | can_use_openmp="" 43 | 44 | ## Check the C++ compiler using the CXX value set 45 | AC_PROG_CXX 46 | ## If it is g++, we have GXX set so let's examine it 47 | if test "${GXX}" = yes; then 48 | AC_MSG_CHECKING([whether g++ version is sufficient]) 49 | gxx_version=$(${CXX} -v 2>&1 | awk '/^.*g.. version/ {print $3}') 50 | case ${gxx_version} in 51 | 1.*|2.*|3.*|4.0.*|4.1.*|4.2.*|4.3.*|4.4.*|4.5.*|4.6.*|4.7.0|4.7.1) 52 | AC_MSG_RESULT([no]) 53 | AC_MSG_WARN([Only g++ version 4.7.2 or greater can be used with RcppArmadillo.]) 54 | AC_MSG_ERROR([Please use a different compiler.]) 55 | ;; 56 | 4.7.*|4.8.*|4.9.*|5.0*|5.1*|5.2*|5.3*) 57 | AC_MSG_RESULT([yes, but without OpenMP as version ${gxx_version} (Armadillo constraint)]) 58 | ## we know this one is bad 59 | can_use_openmp="no" 60 | ;; 61 | 5.4*|5.5*|5.6*|5.7*|5.8*|5.9*|6.*|7.*|8.*|9.*|10.*) 62 | AC_MSG_RESULT([yes, with OpenMP as version ${gxx_version}]) 63 | ## we know this one is good, yay 64 | can_use_openmp="yes" 65 | ;; 66 | *) 67 | AC_MSG_RESULT([almost]) 68 | AC_MSG_WARN([Compiler self-identifies as being compliant with GNUC extensions but is not g++.]) 69 | ## we know nothing, so no 70 | can_use_openmp="no" 71 | ;; 72 | esac 73 | fi 74 | 75 | ## Check for Apple LLVM 76 | 77 | AC_MSG_CHECKING([for macOS]) 78 | RSysinfoName=$("${R_HOME}/bin/Rscript" --vanilla -e 'cat(Sys.info()[["sysname"]])') 79 | 80 | if test x"${RSysinfoName}" == x"Darwin"; then 81 | AC_MSG_RESULT([found]) 82 | AC_MSG_CHECKING([for macOS Apple compiler]) 83 | 84 | apple_compiler=$($CXX --version 2>&1 | grep -i -c -e 'apple llvm') 85 | 86 | if test x"${apple_compiler}" == x"1"; then 87 | AC_MSG_RESULT([found]) 88 | AC_MSG_WARN([OpenMP unavailable and turned off.]) 89 | can_use_openmp="no" 90 | else 91 | AC_MSG_RESULT([not found]) 92 | AC_MSG_CHECKING([for clang compiler]) 93 | clang_compiler=$($CXX --version 2>&1 | grep -i -c -e 'clang ') 94 | 95 | if test x"${clang_compiler}" == x"1"; then 96 | AC_MSG_RESULT([found]) 97 | AC_MSG_CHECKING([for OpenMP compatible version of clang]) 98 | clang_version=$(${CXX} -v 2>&1 | awk '/^.*clang version/ {print $3}') 99 | 100 | case ${clang_version} in 101 | 4.*|5.*|6.*|7.*|8.*) 102 | AC_MSG_RESULT([found and suitable]) 103 | can_use_openmp="yes" 104 | ;; 105 | *) 106 | AC_MSG_RESULT([not found]) 107 | AC_MSG_WARN([OpenMP unavailable and turned off.]) 108 | can_use_openmp="no" 109 | ;; 110 | esac 111 | else 112 | AC_MSG_RESULT([not found]) 113 | AC_MSG_WARN([unsupported macOS build detected; if anything breaks, you keep the pieces.]) 114 | fi 115 | fi 116 | fi 117 | 118 | ## Check for suitable LAPACK_LIBS 119 | AC_MSG_CHECKING([LAPACK_LIBS]) 120 | 121 | ## external LAPACK has the required function 122 | lapack=$(${R_HOME}/bin/R CMD config LAPACK_LIBS) 123 | hasRlapack=$(echo ${lapack} | grep lRlapack) 124 | 125 | ## in what follows below we substitute both side of the define/undef 126 | ## while this may seem a little unusual we do it to fully reproduce the 127 | ## previous bash-based implementation 128 | 129 | if test x"${hasRlapack}" == x""; then 130 | ## We are using a full Lapack and can use zgbsv -- so #undef remains 131 | AC_MSG_RESULT([system LAPACK found]) 132 | arma_lapack="#undef ARMA_CRIPPLED_LAPACK" 133 | else 134 | ## We are using R's subset of Lapack and CANNOT use zgbsv etc, so we mark it 135 | AC_MSG_RESULT([R-supplied partial LAPACK found]) 136 | AC_MSG_WARN([Some complex-valued LAPACK functions may not be available]) 137 | arma_lapack="#define ARMA_CRIPPLED_LAPACK 1" 138 | fi 139 | 140 | ## Default the OpenMP flag to the empty string. 141 | ## If and only if OpenMP is found, expand to $(SHLIB_OPENMP_CXXFLAGS) 142 | openmp_flag="" 143 | ## Set the fallback, by default it is nope 144 | arma_have_openmp="#define ARMA_DONT_USE_OPENMP 1" 145 | 146 | if test x"${can_use_openmp}" == x"yes"; then 147 | AC_MSG_CHECKING([for OpenMP]) 148 | ## if R has -fopenmp we should be good 149 | allldflags=$(${R_HOME}/bin/R CMD config --ldflags) 150 | hasOpenMP=$(echo ${allldflags} | grep -- -fopenmp) 151 | if test x"${hasOpenMP}" == x""; then 152 | AC_MSG_RESULT([missing]) 153 | arma_have_openmp="#define ARMA_DONT_USE_OPENMP 1" 154 | else 155 | AC_MSG_RESULT([found and suitable]) 156 | arma_have_openmp="#define ARMA_USE_OPENMP 1" 157 | openmp_flag='$(SHLIB_OPENMP_CXXFLAGS)' 158 | fi 159 | fi 160 | 161 | 162 | ## now use all these 163 | AC_SUBST([ARMA_LAPACK],["${arma_lapack}"]) 164 | AC_SUBST([ARMA_HAVE_OPENMP], ["${arma_have_openmp}"]) 165 | AC_SUBST([OPENMP_FLAG], ["${openmp_flag}"]) 166 | AC_CONFIG_FILES([inst/include/RcppArmadilloConfigGenerated.h src/Makevars]) 167 | AC_OUTPUT 168 | -------------------------------------------------------------------------------- /docs/ggdmc_0.2.8.1.tar.gz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/yxlin/ggdmc/de30bc2b1e4aabbf8487cd429555058cff8fcf0e/docs/ggdmc_0.2.8.1.tar.gz -------------------------------------------------------------------------------- /ggdmc.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | 3 | RestoreWorkspace: Yes 4 | SaveWorkspace: No 5 | AlwaysSaveHistory: No 6 | 7 | EnableCodeIndexing: Yes 8 | UseSpacesForTab: Yes 9 | NumSpacesForTab: 2 10 | Encoding: UTF-8 11 | 12 | RnwWeave: Sweave 13 | LaTeX: pdfLaTeX 14 | 15 | StripTrailingWhitespace: Yes 16 | 17 | BuildType: Package 18 | PackageUseDevtools: Yes 19 | PackageInstallArgs: --no-multiarch --with-keep.source 20 | PackageCheckArgs: --as-cran 21 | PackageRoxygenize: rd,collate,namespace 22 | 23 | QuitChildProcessesOnExit: Yes 24 | -------------------------------------------------------------------------------- /inst/include/RcppArmadilloConfigGenerated.h.in: -------------------------------------------------------------------------------- 1 | // -*- mode: C++; c-indent-level: 4; c-basic-offset: 4; indent-tabs-mode: nil; -*- 2 | // 3 | // RcppArmadilloGenerated.h: Autoconf-updated file for LAPACK and OpenMP choices 4 | // 5 | // Copyright (C) 2013 - 2017 Dirk Eddelbuettel 6 | // 7 | // This file is part of RcppArmadillo. 8 | // 9 | // RcppArmadillo is free software: you can redistribute it and/or modify it 10 | // under the terms of the GNU General Public License as published by 11 | // the Free Software Foundation, either version 2 of the License, or 12 | // (at your option) any later version. 13 | // 14 | // RcppArmadillo is distributed in the hope that it will be useful, but 15 | // WITHOUT ANY WARRANTY; without even the implied warranty of 16 | // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 17 | // GNU General Public License for more details. 18 | // 19 | // You should have received a copy of the GNU General Public License 20 | // along with RcppArmadillo. If not, see . 21 | 22 | #ifndef RcppArmadillo__RcppArmadilloConfigGenerated__h 23 | #define RcppArmadillo__RcppArmadilloConfigGenerated__h 24 | 25 | #ifndef ARMA_CRIPPLED_LAPACK 26 | // value on next line may be changed between #undef and #define by the configure script 27 | @ARMA_LAPACK@ 28 | #endif 29 | 30 | #ifndef ARMA_USE_OPENMP 31 | // from configure test for OpenMP based on how R is configured, and whether g++ new enough 32 | @ARMA_HAVE_OPENMP@ 33 | #endif 34 | 35 | #endif 36 | -------------------------------------------------------------------------------- /inst/include/ggdmc.hpp: -------------------------------------------------------------------------------- 1 | #include // DDM parameters & PDF 2 | #include // DDM CDF and random deviates 3 | #include // Experimental design information 4 | #include // truncated normal PDF, CDF, & random deviates 5 | #include // LBA PDF, CDF and random deviates 6 | #include 7 | #include // Prior 8 | #include // Likelihood generics 9 | #include // Theta & Phi 10 | #include // DE-MCMC samplers 11 | #include // Von Mise distributions 12 | 13 | -------------------------------------------------------------------------------- /inst/include/ggdmc/Design.hpp: -------------------------------------------------------------------------------- 1 | #ifndef DESIGN_HPP 2 | #define DESIGN_HPP 3 | 4 | #include 5 | 6 | using namespace Rcpp; 7 | 8 | class Design 9 | // parameters = parnames; nParameter 10 | // pvector of samples consists of part of the names of "parameters"; npar 11 | // allpar parameters x conditions; np 12 | { 13 | public: 14 | unsigned int m_nc, m_np, m_nr, m_nRT, m_nParameter, m_npar, m_nallpar; 15 | double *m_allpar; 16 | std::string *m_pnames, *m_parameters, *m_dim0, *m_dim1, *m_dim2; 17 | bool *m_is_empty_cell, *m_is_matched_cell; 18 | 19 | arma::vec m_RT, m_A; 20 | arma::umat m_is_this_cell; 21 | arma::ucube m_model; 22 | 23 | Design(List & dmi) 24 | // Run & likelihood constructor 25 | { 26 | using namespace arma; 27 | using namespace std; 28 | 29 | // NOTE: all things from R must be casted to a valid R-recognizable type 30 | // first, so the messy syntax. 31 | // List dmi = samples["data"]; // data model instance 32 | 33 | NumericVector modelAttr = dmi.attr("model"); 34 | vector ise = dmi.attr("cell.empty"); // nc 35 | List cidx = dmi.attr("cell.index"); // nc elements 36 | ucube tmp_model = dmi.attr("model"); 37 | arma::vec RT = dmi["RT"]; 38 | List modelDim = modelAttr.attr("dimnames"); 39 | NumericVector pvector = modelAttr.attr("p.vector"); // Carry NA values 40 | vector parnames = modelAttr.attr("par.names"); 41 | vector tmp_allpar= modelAttr.attr("all.par"); // with conditoin complications 42 | vector mc = modelAttr.attr("match.cell"); 43 | vector pnames = pvector.attr("names"); 44 | // nc = dim0.size() ; // number of condition, eg s1.r1 etc. 45 | // np = dim1.size() ; // number of parameter x condition, eg v.f1, v.f2 46 | // nr = dim2.size() ; // number of accumualtor/response, eg r1, r2 47 | vector dim0 = modelDim[0]; 48 | vector dim1 = modelDim[1]; 49 | vector dim2 = modelDim[2]; 50 | 51 | // 1. Get RTs 52 | m_RT = RT; 53 | std::string type = modelAttr.attr("type"); 54 | 55 | // Two dependednt variables 56 | if (type == "cddm") 57 | { 58 | arma::vec A = dmi["A"]; 59 | m_A = A; 60 | } 61 | 62 | // 2. Get the sizes of all design-related variables 63 | m_nc = dim0.size(); 64 | m_np = dim1.size(); 65 | m_nr = dim2.size(); 66 | m_nRT = RT.size(); 67 | m_nParameter = parnames.size(); // pure model parameters (no condition) 68 | m_npar = pvector.size(); // modeled model-condition parameters 69 | m_nallpar = tmp_allpar.size(); // modeled and fixed model-condition parameters 70 | 71 | // 3. Copy from stack to heap 72 | m_allpar = new double[m_nallpar]; 73 | m_pnames = new string[m_npar]; 74 | m_parameters = new string[m_nParameter]; 75 | m_dim0 = new string[m_nc]; 76 | m_dim1 = new string[m_np]; 77 | m_dim2 = new string[m_nr]; 78 | m_is_matched_cell = new bool[m_nc]; 79 | m_is_empty_cell = new bool[m_nc]; 80 | 81 | std::copy(tmp_allpar.begin(), tmp_allpar.end(), m_allpar); 82 | std::copy(pnames.begin(), pnames.end(), m_pnames); 83 | std::copy(parnames.begin(), parnames.end(), m_parameters); 84 | 85 | std::copy(dim0.begin(), dim0.end(), m_dim0); 86 | std::copy(dim1.begin(), dim1.end(), m_dim1); 87 | std::copy(dim2.begin(), dim2.end(), m_dim2); 88 | 89 | std::copy(ise.begin(), ise.end(), m_is_empty_cell); 90 | std::copy(mc.begin(), mc.end(), m_is_matched_cell); 91 | 92 | // 4. We rely on Armadillo methods to handle cellidx and model cube 93 | umat tmp_cidx(m_nRT, m_nc); 94 | for (size_t i = 0; i ise = dmi.slot("cell.empty"); // nc 118 | List cidx = dmi.slot("cell.index"); // nc elements 119 | 120 | arma::vec RT = data["RT"]; 121 | 122 | ucube tmp_model = model.slot("model"); 123 | List modelDim = model.slot("dimnames"); 124 | NumericVector pvector = model.slot("p.vector"); // Carry NA values 125 | vector parnames = model.slot("par.names"); 126 | vector tmp_allpar= model.slot("all.par"); // with conditoin complications 127 | vector mc = model.slot("match.cell"); 128 | 129 | vector pnames = model.slot("pnames"); 130 | // nc = dim0.size() ; // number of condition, eg s1.r1 etc. 131 | // np = dim1.size() ; // number of parameter x condition, eg v.f1, v.f2 132 | // nr = dim2.size() ; // number of accumualtor/response, eg r1, r2 133 | vector dim0 = modelDim[0]; 134 | vector dim1 = modelDim[1]; 135 | vector dim2 = modelDim[2]; 136 | 137 | // 1. Get RTs 138 | m_RT = RT; 139 | std::string type = model.slot("type"); 140 | 141 | // Two dependednt variables 142 | if (type == "cddm") 143 | { 144 | arma::vec A = data["A"]; 145 | m_A = A; 146 | } 147 | 148 | // 2. Get the sizes of all design-related variables 149 | m_nc = dim0.size(); 150 | m_np = dim1.size(); 151 | m_nr = dim2.size(); 152 | m_nRT = RT.size(); 153 | m_nParameter = parnames.size(); // pure model parameters (no condition) 154 | m_npar = pvector.size(); // modeled model-condition parameters 155 | m_nallpar = tmp_allpar.size(); // modeled and fixed model-condition parameters 156 | 157 | // 3. Copy from stack to heap 158 | m_allpar = new double[m_nallpar]; 159 | m_pnames = new string[m_npar]; 160 | m_parameters = new string[m_nParameter]; 161 | m_dim0 = new string[m_nc]; 162 | m_dim1 = new string[m_np]; 163 | m_dim2 = new string[m_nr]; 164 | m_is_matched_cell = new bool[m_nc]; 165 | m_is_empty_cell = new bool[m_nc]; 166 | 167 | std::copy(tmp_allpar.begin(), tmp_allpar.end(), m_allpar); 168 | std::copy(pnames.begin(), pnames.end(), m_pnames); 169 | std::copy(parnames.begin(), parnames.end(), m_parameters); 170 | 171 | std::copy(dim0.begin(), dim0.end(), m_dim0); 172 | std::copy(dim1.begin(), dim1.end(), m_dim1); 173 | std::copy(dim2.begin(), dim2.end(), m_dim2); 174 | 175 | std::copy(ise.begin(), ise.end(), m_is_empty_cell); 176 | std::copy(mc.begin(), mc.end(), m_is_matched_cell); 177 | 178 | // 4. We rely on Armadillo methods to handle cellidx and model cube 179 | umat tmp_cidx(m_nRT, m_nc); 180 | for (size_t i = 0; i & pnames, 192 | std::vector & parnames, 193 | std::vector & dim0, 194 | std::vector & dim1, 195 | std::vector & dim2, 196 | std::vector & allpar, 197 | arma::ucube & model) : m_model(model) 198 | // p_df constructor 199 | { 200 | m_nc = dim0.size(); // number of condition, eg s1.r1 etc. 201 | m_np = dim1.size(); // number of parameter x condition, eg v.f1, v.f2 202 | m_nr = dim2.size(); // number of accumualtor/response, eg r1, r2 203 | m_nParameter = parnames.size(); 204 | m_npar = pnames.size(); 205 | 206 | m_allpar = new double[allpar.size()]; 207 | m_pnames = new std::string[m_npar]; 208 | m_parameters = new std::string[m_nParameter]; 209 | m_dim0 = new std::string[m_nc]; 210 | m_dim1 = new std::string[m_np]; 211 | m_dim2 = new std::string[m_nr]; 212 | 213 | std::copy(pnames.begin(), pnames.end(), m_pnames); 214 | std::copy(parnames.begin(), parnames.end(), m_parameters); 215 | std::copy(dim0.begin(), dim0.end(), m_dim0); 216 | std::copy(dim1.begin(), dim1.end(), m_dim1); 217 | std::copy(dim2.begin(), dim2.end(), m_dim2); 218 | std::copy(allpar.begin(), allpar.end(), m_allpar); 219 | 220 | } 221 | 222 | ~Design() 223 | { 224 | // Rcout << "Design destructor\n"; 225 | } 226 | }; 227 | 228 | #endif 229 | -------------------------------------------------------------------------------- /inst/include/ggdmc/FCalculator.hpp: -------------------------------------------------------------------------------- 1 | /* (1) pde.c - numerically solve the Fokker-Planck equation 2 | * (2) phi.c - the CDF and inverse CDF of the standard normal distribution 3 | * (3) cdf.c, FCalculator.h, FControler.h & CDF_***.h - compute the CDF for 4 | * the diffusion model 5 | * (4) construct-samples.c, Sampling.hpp - Contains main call for random 6 | * sampling 7 | * 8 | * This program is free software; you can redistribute it and/or 9 | * modify it under the terms of the GNU General Public License as 10 | * published by the Free Software Foundation; either version 2 of the 11 | * License, or (at your option) any later version. 12 | * 13 | * This program is distributed in the hope that it will be useful, but 14 | * WITHOUT ANY WARRANTY; without even the implied warranty of 15 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 16 | * General Public License for more details. 17 | * 18 | * You should have received a copy of the GNU General Public License 19 | * along with this program; if not, write to the Free Software 20 | * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 21 | * 02110-1301 USA. 22 | */ 23 | 24 | // See also Feller (1971, p358 & p359) 25 | 26 | #ifndef FCALCULATOR_H 27 | #define FCALCULATOR_H 28 | 29 | #include // for std, cmath and many other supports via Rcpp 30 | 31 | #define xrenew(T,OLD,N) ( (T *)xrealloc(OLD, (N)*sizeof(T)) ) 32 | 33 | class F_calculator 34 | // A parent class for F_plain, F_sz, F_sv & F_st0. All four derived classes 35 | // should all return F_calculator type. 36 | { 37 | public: 38 | int N, plus; 39 | void *data; // Cast to a derived class in their member functions 40 | 41 | void (*start) (F_calculator *, int plus); 42 | void (*free) (F_calculator *); 43 | const double *(*get_F) (F_calculator *, double t); 44 | double (*get_z) (const F_calculator *, int i); 45 | }; 46 | 47 | class F_plain_data // plain: no variability 48 | { 49 | public: 50 | double a, v, t0, d; /* parameters (except z) */ 51 | double dz; /* z step-size */ 52 | double t_offset; /* time adjustment, resulting from t0 and d */ 53 | double t; /* adjusted time, corresponding to the vector F */ 54 | double *F; // state at time t + t_offset; ie CDFs 55 | 56 | double TUNE_PDE_DT_MIN; 57 | double TUNE_PDE_DT_MAX; 58 | double TUNE_PDE_DT_SCALE; 59 | 60 | double F_limit(double z); 61 | }; 62 | 63 | class F_sz_data // sz 64 | { 65 | public: 66 | F_calculator *base_fc; // gives the values we average over 67 | double *avg; // the computed averages 68 | int k; // the average involves 2*k+1 cells 69 | double q; // unused part of the outermost cells 70 | double f; // scale factor for the integration 71 | }; 72 | 73 | class F_sv_data // sv 74 | { 75 | public: 76 | int nv; // number of points in integration 77 | std::vector base_fc; // F_calculators for different v 78 | double *avg; 79 | }; 80 | 81 | class F_st0_data // st0 82 | { 83 | public: 84 | F_calculator *base_fc; 85 | double st0; // variability of t0 86 | int M; // number of stored grid lines 87 | double start; // t-value of first stored grid line 88 | double dt; // t-spacing of stored grid lines 89 | double *values; // array: stored grid lines (length M*(N+1)) 90 | char *valid; // which lines in 'values' are valid 91 | int base; // first grid line starts at pos. base*(N+1) 92 | double *avg; // the computed average (size N+1) 93 | }; 94 | 95 | 96 | // A specific two-step constructor, two member functions and a destructor 97 | // of the F_calculator class 98 | F_calculator * F_new (Parameters *params); 99 | void F_start (F_calculator *fc, int boundary); 100 | const double * F_get_F (F_calculator *fc, double t); 101 | double F_get_z (const F_calculator *fc, int i); 102 | void F_delete (F_calculator *fc); 103 | double F_get_val (F_calculator *fc, double t, double z); 104 | 105 | /*--------------------------------------------------------------------------- 106 | Original found in construct-samples.c 107 | ---------------------------------------------------------------------------*/ 108 | Rcpp::List sampling(int s_size, Parameters * params, bool random_flag); 109 | 110 | #endif 111 | -------------------------------------------------------------------------------- /inst/include/ggdmc/LBA.hpp: -------------------------------------------------------------------------------- 1 | #ifndef LBA_HPP 2 | #define LBA_HPP 3 | 4 | #include 5 | 6 | class lba { 7 | public: 8 | double m_A, m_b, m_mean_v, m_sd_v, m_t0, m_st0; // LBA distribution. 9 | bool is_posv; 10 | double *m_dt, *m_A_vec, *m_b_vec, *m_meanv_vec, *m_sdv_vec, *m_t0_vec, *m_st0_vec; 11 | unsigned int m_nmean_v, m_nrt; 12 | 13 | lba (double A, double b, double mean_v, double sd_v, double t0, double st0, 14 | bool posdrift, arma::vec & rt) : 15 | m_A(A), m_b(b), m_mean_v(mean_v), m_sd_v(sd_v), m_t0(t0), m_st0(st0), 16 | is_posv(posdrift) 17 | { 18 | m_nrt = rt.size(); 19 | m_dt = new double[m_nrt]; 20 | for (size_t i = 0; i < m_nrt; i++) { m_dt[i] = rt[i] - m_t0; } 21 | 22 | denom = !is_posv ? 1.0 : 23 | R::fmax2(R::pnorm(m_mean_v/m_sd_v, 0, 1, 1, 0), 1e-10); 24 | }; 25 | // pdf, cdf 26 | 27 | lba (double A, double b, double * mean_v, double * sd_v, double t0, 28 | double st0, unsigned int & nmean_v, bool posdrift) : 29 | m_A(A), m_b(b), m_t0(t0), m_st0(st0), is_posv(posdrift), 30 | m_meanv_vec(mean_v), m_sdv_vec(sd_v), m_nmean_v(nmean_v) 31 | { 32 | if (m_st0 < 0) Rcpp::stop("st0 must be greater than 0."); 33 | } 34 | // rlba_norm. NOTE double * mean_v and double * sd_v 35 | 36 | lba (double * A, double * b, double * mean_v, double * sd_v, double * t0, 37 | double * st0, unsigned int & nmean_v, bool posdrift) : 38 | m_A_vec(A), m_b_vec(b), m_meanv_vec(mean_v), m_sdv_vec(sd_v), m_t0_vec(t0), 39 | m_st0_vec(st0), m_nmean_v(nmean_v), is_posv(posdrift) 40 | { 41 | } 42 | // rlba_norm. vectorized 43 | 44 | 45 | ~lba() {}; 46 | 47 | arma::vec d() 48 | { 49 | arma::vec out(m_nrt); 50 | 51 | for (size_t i = 0; i < m_nrt; i++) 52 | { 53 | if (m_dt[i] < 0) 54 | { 55 | out[i] = 0.0; 56 | } 57 | else if (m_A < 1e-10) 58 | { 59 | out[i] = R::fmax2(0.0, (m_b / (m_dt[i]*m_dt[i])) * R::dnorm( 60 | m_b / m_dt[i], m_mean_v, m_sd_v, 0) / denom ); 61 | } 62 | else 63 | { 64 | ts = m_dt[i] * m_sd_v; // zs 65 | tv = m_dt[i] * m_mean_v; // zu 66 | term1 = m_mean_v *(R::pnorm((m_b-tv)/ts, 0, 1, 1, 0) - 67 | R::pnorm((m_b-m_A-tv)/ts,0,1,1, 0)); 68 | term2 = m_sd_v *(R::dnorm((m_b-m_A-tv)/ts, 0, 1, 0) - 69 | R::dnorm((m_b-tv)/ts, 0,1,0)); 70 | out[i] = R::fmax2(0.0, (term1 + term2) / (m_A*denom)); 71 | } 72 | 73 | if (ISNAN(out[i])) out[i] = 0.0; 74 | } 75 | 76 | delete [] m_dt; 77 | return out; 78 | } 79 | 80 | arma::vec p() 81 | { 82 | arma::vec out(m_nrt); 83 | 84 | for (size_t i = 0; i < m_nrt; i++) 85 | { 86 | if (m_A < 1e-10) 87 | { 88 | out[i] = R::fmin2(1.0, 89 | R::fmax2(0.0, 90 | R::pnorm(m_b / m_dt[i], m_mean_v, m_sd_v, false, false) / denom)); 91 | } 92 | else 93 | { 94 | tv = m_dt[i] * m_mean_v; 95 | ts = m_dt[i] * m_sd_v; 96 | 97 | term1 = (m_b-m_A-tv) * R::pnorm((m_b - m_A - tv) / ts, 0, 1, true, false) - 98 | (m_b -tv) * R::pnorm((m_b - tv) / ts, 0, 1, true, false); 99 | term2 = ts * (R::dnorm((m_b - m_A - tv) / ts, 0, 1, false) - 100 | R::dnorm((m_b - tv) / ts, 0, 1, false)); 101 | 102 | out[i] = R::fmin2(1.0, 103 | R::fmax2(0.0, (1.0 + (term1 + term2)/m_A) / denom)); 104 | } 105 | 106 | if (ISNAN(out[i])) out[i] = 0.0; 107 | 108 | } 109 | delete [] m_dt; 110 | return out; 111 | } 112 | 113 | 114 | void r (unsigned int & n, arma::mat & output) 115 | { 116 | // output n x 2 117 | arma::vec tmp(m_nmean_v); 118 | 119 | for (size_t i=0; ir(); 192 | delete obj; 193 | } 194 | if ( output.has_inf() ) Rcpp::stop("Found infinite in rt_vec class"); 195 | } 196 | 197 | }; 198 | 199 | arma::vec n1PDFfixedt0(arma::vec rt, arma::vec A, arma::vec b, arma::vec mean_v, 200 | arma::vec sd_v, arma::vec t0, arma::vec st0, 201 | bool posdrift); 202 | 203 | 204 | #endif 205 | -------------------------------------------------------------------------------- /inst/include/ggdmc/Likelihood.hpp: -------------------------------------------------------------------------------- 1 | #ifndef LIKELIHOOD_HPP 2 | #define LIKELIHOOD_HPP 3 | 4 | #include 5 | 6 | using namespace Rcpp; 7 | 8 | class Likelihood 9 | { 10 | private: 11 | enum ModelType { DEFAULT, DDM, LBA, CDDM }; 12 | 13 | ModelType resolve_option(std::string type) 14 | { 15 | if(type == "rd") return DDM; // 1 16 | if(type == "norm") return LBA; // 2 17 | if(type == "cddm") return CDDM; // 3 18 | return DEFAULT; // 0 19 | } 20 | 21 | public: 22 | Design * m_d; 23 | std::string m_mtype; 24 | 25 | // All additional arguments 26 | arma::uvec m_is_r1; // DDM 27 | double m_precision; // DDM 28 | 29 | arma::umat m_n1idx; // LBA 30 | bool m_posdrift, m_n1order; 31 | 32 | Likelihood(List & dmi, Design * d, double precision) : 33 | m_d(d), m_precision(precision) 34 | // Run and likelihood constructor 35 | { 36 | NumericVector modelAttr = dmi.attr("model"); 37 | 38 | arma::umat tmp_n1idx = modelAttr.attr("n1.order"); 39 | std::string type = modelAttr.attr("type"); 40 | 41 | m_n1idx = tmp_n1idx; 42 | 43 | // TODO: make it compatible to old version 44 | arma::uvec tmp_isr1 = modelAttr.attr("is.r1"); 45 | m_mtype = type; 46 | 47 | if (m_mtype == "rd") m_is_r1 = tmp_isr1; 48 | 49 | // m_precision = 3.0; 50 | m_posdrift = modelAttr.attr("posdrift"); 51 | m_n1order = true; 52 | } 53 | 54 | Likelihood(S4 & dmi, Design * d, double precision) : 55 | m_d(d), m_precision(precision) 56 | // Run and likelihood constructor 57 | { 58 | S4 model = dmi.slot("model"); 59 | arma::umat tmp_n1idx = model.slot("n1.order"); 60 | std::string type = model.slot("type"); 61 | 62 | m_n1idx = tmp_n1idx; 63 | arma::uvec tmp_isr1 = model.attr("is.r1"); 64 | 65 | m_mtype = type; 66 | 67 | if (m_mtype == "rd") m_is_r1 = tmp_isr1; 68 | 69 | // m_precision = 3.0; 70 | m_posdrift = model.slot("posdrift"); 71 | m_n1order = true; 72 | } 73 | 74 | Likelihood(std::string model_type, 75 | arma::uvec isr1, 76 | arma::umat n1idx, 77 | bool n1order, 78 | Design * d) : 79 | m_d(d), m_mtype(model_type), m_is_r1(isr1), m_n1idx(n1idx) 80 | // p_df constructor, random functions set n1order as false 81 | { 82 | m_precision = 3.0; 83 | m_posdrift = true; 84 | m_n1order = n1order; 85 | } 86 | 87 | ~Likelihood() 88 | { 89 | delete m_d; 90 | // Rcout << "Likelihood destructor\n"; 91 | } 92 | 93 | /* ---------------Model-specific methods--------------- */ 94 | 95 | void transform (arma::mat & output, std::string & cell) 96 | // DDM transform 97 | { 98 | // parmat 8 x 2 99 | 100 | for (size_t i = 0; i < m_d->m_nc; i++) 101 | { 102 | // dim0: // "s1.r1" "s2.r1" "s1.r2" "s2.r2" 103 | // ir1 is an index vector, indicating: 104 | // 105 | // If this is the selected condition (ie cell), plus it is a 106 | // correct response, plus it is the first response, then flip zr. 107 | // TODO: NEED FURTHER INVESTIGATION. This may be a AH's bug. 108 | if (m_d->m_dim0[i] == cell && m_is_r1[i]) 109 | { 110 | output.row(2) = 1 - output.row(2); 111 | } 112 | } 113 | 114 | } 115 | 116 | arma::mat transform (arma::mat & parmat, std::string & cell, 117 | bool n1order) 118 | // LBA transform 119 | { 120 | // A b t0 mean_v sd_v st0 121 | parmat.row(1) += parmat.row(0); // calculate b = A + B 122 | arma::mat out = parmat; 123 | 124 | // n1idx: nc x nr 125 | if (n1order) 126 | { 127 | for (size_t i=0; im_nc; i++) 128 | { 129 | if (m_d->m_dim0[i] == cell) 130 | { 131 | for (size_t j=0; j < m_d->m_nr; j++) 132 | { 133 | out.col(j) = parmat.col( m_n1idx(i, j) - 1 ); 134 | } 135 | } 136 | } 137 | } 138 | 139 | return out; 140 | } 141 | 142 | 143 | arma::vec ddm (arma::vec & pvector) 144 | { 145 | double * para = new double[m_d->m_nParameter]; 146 | 147 | arma::mat pmat(m_d->m_nParameter, m_d->m_nr); // 8 x 2 148 | arma::vec out(m_d->m_nRT); 149 | 150 | // Parameters * params; 151 | arma::uvec RTIdx, tmp; 152 | arma::vec selectedRT; 153 | 154 | // [a v zr d szr sv t0 st0] 155 | for (size_t i=0; im_nc; i++) 156 | { 157 | if (!m_d->m_is_empty_cell[i]) 158 | { 159 | parameter_matrix(pvector, m_d->m_dim0[i], pmat); 160 | transform(pmat, m_d->m_dim0[i]); 161 | 162 | for (size_t j = 0; j < m_d->m_nParameter; j++) para[j] = pmat(j, 0); 163 | 164 | Parameters * params = new Parameters(para, m_precision); 165 | 166 | tmp = m_d->m_is_this_cell.col(i); 167 | RTIdx = arma::find(m_d->m_is_this_cell.col(i)); 168 | selectedRT = m_d->m_RT(RTIdx); 169 | 170 | if (!params->ValidateParams(false)) // do not print invalid parameters 171 | { 172 | out(RTIdx).fill(1e-10); 173 | } 174 | else 175 | { 176 | if (m_d->m_is_matched_cell[i]) // choose g_plus 177 | { 178 | for (size_t k = 0; k < selectedRT.n_elem; k++) 179 | { 180 | out(RTIdx(k)) = R::fmax2(std::abs(g_plus(selectedRT(k), params)), 1e-10); 181 | } 182 | } 183 | else 184 | { 185 | for (size_t k = 0; k < selectedRT.n_elem; k++) 186 | { 187 | out(RTIdx(k)) = R::fmax2(std::abs(g_minus(selectedRT(k), params)), 1e-10); 188 | } 189 | } 190 | } 191 | 192 | delete params; 193 | 194 | 195 | } 196 | } 197 | 198 | delete [] para; 199 | return out; 200 | } 201 | 202 | arma::vec lba_ (arma::vec & pvector) 203 | { 204 | arma::mat pmat0(m_d->m_nParameter, m_d->m_nr); 205 | arma::vec out(m_d->m_nRT); 206 | arma::uvec RTIdx; 207 | 208 | // pmat: A b t0 mean_v sd_v st0 209 | for (size_t i=0; im_nc; i++) 210 | { 211 | if (!m_d->m_is_empty_cell[i]) 212 | { 213 | parameter_matrix(pvector, m_d->m_dim0[i], pmat0); 214 | 215 | arma::mat pmat = transform(pmat0, m_d->m_dim0[i], m_n1order); 216 | pmat = arma::trans(pmat); 217 | 218 | // PM model 219 | if (pmat.n_cols == 7) { pmat = pmat.rows(0, pmat(1,6)-1); } 220 | 221 | RTIdx = arma::find(m_d->m_is_this_cell.col(i) == 1); 222 | out(RTIdx) = n1PDFfixedt0(m_d->m_RT(RTIdx), pmat.col(0), pmat.col(1), 223 | pmat.col(3), pmat.col(4), pmat.col(2), pmat.col(5), m_posdrift); 224 | } 225 | 226 | } 227 | 228 | // for (size_t i = 0; i < m_d->m_nRT; i++) out[i] = R::fmax2(out[i], 1e-10); 229 | return out; 230 | } 231 | 232 | arma::vec cddm (arma::vec & pvector) 233 | { 234 | arma::mat pmat0(m_d->m_nParameter, m_d->m_nr); 235 | arma::vec out(m_d->m_nRT); 236 | arma::uvec idx; 237 | 238 | unsigned int sz = 300, nw=50, kmax = 50; 239 | 240 | for (size_t i=0; im_nc; i++) // loop through each condition 241 | { 242 | if (!m_d->m_is_empty_cell[i]) 243 | { 244 | parameter_matrix(pvector, m_d->m_dim0[i], pmat0); 245 | // Rprintf("Condition %d: ", i); 246 | // pmat0.print("pmat0"); 247 | arma::vec P = pmat0.col(0); // Use the 1st accumulation parameter vector 248 | idx = arma::find(m_d->m_is_this_cell.col(i) == 1); 249 | 250 | // sz = P(8)/P(9); // tmax/h 251 | out(idx) = dcircle(m_d->m_RT(idx), m_d->m_A(idx), P.subvec(0, 7), P(8), 252 | kmax, sz, nw); 253 | } 254 | } 255 | return out; 256 | } 257 | 258 | /* ---------------Generic methods--------------- */ 259 | void parameter_matrix(arma::vec & pvector, std::string & cell, 260 | arma::mat & output) 261 | { 262 | arma::vec tmp(m_d->m_nParameter); 263 | 264 | // Iterate through accumulators, eg r1, r2, (if have any), r3, etc. 265 | // parnames is the parameter the user wishes to fit, which may/may not 266 | // differ from the parameter likelihood function expects 267 | // eg A, B, mean_v, sd_v, t0, st0 vs A, b, mean_v, sd_v, t0, st0 268 | // likelihood function expects to see b, but the user is asked to enter B. 269 | 270 | for (size_t i=0; im_nr; i ++) // r1, r2, r3, etc. 271 | { 272 | for (size_t j=0; jm_nc; j++) // eg s1.r1, s2.r1, s1.r2, s2.r2 etc. 273 | { 274 | if (m_d->m_dim0[j] == cell) 275 | { 276 | size_t idx = 0; 277 | 278 | for (size_t k=0; km_np; k++) // eg allpars a, v.f1, v.f2, z, d, sz) ... 279 | { 280 | 281 | if (m_d->m_model(j, k, i)) 282 | { 283 | // The values in allpar vector is either constant or NA. 284 | // When a value is NA, it indicates that it is not a constant. 285 | // In this case, its value is stored in pvector 286 | // allpar names == dim2 names 287 | 288 | tmp[idx] = m_d->m_allpar[k]; // constant values or NA 289 | 290 | for(size_t l = 0; l < m_d->m_npar; l++) 291 | { 292 | // replace NA with values in p.vector. 293 | if (m_d->m_pnames[l] == m_d->m_dim1[k] && ISNAN(tmp[idx])) 294 | { 295 | tmp[idx] = pvector[l]; 296 | } 297 | } 298 | 299 | idx++; 300 | 301 | } 302 | } 303 | } 304 | } 305 | 306 | output.col(i) = tmp; 307 | } 308 | } 309 | 310 | double sumloglike(arma::vec pvector) // mustn't pass memory location 311 | { 312 | arma::vec den; 313 | 314 | switch(resolve_option(m_mtype)) 315 | { 316 | case DDM: 317 | den = ddm(pvector); 318 | break; 319 | case LBA: 320 | den = lba_(pvector); 321 | break; 322 | case CDDM: 323 | // Rcout << "CDDM removed \n"; den.fill(1e-10); 324 | den = cddm(pvector); 325 | break; 326 | case DEFAULT: 327 | Rcout << "Undefined model type\n"; den.fill(1e-10); 328 | break; 329 | default: 330 | Rcout << "Unexpected situation\n"; den.fill(1e-10); 331 | break; 332 | } 333 | 334 | double out = arma::accu(arma::log(den)); 335 | if (ISNAN(out)) out = R_NegInf; 336 | 337 | return out; 338 | } 339 | 340 | arma::vec likelihood(arma::vec & pvector) 341 | { 342 | arma::vec den; 343 | switch(resolve_option(m_mtype)) 344 | { 345 | case DDM: 346 | den = ddm(pvector); 347 | break; 348 | case LBA: 349 | den = lba_(pvector); 350 | break; 351 | case CDDM: 352 | // Rcout << "CDDM removed \n"; den.fill(1e-10); 353 | den = cddm(pvector); 354 | break; 355 | case DEFAULT: 356 | Rcout << "Undefined model type\n"; den.fill(1e-10); 357 | break; 358 | default: 359 | Rcout << "Unexpected situation\n"; den.fill(1e-10); 360 | break; 361 | } 362 | 363 | return den; 364 | } 365 | 366 | arma::mat get_pmat(arma::vec & pvector, std::string & cell) 367 | { 368 | arma::mat pmat(m_d->m_nParameter, m_d->m_nr); 369 | 370 | switch(resolve_option(m_mtype)) 371 | { 372 | case DDM: // 1 373 | parameter_matrix(pvector, cell, pmat); 374 | transform(pmat, cell); 375 | break; 376 | case LBA: // 2 377 | parameter_matrix(pvector, cell, pmat); 378 | pmat = transform(pmat, cell, m_n1order); 379 | break; 380 | case CDDM: // 3 381 | parameter_matrix(pvector, cell, pmat); 382 | break; 383 | case DEFAULT: // 0 384 | Rcout << "Undefined model.\n"; pmat.fill(NA_REAL); 385 | break; 386 | default: 387 | Rcout << "Unexpected situation.\n"; pmat.fill(NA_REAL); 388 | break; 389 | } 390 | 391 | return pmat.t(); 392 | } 393 | 394 | 395 | }; 396 | 397 | #endif 398 | -------------------------------------------------------------------------------- /inst/include/ggdmc/Parameters.hpp: -------------------------------------------------------------------------------- 1 | /* Parameters.h - A class to contain the model parameters and precision tuning 2 | * 3 | * - The adapation is largely from Matthew Gretton's C++ codes in the rtdists 4 | * package 5 | * - Originally from parameters.c and precision.c (C) 2006-2012 Jochen Voss, 6 | * & Andreas Voss. 7 | * 8 | * 9 | * This program is free software; you can redistribute it and/or 10 | * modify it under the terms of the GNU General Public License as 11 | * published by the Free Software Foundation; either version 2 of the 12 | * License, or (at your option) any later version. 13 | * 14 | * This program is distributed in the hope that it will be useful, but 15 | * WITHOUT ANY WARRANTY; without even the implied warranty of 16 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 17 | * General Public License for more details. 18 | * 19 | * You should have received a copy of the GNU General Public License 20 | * along with this program; if not, write to the Free Software 21 | * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 22 | * 02110-1301 USA. 23 | */ 24 | 25 | #ifndef PARAMETERS_H 26 | #define PARAMETERS_H 27 | 28 | #include // for std, cmath and many other supports via Rcpp 29 | 30 | // Note: Parameters class now includes precision constants 31 | // Indices for packed parameters array 32 | 33 | #define PARAM_a 0 34 | #define PARAM_v 1 35 | #define PARAM_zr 2 36 | #define PARAM_d 3 37 | #define PARAM_szr 4 38 | #define PARAM_sv 5 39 | #define PARAM_t0 6 40 | #define PARAM_st0 7 41 | #define PARAM_s 8 42 | 43 | #define BOUNDARY_LOWER 0 44 | #define BOUNDARY_UPPER 1 45 | 46 | const double EPSILON = 1e-6; // used in ddiffusion 47 | const unsigned int MAX_INPUT_VALUES = 1e6; // max simulation number 48 | 49 | class Parameters 50 | { 51 | public: 52 | double a; // Boundary separation 53 | double v; // Mean of the drift 54 | double t0; // Non-decision time 55 | double d; // Difference between boundaries of non-decision time 56 | double szr; // width of zr distribution 57 | double sv; // standard deviation of v distribution 58 | double st0; // width of t0 distribution 59 | double zr; // Mean of diffusion starting point relative to boundaries 60 | double s; // standard deviation; sqrt(diffusion constant) 61 | 62 | // Precision constants set by SetPrecision() 63 | double TUNE_DZ; 64 | double TUNE_DV; 65 | double TUNE_DT0; 66 | 67 | double TUNE_PDE_DT_MIN; // If std=c++11 we can use C++ defaults to set as = 1e-6; 68 | double TUNE_PDE_DT_MAX; // ... we can default to = 1e-6; 69 | double TUNE_PDE_DT_SCALE; // ... we can default to = 0.0; 70 | 71 | double TUNE_INT_T0; 72 | double TUNE_INT_Z; 73 | 74 | double TUNE_SV_EPSILON; // CONVERSION NOTE: See below in SetPrecision() 75 | double TUNE_SZ_EPSILON; // CONVERSION NOTE: See below in SetPrecision() 76 | double TUNE_ST0_EPSILON; // CONVERSION NOTE: See below in SetPrecision() 77 | 78 | // 3 constructors 79 | Parameters(std::vector params, double precision, int boundary); 80 | Parameters(std::vector params, double precision); 81 | Parameters(double * params, double precision); 82 | 83 | bool ValidateParams (bool print); 84 | void Show(std::string str) const; 85 | 86 | private: 87 | void SetPrecision (double p) 88 | { 89 | // Try to achieve an accuracy of approximately 10^{-p} for the CDF. 90 | TUNE_PDE_DT_MIN = std::pow(10, -0.400825*p-1.422813); 91 | TUNE_PDE_DT_MAX = std::pow(10, -0.627224*p+0.492689); 92 | TUNE_PDE_DT_SCALE = std::pow(10, -1.012677*p+2.261668); 93 | 94 | TUNE_DZ = std::pow(10, -0.5*p-0.033403); // CDF 95 | TUNE_DV = std::pow(10, -1.0*p+1.4); 96 | TUNE_DT0 = std::pow(10, -0.5*p-0.323859); 97 | 98 | TUNE_INT_T0 = 0.089045 * std::exp(-1.037580*p); // PDF 99 | TUNE_INT_Z = 0.508061 * std::exp(-1.022373*p); 100 | 101 | // CONVERSION NOTE: 102 | // These have been added to optimise code paths by treating very small variances as 0 103 | // e.g. with precision = 3, sv or sz values < 10^-5 are considered 0 104 | TUNE_SV_EPSILON = std::pow (10, -(p+2.0)); // Used by pdiffusion 105 | TUNE_SZ_EPSILON = std::pow (10, -(p+2.0)); // Used by ddiffusion and pdiffusion 106 | TUNE_ST0_EPSILON = std::pow (10, -(p+2.0)); // Used by ddiffusion 107 | } 108 | 109 | }; 110 | 111 | ///////////////////// Density.h ////////////////////// 112 | double g_minus(double t, Parameters *params); 113 | double g_plus(double t, Parameters *params); 114 | 115 | #endif // PARAMETERS_H 116 | -------------------------------------------------------------------------------- /inst/include/ggdmc/Prior.hpp: -------------------------------------------------------------------------------- 1 | #ifndef PRIOR_HPP 2 | #define PRIOR_HPP 3 | 4 | #include 5 | 6 | using namespace Rcpp; 7 | 8 | class Prior 9 | { 10 | private: 11 | 12 | enum DistributionType { DEFAULT, TNORM, BETA_LU, GAMMA_L, LNORM_L, UNIF_, 13 | CONSTANT, TNORM_TAU, CAUCHY_L }; 14 | 15 | DistributionType resolve_option(double type) 16 | { 17 | if (type == 1) return TNORM; 18 | if (type == 2) return BETA_LU; 19 | if (type == 3) return GAMMA_L; 20 | if (type == 4) return LNORM_L; 21 | if (type == 5) return UNIF_; 22 | if (type == 6) return CONSTANT; 23 | if (type == 7) return TNORM_TAU; 24 | if (type == 8) return CAUCHY_L; 25 | return DEFAULT; // 0 26 | } 27 | 28 | public: 29 | unsigned int m_npar; 30 | arma::vec m_p0, m_p1, m_l, m_u; 31 | arma::uvec m_d, m_lg; 32 | 33 | Prior (List & pprior); 34 | Prior (S4 & pprior); 35 | 36 | ~Prior(); 37 | 38 | void dprior(double * pvector, double * out); 39 | // dprior is important for hierarchical modelling to be accurate 40 | 41 | arma::vec dprior(arma::vec pvector); 42 | // a wrapper for Armadillo vector 43 | 44 | arma::vec rprior(); 45 | // Used by ininitlise & R's rprior; 46 | 47 | double sumlogprior(arma::vec pvector); 48 | 49 | void print(std::string str) const; 50 | // debugging function 51 | 52 | }; 53 | 54 | #endif 55 | -------------------------------------------------------------------------------- /inst/include/ggdmc/tnorm.hpp: -------------------------------------------------------------------------------- 1 | #ifndef TNORM_HPP 2 | #define TNORM_HPP 3 | 4 | #include // for std, cmath and many other supports via Rcpp 5 | 6 | #define SQRT_2PI 2.5066282746310007e+0 /* sqrt(2 x pi) */ 7 | 8 | class tnorm { 9 | public: 10 | // truncated normal distribution. 11 | double m, s, l, u; // mean, sd, lower, upper, and precision 12 | bool lp, lt; // log probability, lower tail 13 | 14 | tnorm (double mu, double sig, double lower, double upper, bool lg); 15 | 16 | tnorm (double mu, double sig, double lower, double upper, bool lg, 17 | bool lower_tail); 18 | tnorm (double mu, double sig, double lower, double upper); 19 | 20 | double d (double x); 21 | // Return probability density function. 22 | double p (double x); 23 | // Return cumulative distribution function. 24 | double r (); 25 | // Return random deviates 26 | 27 | void d (std::vector & x, std::vector & output); 28 | void p (std::vector & x, std::vector & output); 29 | 30 | double d2 (double x); 31 | // Return probability density function, using precision. 32 | 33 | 34 | 35 | private: 36 | double rtnorm0(const double &l, const double &u) { 37 | // Accept-Reject Algorithm 0; Naive method A-R method 38 | bool invalid = true; 39 | double z; 40 | while (invalid) { 41 | z = R::rnorm(0.0, 1.0); 42 | if (z <= u && z >= l) break; 43 | } 44 | return z; 45 | } 46 | 47 | double rtnorm1(const double &l, const double &u) { 48 | // Algorithm 1; 'expl'; use when lower > mean; upper = INFINITY; p 122, right 49 | bool invalid = true; 50 | double z, r, num; // a stands for alphaStar in Robert (1995) 51 | double a = 0.5 * (std::sqrt(l*l + 4.0) + l); 52 | 53 | while (invalid) { 54 | z = (-1.0/a)*std::log(R::runif(0.0, 1.0)) + l; // control lower boundary 55 | num = R::runif(0.0, 1.0); 56 | r = std::exp(-0.5 * (z - a)*(z - a)); 57 | if (num <= r && z <= u) break; 58 | } 59 | return z ; 60 | } 61 | 62 | double rtnorm2(const double &l, const double &u) { 63 | // Algorithm 2; 'expu'; use when upper < mean; lower = -INFINITY. 64 | bool invalid = true; 65 | double z, r, num; 66 | double a = 0.5 * (std::sqrt(u*u + 4.0) - u); 67 | 68 | while (invalid) { 69 | z = (-1.0/a)*std::log(R::runif(0.0, 1.0)) - u; // control lower boundary 70 | num = R::runif(0.0, 1.0); 71 | r = std::exp(-0.5 * (z - a)*(z - a)); 72 | if (num <= r && z <= -l) break; 73 | } 74 | return -z; // note the negative 75 | } 76 | 77 | double rtnorm3(const double &l, const double &u) { 78 | // Algorithm 3; page 123. 2.2. Two-sided truncated normal dist. 79 | bool invalid = true; 80 | double z, r, num; // a stands for alphaStar in Robert (1995) 81 | double l2 = l*l; 82 | double u2 = u*u; 83 | 84 | while (invalid) { 85 | z = R::runif(l, u) ; 86 | if (l > 0) { 87 | r = std::exp(0.5 * (l2 - z*z)); 88 | } else if (u < 0) { 89 | r = std::exp(0.5 * (u2 - z*z)); 90 | } else { 91 | r = std::exp( -0.5 * z * z ) ; 92 | } 93 | num = R::runif(0.0, 1.0); 94 | if (num <= r) break; 95 | } 96 | return z ; 97 | } 98 | 99 | }; 100 | 101 | #endif 102 | -------------------------------------------------------------------------------- /inst/include/ggdmc/vonmises.hpp: -------------------------------------------------------------------------------- 1 | #ifndef VONMISES_HPP 2 | #define VONMISES_HPP 3 | #include 4 | 5 | arma::vec rvonmises(unsigned int n, double mu, double kappa); 6 | 7 | #endif -------------------------------------------------------------------------------- /man/BuildDMI.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/model.R 3 | \name{BuildDMI} 4 | \alias{BuildDMI} 5 | \title{Bind data and models} 6 | \usage{ 7 | BuildDMI(x, model) 8 | } 9 | \arguments{ 10 | \item{x}{data formatted as a data frame} 11 | 12 | \item{model}{a model object} 13 | } 14 | \value{ 15 | a data model instance 16 | } 17 | \description{ 18 | Binding a data set with an object of data-model instance. The function 19 | checks whether the data and the model are compatible and adds attributes 20 | to a data model instance. 21 | } 22 | -------------------------------------------------------------------------------- /man/BuildModel.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/model.R 3 | \name{BuildModel} 4 | \alias{BuildModel} 5 | \title{Create a model object} 6 | \usage{ 7 | BuildModel(p.map, responses, factors = list(A = "1"), match.map = NULL, 8 | constants = numeric(0), type = "norm", posdrift = TRUE, 9 | verbose = TRUE) 10 | } 11 | \arguments{ 12 | \item{p.map}{parameter map. This option maps a particular factorial design 13 | to model parameters} 14 | 15 | \item{responses}{specifying the response names and levels} 16 | 17 | \item{factors}{specifying a list of factors and their treatment levels} 18 | 19 | \item{match.map}{match map. This option matches stimuli and responses} 20 | 21 | \item{constants}{specifying the parameters that you want to be fixed.} 22 | 23 | \item{type}{the model type defined in the package, "rd", "norm", or "cddm".} 24 | 25 | \item{posdrift}{a Boolean, switching between enforcing strict postive drift 26 | rates by using truncated normal distribution. This option is only useful in 27 | "norm" model type.} 28 | 29 | \item{verbose}{Print p.vector, constants and model type} 30 | } 31 | \description{ 32 | A model object consists of arrays with model attributes. 33 | } 34 | \examples{ 35 | ## A diffusion decision model 36 | model <- BuildModel( 37 | p.map = list(a ="1", v = "1",z = "1", d = "1", sz = "1", sv = "1", 38 | t0 = "1", st0 = "1"), 39 | match.map = list(M = list(s1 = "r1", s2 ="r2")), 40 | factors = list(S = c("s1", "s2")), 41 | constants = c(st0 = 0, d = 0), 42 | responses = c("r1", "r2"), 43 | type = "rd") 44 | 45 | ## A LBA model 46 | model <- BuildModel( 47 | p.map = list(A = "1", B = "1", t0 = "1", mean_v = "M", sd_v = "1", 48 | st0 = "1"), 49 | match.map = list(M = list(s1 = 1, s2 = 2)), 50 | factors = list(S = c("s1", "s2")), 51 | constants = c(st0 = 0, sd_v = 1), 52 | responses = c("r1", "r2"), 53 | type = "norm") 54 | 55 | ## A circular diffusion decision model 56 | model <- BuildModel( 57 | p.map = list(v1 = "1", v2 = "1", a = "1", t0 = "1", sigma1="1", 58 | sigma2="1", eta1="1", eta2="1", tmax="1", h="1"), 59 | match.map = list(M=list()), 60 | constants = c(sigma1 = 1, sigma2 = 1, eta1=0, eta2=0, tmax=6, h=1e-4), 61 | factors = list(S = c("s1", "s2")), 62 | responses = paste0('theta_', letters[1:4]), 63 | type = "cddm") 64 | } 65 | -------------------------------------------------------------------------------- /man/BuildPrior.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/prior.R 3 | \name{BuildPrior} 4 | \alias{BuildPrior} 5 | \title{Specifying Prior Distributions} 6 | \usage{ 7 | BuildPrior(p1, p2, lower = rep(NA, length(p1)), upper = rep(NA, 8 | length(p1)), dists = rep("tnorm", length(p1)), 9 | untrans = rep("identity", length(p1)), types = c("tnorm", "beta", 10 | "gamma", "lnorm", "unif", "constant", "tnorm2", "cauchy", NA), 11 | lg = TRUE) 12 | } 13 | \arguments{ 14 | \item{p1}{the first parameter of a distribution} 15 | 16 | \item{p2}{the second parameter of a distribution} 17 | 18 | \item{lower}{lower support (boundary)} 19 | 20 | \item{upper}{upper support (boundary)} 21 | 22 | \item{dists}{a vector of character string specifying a distribution.} 23 | 24 | \item{untrans}{whether to do log transformation. Default is not} 25 | 26 | \item{types}{available distribution types} 27 | 28 | \item{lg}{logical; if TRUE, probabilities p are given as log(p)} 29 | } 30 | \value{ 31 | a list of list 32 | } 33 | \description{ 34 | \code{BuildPrior} sets up prior distributions for each model 35 | parameter. \code{p1} and \code{p2} refer to the first and second parameters 36 | a prior distribution. \code{p1} must comes with parameter names. 37 | } 38 | \details{ 39 | Four distribution types are implemented: 40 | \enumerate{ 41 | \item Normal and truncated normal distribution, where: p1 = mean, p2 = sd. 42 | When the lower and upper are not provided, they are set to -Inf and 43 | Inf, rendering a normal distribution. Type name is "tnorm". 44 | \item Beta distribution, where: p1 = shape1 and p2 = shape2 (see \link{pbeta}). 45 | Note the uniform distribution is a special case of the beta with p1 = 1 46 | and p2 = 1. Type name is "beta". 47 | \item Gamma distribution, where p1 = shape and p2 = scale (see \link{pgamma}). 48 | Note p2 is scale, not rate. Type name is "gamma". 49 | \item Log-normal, where p1 = meanlog and p2 = sdlog (see \link{plnorm}). 50 | \item Uniform distribution. The bounds are not c(0, 1). The option comes handy. 51 | Type name is "unif". 52 | } 53 | } 54 | \examples{ 55 | ## Show using dbeta to visualise a uniform distribution with bound (0, 1) 56 | x <- seq(-.1, 1.1, .001) 57 | plot(x, dbeta(x, 1, 1), type="l", ylab="Density", xlab="x", lwd=2) 58 | 59 | ## BuildPrior 60 | pop.mean <- c(a=2, v=4, z=0.5, t0=0.3) 61 | pop.scale <- c(a=0.5, v=.5, z=0.1, t0=0.05) 62 | 63 | pop.prior <- BuildPrior( 64 | dists = rep("tnorm", 4), 65 | p1 = pop.mean, 66 | p2 = pop.scale, 67 | lower = c(0,-5, 0, 0), 68 | upper = c(5, 7, 1, 1)) 69 | 70 | p.prior <- BuildPrior( 71 | dists = rep("tnorm", 4), 72 | p1 = pop.mean, 73 | p2 = pop.scale*5, 74 | lower = c(0,-5, 0, 0), 75 | upper = c(5, 7, 1, 1)) 76 | 77 | mu.prior <- BuildPrior( 78 | dists = rep("tnorm", 4), 79 | p1 = pop.mean, 80 | p2 = pop.scale*5, 81 | lower = c(0,-5, 0, 0), 82 | upper = c(5, 7, 1, 1)) 83 | 84 | sigma.prior <- BuildPrior( 85 | dists = rep("beta", 4), 86 | p1 = c(a=1, v=1, z=1, t0=1), 87 | p2 = rep(1, 4), 88 | upper = rep(1, 4)) 89 | 90 | ## Bind three priors together for hierarchical modelling 91 | priors <- list(pprior=p.prior, location=mu.prior, scale=sigma.prior) 92 | 93 | } 94 | -------------------------------------------------------------------------------- /man/DIC-methods.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/model-class.R 3 | \docType{methods} 4 | \name{DIC} 5 | \alias{DIC} 6 | \alias{DIC,posterior-method} 7 | \alias{DIC,list-method} 8 | \alias{DIC,hyper-method} 9 | \title{Deviance Information Criteria} 10 | \usage{ 11 | DIC(object, ...) 12 | 13 | \S4method{DIC}{posterior}(object, start = 1, end = NA, BPIC = FALSE) 14 | 15 | \S4method{DIC}{list}(object, start = 1, end = NA, BPIC = FALSE) 16 | 17 | \S4method{DIC}{hyper}(object, start = 1, end = NA, BPIC = FALSE) 18 | } 19 | \arguments{ 20 | \item{object}{posterior samples from one participant} 21 | 22 | \item{...}{other plotting arguments passing through dot dot dot.} 23 | 24 | \item{start}{start from which iteration.} 25 | 26 | \item{end}{end at which iteration. For example, set 27 | \code{start = 101} and \code{end = 1000}, instructs the function to 28 | calculate from 101 to 1000 iteration.} 29 | 30 | \item{BPIC}{a Boolean switch to calculate BPIC, instead of DIC} 31 | } 32 | \description{ 33 | Calculate DIC and BPIC. 34 | } 35 | \details{ 36 | This function implements three different definitions of the "effective 37 | number of parameters of the model". First is from Spiegelhalter et al 38 | (2002, p. 587), "... that pD can be considered as a 'mean deviance minus 39 | the deviance of the means'". Second is from Gelman et al (2014, p. 173, 40 | equation 7.10), and third subtracts the minimal value of the deviance from 41 | the mean of the deviance. 42 | } 43 | \examples{ 44 | ## Calculate DIC from data of one participant 45 | \dontrun{ 46 | model <- BuildModel( 47 | p.map = list(A = "1", B = "1", t0 = "1", mean_v = "M", sd_v = "1", 48 | st0 = "1"), 49 | match.map = list(M = list(s1 = 1, s2 = 2)), 50 | factors = list(S = c("s1", "s2")), 51 | constants = c(st0 = 0, sd_v = 1), 52 | responses = c("r1", "r2"), 53 | type = "norm") 54 | 55 | p.vector <- c(A = .75, B = 1.25, t0 = .15, mean_v.true = 2.5, 56 | mean_v.false = 1.5) 57 | ntrial <- 50 58 | dat <- simulate(model, nsim = ntrial, ps = p.vector) 59 | dmi <- BuildDMI(dat, model) 60 | 61 | p.prior <- BuildPrior( 62 | dists = c("tnorm", "tnorm", "beta", "tnorm", "tnorm"), 63 | p1 = c(A = 1, B = 1, t0 = 1, mean_v.true = 1, mean_v.false = 1), 64 | p2 = c(1, 1, 1, 1, 1), 65 | lower = c(rep(0, 3), rep(NA, 2)), 66 | upper = c(rep(NA, 2), 1, rep(NA, 2))) 67 | 68 | ## Sampling 69 | fit0 <- StartNewsamples(dmi, p.prior) 70 | fit <- run(fit0, thin = 8) 71 | 72 | DIC(fit) 73 | DIC(fit) 74 | DIC(fit, start=100, end=200) 75 | DIC(fit, BPIC=TRUE) 76 | DIC(fit, BPIC=TRUE, start=201, end=400) 77 | } 78 | 79 | ## Calculate DICs from data of 8 participant 80 | \dontrun{ 81 | model <- BuildModel( 82 | p.map = list(a = "1", v = "F", z = "1", d = "1", sz = "1", sv = "1", 83 | t0 = "1", st0 = "1"), 84 | match.map = list(M = list(s1 = "r1", s2 = "r2")), 85 | factors = list(S = c("s1", "s2"), F = c("f1", "f2")), 86 | constants = c(st0 = 0, d = 0), 87 | responses = c("r1", "r2"), 88 | type = "rd") 89 | npar <- length(Get_pnames(model)) 90 | 91 | ## Population distribution 92 | pop.mean <- c(a=2, v.f1=4, v.f2=3, z=0.5, sz=0.3, sv=1, t0=0.3) 93 | pop.scale <- c(a=0.5, v.f1=.5, v.f2=.5, z=0.1, sz=0.1, sv=.3, t0=0.05) 94 | pop.prior <- BuildPrior( 95 | dists = rep("tnorm", npar), 96 | p1 = pop.mean, 97 | p2 = pop.scale, 98 | lower = c(0,-5, -5, 0, 0, 0, 0), 99 | upper = c(5, 7, 7, 1, 2, 1, 1)) 100 | 101 | ## Simulate some data 102 | dat <- simulate(model, nsub = 8, nsim = 10, prior = pop.prior) 103 | dmi <- BuildDMI(dat, model) 104 | ps <- attr(dat, "parameters") 105 | 106 | p.prior <- BuildPrior( 107 | dists = rep("tnorm", npar), 108 | p1 = pop.mean, 109 | p2 = pop.scale*5, 110 | lower = c(0,-5, -5, 0, 0, 0, 0), 111 | upper = c(5, 7, 7, 1, 2, 2, 1)) 112 | 113 | ## Sampling 114 | fit0 <- StartNewsamples(dmi, p.prior, ncore=1) 115 | fit <- run(fit0, ncore=4) ## No printing when running in RStudio 116 | 117 | ## Calculate DIC for participant 1 118 | DIC(fit[[1]]) 119 | 120 | ## Calculate all participants 121 | res <- DIC(fit) 122 | 123 | ## BPIC 124 | res <- DIC(fit, BPIC = TRUE) 125 | } 126 | 127 | } 128 | -------------------------------------------------------------------------------- /man/GetNsim.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/model-class.R 3 | \name{GetNsim} 4 | \alias{GetNsim} 5 | \title{Get a n-cell matrix} 6 | \usage{ 7 | GetNsim(ncell, n, ns) 8 | } 9 | \arguments{ 10 | \item{ncell}{number of cells.} 11 | 12 | \item{n}{number of trials.} 13 | 14 | \item{ns}{number of subjects.} 15 | } 16 | \description{ 17 | Constructs a matrix, showing how many responses to in each 18 | cell. The function checks whether the format of \code{n} and \code{ns} 19 | conform. 20 | } 21 | \details{ 22 | \code{n} can be: 23 | \enumerate{ 24 | \item an integer for a balanced design, 25 | \item a matrix for an unbalanced design, where rows are subjects and 26 | columns are cells. If the matrix is a row vector, all subjects 27 | have the same \code{n} in each cell. If it is a column vector, all 28 | cells have the same \code{n}. Otherwise each entry specifies the \code{n} 29 | for a particular subject x cell combination. See below for concrete 30 | examples.} 31 | } 32 | \examples{ 33 | model <- BuildModel( 34 | p.map = list(A = "1", B = "R", t0 = "1", mean_v = "M", sd_v = "M", 35 | st0 = "1"), 36 | match.map = list(M = list(s1 = 1, s2 = 2)), 37 | constants = c(sd_v.false = 1, st0 = 0), 38 | factors = list(S = c("s1","s2")), 39 | responses = c("r1", "r2"), 40 | type = "norm") 41 | 42 | #######################30 43 | ## Example 1 44 | #######################30 45 | cells <- as.numeric(sapply(model@factors, length)) 46 | ncell <- prod(cells) 47 | GetNsim(ncell, ns = 2, n = 1) 48 | # [,1] [,2] 49 | # [1,] 1 1 50 | # [2,] 1 1 51 | 52 | #######################30 53 | ## Example 2 54 | #######################30 55 | n <- matrix(c(1:2), ncol = 1) 56 | # [,1] 57 | # [1,] 1 ## subject 1 has 1 response for each cell 58 | # [2,] 2 ## subject 2 has 2 responses for each cell 59 | 60 | GetNsim(ncell, ns = 2, n = n) 61 | # [,1] [,2] 62 | # [1,] 1 1 63 | # [2,] 2 2 64 | 65 | #######################30 66 | ## Example 3 67 | #######################30 68 | n <- matrix(c(1:2), nrow = 1) 69 | # [,1] [,2] 70 | # [1,] 1 2 71 | GetNsim(ncell, ns = 2, n = n) 72 | # [,1] [,2] 73 | # [1,] 1 2 ## subject 1 has 1 response for cell 1 and 2 responses for cell 2 74 | # [2,] 1 2 ## subject 2 has 1 response for cell 1 and 2 responses for cell 2 75 | 76 | #######################30 77 | ## Example 4 78 | #######################30 79 | n <- matrix(c(1:4), nrow=2) 80 | # [,1] [,2] 81 | # [1,] 1 3 82 | # [2,] 2 4 83 | GetNsim(ncell, ns = 2, n = n) 84 | # [,1] [,2] 85 | # [1,] 1 3 ## subject 1 has 1 response for cell 1 and 3 responses for cell 2 86 | # [2,] 2 4 ## subject 2 has 2 responses for cell 1 and 4 responses for cell 2 87 | } 88 | -------------------------------------------------------------------------------- /man/GetPNames.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/utils.R 3 | \name{GetPNames} 4 | \alias{GetPNames} 5 | \title{Extract parameter names from a model object} 6 | \usage{ 7 | GetPNames(x) 8 | } 9 | \arguments{ 10 | \item{x}{a model object} 11 | } 12 | \description{ 13 | GetPNames will be deprecated. Please extract pnames directly via S4 slot 'model@pnames' 14 | } 15 | -------------------------------------------------------------------------------- /man/GetParameterMatrix.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/model-class.R 3 | \name{GetParameterMatrix} 4 | \alias{GetParameterMatrix} 5 | \title{Constructs a ns x npar matrix,} 6 | \usage{ 7 | GetParameterMatrix(object, nsub, prior, ps, seed = NULL) 8 | } 9 | \arguments{ 10 | \item{object}{a model object} 11 | 12 | \item{nsub}{number of subjects.} 13 | 14 | \item{prior}{a prior object} 15 | 16 | \item{ps}{a vector or a matirx.} 17 | 18 | \item{seed}{an integer specifying a random seed.} 19 | } 20 | \value{ 21 | a ns x npar matrix 22 | } 23 | \description{ 24 | The matrix is used to simulate data. Each row represents one set of 25 | parameters for a participant. 26 | } 27 | \details{ 28 | One must enter either a vector or a matrix as true parameters 29 | to the argument, \code{ps}, when presuming to simulate data based on a 30 | fixed-effect model. When the assumption is to simulate data based on a 31 | random-effect model, one must enter a prior object to the argument, 32 | \code{prior} to first randomly generate a true parameter matrix. 33 | } 34 | \examples{ 35 | model <- BuildModel( 36 | p.map = list(a ="1", v = "1",z = "1", d = "1", sz = "1", sv = "1", 37 | t0 = "1", st0 = "1"), 38 | match.map = list(M = list(s1 = "r1", s2 ="r2")), 39 | factors = list(S = c("s1", "s2")), 40 | constants = c(st0 = 0, d = 0), 41 | responses = c("r1", "r2"), 42 | type = "rd") 43 | 44 | p.prior <- BuildPrior( 45 | dists = c("tnorm", "tnorm", "beta", "beta", "tnorm", "beta"), 46 | p1 = c(a = 1, v = 0, z = 1, sz = 1, sv = 1, t0 = 1), 47 | p2 = c(a = 1, v = 2, z = 1, sz = 1, sv = 1, t0 = 1), 48 | lower = c(0, -5, NA, NA, 0, NA), 49 | upper = c(2, 5, NA, NA, 2, NA)) 50 | 51 | ## Example 1: Randomly generate 2 sets of true parameters from 52 | ## parameter priors (p.prior) 53 | GetParameterMatrix(model, nsub=2, p.prior) 54 | ## a v z sz sv t0 55 | ## [1,] 1.963067 1.472940 0.9509158 0.5145047 1.344705 0.0850591 56 | ## [2,] 1.512276 -1.995631 0.6981290 0.2626882 1.867853 0.1552828 57 | 58 | ## Example 2: Use a user-selected true parameters 59 | true.vector <- c(a=1, v=1, z=0.5, sz=0.2, sv=1, t0=.15) 60 | GetParameterMatrix(model, nsub=2, ps = true.vector) 61 | ## a v z sz sv t0 62 | ## 1 1 1 0.5 0.2 1 0.15 63 | ## 2 1 1 0.5 0.2 1 0.15 64 | 65 | ## Example 3: When a user enter arbritary sequence of parameters. 66 | ## Note sv is before sz. It should be sz before sv 67 | ## See correct sequence, by entering "model@pnames" 68 | ## GetParameterMatrix will rearrange the sequence. 69 | true.vector <- c(t0=15, a=1, v=1, z=0.5, sv=1, sz = .2) 70 | GetParameterMatrix(model, nsub=2, ps= true.vector) 71 | ## a v z sz sv t0 72 | ## 1 1 1 0.5 0.2 1 0.15 73 | ## 2 1 1 0.5 0.2 1 0.15 74 | 75 | } 76 | -------------------------------------------------------------------------------- /man/PickStuck-methods.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/analysis.R, R/diagnosis.R, R/model-class.R 3 | \docType{methods} 4 | \name{CheckConverged} 5 | \alias{CheckConverged} 6 | \alias{PickStuck} 7 | \alias{PickStuck,posterior-method} 8 | \alias{PickStuck,list-method} 9 | \alias{PickStuck,hyper-method} 10 | \alias{isstuck} 11 | \alias{isstuck,posterior-method} 12 | \alias{isstuck,list-method} 13 | \alias{isstuck,hyper-method} 14 | \alias{isflat} 15 | \alias{isflat,posterior-method} 16 | \alias{isflat,list-method} 17 | \alias{ismixed} 18 | \alias{ismixed,posterior-method} 19 | \title{Convergence Diagnosis} 20 | \usage{ 21 | CheckConverged(x) 22 | 23 | CheckConverged(x) 24 | 25 | PickStuck(x, ...) 26 | 27 | \S4method{PickStuck}{posterior}(x, cut = 10, start = 1, end = NA, 28 | verbose = FALSE, digits = 2) 29 | 30 | \S4method{PickStuck}{list}(x, cut = 10, start = 1, end = NA, 31 | verbose = FALSE, digits = 2) 32 | 33 | \S4method{PickStuck}{hyper}(x, hyper = TRUE, cut = 10, start = 1, 34 | end = NA, verbose = FALSE, digits = 2) 35 | 36 | isstuck(x, ...) 37 | 38 | \S4method{isstuck}{posterior}(x, cut = 10, start = 1, end = NA, 39 | verbose = FALSE) 40 | 41 | \S4method{isstuck}{list}(x, cut = 10, start = 1, end = NA, 42 | verbose = FALSE, digits = 2) 43 | 44 | \S4method{isstuck}{hyper}(x, hyper = TRUE, cut = 10, start = 1, 45 | end = NA, verbose = FALSE, digits = 2) 46 | 47 | isflat(x, ...) 48 | 49 | \S4method{isflat}{posterior}(x, p1 = 1/3, p2 = 1/3, cut = 0.25, 50 | cut_scale = Inf, verbose = FALSE, digits = 2) 51 | 52 | \S4method{isflat}{list}(x, p1 = 1/3, p2 = 1/3, cut = 0.25, 53 | cut_scale = Inf, verbose = FALSE, digits = 2) 54 | 55 | ismixed(x, ...) 56 | 57 | \S4method{ismixed}{posterior}(x, cut = 1.1, verbose = FALSE) 58 | } 59 | \arguments{ 60 | \item{x}{posterior samples} 61 | 62 | \item{...}{other additional arguments} 63 | 64 | \item{cut}{a criterion for deciding whether chains get stuck 65 | (\code{isstuck}); whether chains are not flat 66 | (using median or IQR \code{isflat}); whether chains are well mixed 67 | \code{ismixed}.} 68 | 69 | \item{start}{start to evaluate from which iteration.} 70 | 71 | \item{end}{end at which iteration for evaeuation.} 72 | 73 | \item{verbose}{a boolean switch to print more information} 74 | 75 | \item{digits}{print how many digits. Default is 2} 76 | 77 | \item{hyper}{whether x are hierarhcial samples} 78 | 79 | \item{p1}{the range of the head of MCMC chains} 80 | 81 | \item{p2}{the range of the tail of the MCMC chains} 82 | 83 | \item{cut_scale}{Use IQR to decide whether chains are not flat} 84 | } 85 | \value{ 86 | \code{PickStuck} gives an index vector; \code{unstick} gives a 87 | posterios samples. 88 | } 89 | \description{ 90 | These functions test whether Markov chains are converged . 91 | } 92 | \details{ 93 | \code{isstuck} tests whether a chain hovers around a region significantly 94 | deviates from other its peers. 95 | 96 | \code{PickStuck} calculate each chain separately for the mean (across 97 | MC samples) of posterior log likelihood. If the difference of the means and 98 | the median (across chains) of the mean of posterior log likelihood 99 | is greater than the value set in \code{cut}, chains are considered stuck. 100 | The default value for \code{cut} is 10. The user should consider their 101 | situatin to set the cut value. 102 | 103 | \code{unstick} removes stuck chains from posterior samples (not well tested). 104 | 105 | \code{ismixed} tests whether the potential scale reduction factor for a 106 | model fit is lower than a criterion, defined by \code{cut}. 107 | 108 | \code{iseffective} testes whether posterior samples are enough adjusted 109 | autocorrelation. 110 | 111 | \code{CheckConverged} is a wrapper function running the four checking 112 | functions, \code{isstuck}, \code{isflat}, \code{ismixed} and \code{iseffective}. 113 | } 114 | \examples{ 115 | model <- BuildModel( 116 | p.map = list(a = "1", v="1", z="1", d="1", sz="1", sv="1", t0="1", 117 | st0="1"), 118 | match.map = list(M = list(s1 = "r1", s2 = "r2")), 119 | factors = list(S = c("s1", "s2")), 120 | responses = c("r1","r2"), 121 | constants = c(st0 = 0, d = 0, sv = 0, sz = 0), 122 | type = "rd") 123 | 124 | npar <- model@npar 125 | pop.mean <- c(a=2, v=4, z=0.5, t0=0.3) 126 | pop.scale <- c(a=0.5, v=.5, z=0.1, t0=0.05) 127 | pop.prior <- BuildPrior( 128 | dists = rep("tnorm", npar), 129 | p1 = pop.mean, 130 | p2 = pop.scale, 131 | lower = c(0,-5, 0, 0), 132 | upper = c(5, 7, 1, 1)) 133 | 134 | dat <- simulate(model, nsub = 8, nsim = 30, prior = pop.prior) 135 | dmi <- BuildDMI(dat, model) 136 | ps <- attr(dat, "parameters") 137 | 138 | p.prior <- BuildPrior( 139 | dists = rep("tnorm", npar), 140 | p1 = pop.mean, 141 | p2 = pop.scale*5, 142 | lower = c(0,-5, 0, 0), 143 | upper = c(5, 7, 1, 1)) 144 | 145 | mu.prior <- BuildPrior( 146 | dists = rep("tnorm", npar), 147 | p1 = pop.mean, 148 | p2 = pop.scale*5, 149 | lower = c(0,-5, 0, 0), 150 | upper = c(5, 7, 1, 1)) 151 | 152 | sigma.prior <- BuildPrior( 153 | dists = rep("beta", npar), 154 | p1 = c(a=1, v=1, z=1, t0=1), 155 | p2 = rep(1, npar), 156 | upper = rep(1, npar)) 157 | 158 | ## Note the names are important 159 | priors <- list(pprior=p.prior, location=mu.prior, scale=sigma.prior) 160 | 161 | \dontrun{ 162 | Fit hierarchical model ----## 163 | fit0 <- StartNewsamples(dmi, priors) 164 | fit <- run(fit0) 165 | 166 | PickStuck(fit, hyper=TRUE) 167 | PickStuck(fit@individuals[[1]]) 168 | PickStuck(fit) 169 | 170 | tmp <- PickStuck(fit, hyper=TRUE, verbose=T) 171 | tmp <- PickStuck(fit@individuals[[1]], verbose=T) 172 | tmp <- PickStuck(fit, verbose=T) 173 | isstuck(fit0@individuals[[1]]) 174 | isstuck(fit@individuals[[1]]) 175 | isstuck(fit, hyper = TRUE) 176 | 177 | tmp <- isflat(fit@individuals[[1]]) 178 | tmp <- isflat(fit@individuals[[1]], verbose = TRUE) 179 | 180 | tmp <- isflat(fit@individuals[[1]], cut_scale = .25) 181 | tmp <- isflat(fit@individuals[[1]], cut_scale = .25, verbose = TRUE) 182 | 183 | ## Test unstick 184 | fit0 <- StartNewsamples(dmi, priors, nmc=50) 185 | fit <- run(fit0, nmc=200) 186 | bad <- PickStuck(fit@individuals[[1]], verbose=T) 187 | chain_removed <- unstick_one(fit@individuals[[1]], bad) 188 | plot(tmp) 189 | } 190 | } 191 | -------------------------------------------------------------------------------- /man/StartNewsamples.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/sampling.R 3 | \name{StartNewsamples} 4 | \alias{StartNewsamples} 5 | \alias{run} 6 | \title{Start new model fits} 7 | \usage{ 8 | StartNewsamples(dmi, prior, nmc = 200, thin = 1, nchain = NULL, 9 | report = 100, rp = 0.001, gammamult = 2.38, pm0 = 0.05, 10 | pm1 = 0.05, block = TRUE, ncore = 1) 11 | 12 | run(samples, nmc = 500, thin = 1, report = 100, rp = 0.001, 13 | gammamult = 2.38, pm0 = 0, pm1 = 0, block = TRUE, ncore = 1, 14 | add = FALSE, prior = NULL) 15 | } 16 | \arguments{ 17 | \item{dmi}{a data model instance or a list of data model instances} 18 | 19 | \item{prior}{prior objects. For hierarchical model, this must be a 20 | list with three sets of prior distributions. Each is respectively named, 21 | "pprior", "location", and "scale".} 22 | 23 | \item{nmc}{number of Monte Carlo samples} 24 | 25 | \item{thin}{thinning length} 26 | 27 | \item{nchain}{number of chains} 28 | 29 | \item{report}{progress report interval} 30 | 31 | \item{rp}{tuning parameter 1} 32 | 33 | \item{gammamult}{tuning parameter 2. This is the step size.} 34 | 35 | \item{pm0}{probability of migration type 0 (Hu & Tsui, 2010)} 36 | 37 | \item{pm1}{probability of migration type 1 (Turner et al., 2013)} 38 | 39 | \item{block}{Only for hierarchical modeling. A Boolean switch for update one 40 | parameter at a time} 41 | 42 | \item{ncore}{Only for non-hierarchical, fixed-effect models with many 43 | subjects.} 44 | 45 | \item{samples}{posterior samples.} 46 | 47 | \item{add}{Boolean whether to add new samples} 48 | } 49 | \description{ 50 | Fit a hierarchical or a fixed-effect model, using Bayeisan 51 | optimisation. We use a specific type of pMCMC algorithm, the DE-MCMC. This 52 | particular sampling method includes crossover and two different migration 53 | operators. The migration operators are similar to random-walk algorithm. 54 | They would be less efficient to find the target parameter space, if been 55 | used alone. 56 | } 57 | -------------------------------------------------------------------------------- /man/TableParameters.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/model.R 3 | \name{TableParameters} 4 | \alias{TableParameters} 5 | \title{Table response and parameter} 6 | \usage{ 7 | TableParameters(p.vector, cell, model, n1order) 8 | } 9 | \arguments{ 10 | \item{p.vector}{a parameter vector} 11 | 12 | \item{cell}{a string or an integer indicating a design cell, e.g., 13 | \code{s1.f1.r1} or 1. Note the integer cannot exceed the number of cell. 14 | One can check this by entering \code{length(dimnames(model))}.} 15 | 16 | \item{model}{a model object} 17 | 18 | \item{n1order}{a Boolean switch, indicating using node 1 ordering. This is 19 | only for LBA-like models and its n1PDF likelihood function.} 20 | } 21 | \value{ 22 | each row corresponding to the model parameter for a response. 23 | When \code{n1.order} is FALSE, TableParameters returns a martix without 24 | rearranging into node 1 order. For example, this is used in 25 | the \code{simulate} function. By default \code{n1.order} is TRUE. 26 | } 27 | \description{ 28 | \code{TableParameters} arranges the values in a parameter 29 | vector and creates a response x parameter matrix. The matrix is used 30 | by the likelihood function, assigning a trial to a cell for calculating 31 | probability densities. 32 | } 33 | \examples{ 34 | m1 <- BuildModel( 35 | p.map = list(a = "1", v = "F", z = "1", d = "1", sz = "1", sv = "F", 36 | t0 = "1", st0 = "1"), 37 | match.map = list(M = list(s1 = "r1", s2 = "r2")), 38 | factors = list(S = c("s1", "s2"), F = c("f1","f2")), 39 | constants = c(st0 = 0, d = 0), 40 | responses = c("r1","r2"), 41 | type = "rd") 42 | 43 | m2 <- BuildModel( 44 | p.map = list(A = "1", B = "1", mean_v = "M", sd_v = "1", 45 | t0 = "1", st0 = "1"), 46 | constants = c(st0 = 0, sd_v = 1), 47 | match.map = list(M = list(s1 = 1, s2 = 2)), 48 | factors = list(S = c("s1", "s2")), 49 | responses = c("r1", "r2"), 50 | type = "norm") 51 | 52 | pvec1 <- c(a = 1.15, v.f1 = -0.10, v.f2 = 3, z = 0.74, sz = 1.23, 53 | sv.f1 = 0.11, sv.f2 = 0.21, t0 = 0.87) 54 | pvec2 <- c(A = .75, B = .25, mean_v.true = 2.5, mean_v.false = 1.5, 55 | t0 = .2) 56 | 57 | print(m1, pvec1) 58 | print(m2, pvec2) 59 | 60 | accMat1 <- TableParameters(pvec1, "s1.f1.r1", m1, FALSE) 61 | accMat2 <- TableParameters(pvec2, "s1.r1", m2, FALSE) 62 | 63 | ## a v t0 z d sz sv st0 64 | ## 1.15 -0.1 0.87 0.26 0 1.23 0.11 0 65 | ## 1.15 -0.1 0.87 0.26 0 1.23 0.11 0 66 | 67 | ## A b t0 mean_v sd_v st0 68 | ## 0.75 1 0.2 2.5 1 0 69 | ## 0.75 1 0.2 1.5 1 0 70 | } 71 | -------------------------------------------------------------------------------- /man/ac.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/utils.R 3 | \name{ac} 4 | \alias{ac} 5 | \title{Calculate the autocorrelation of a vector} 6 | \usage{ 7 | ac(x, nLags = 50) 8 | } 9 | \arguments{ 10 | \item{x}{a vector storing parameter values} 11 | 12 | \item{nLags}{the maximum number of lags} 13 | } 14 | \value{ 15 | A data.frame 16 | } 17 | \description{ 18 | Calculate the autocorrelation of a vector. 19 | } 20 | \examples{ 21 | res <- ac(1:100) 22 | ## List of 2 23 | ## $ Lag : int [1:50] 1 2 3 4 5 6 7 8 9 10 ... 24 | ## $ Autocorrelation: num [1:50] 1 1 1 1 1 1 1 1 1 1 ... 25 | 26 | res <- ac(rnorm(100)) 27 | str(res) 28 | ## List of 2 29 | ## $ Lag : int [1:50] 1 2 3 4 5 6 7 8 9 10 ... 30 | ## $ Autocorrelation: num [1:50] 1 -0.0485 0.0265 -0.1496 0.0437 ... 31 | } 32 | -------------------------------------------------------------------------------- /man/autocorr.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/plotting.R 3 | \name{autocorr} 4 | \alias{autocorr} 5 | \title{Autocorrelation Plot} 6 | \usage{ 7 | autocorr(x, start = 1, end = NA, nLags = 50, pll = TRUE, 8 | subchain = FALSE) 9 | } 10 | \arguments{ 11 | \item{x}{posterior samples} 12 | 13 | \item{start}{start from which iteration.} 14 | 15 | \item{end}{end at which iteration} 16 | 17 | \item{nLags}{the maximum number of lags.} 18 | 19 | \item{pll}{a Boolean switch for plotting parameter values or posterior 20 | log likelihoods} 21 | 22 | \item{subchain}{a Boolean switch to plot a subset of chains.} 23 | } 24 | \description{ 25 | Plot the autocorrelation of posterior samples, 26 | } 27 | \examples{ 28 | ## Model 1 29 | ## 27 elements with 20 levels 30 | FR <- list(S = c("n","w","p"), cond=c("C","F", "H"), R=c("N", "W", "P")) 31 | lev <- c("CnN","CwN", "CnW","CwW", 32 | "FnN","FwN","FpN", "FnW","FwW","FpW", "fa","FpP", 33 | "HnN","HwN","HpN", "HnW","HwW","HpW", "HpP", 34 | "FAKERATE") 35 | map_mean_v <- ggdmc:::MakeEmptyMap(FR, lev) 36 | map_mean_v[1:27] <- c( 37 | "CnN","CwN","FAKERATE", "FnN","FwN","FpN", "HnN","HwN","HpN", 38 | "CnW","CwW","FAKERATE", "FnW","FwW","FpW", "HnW","HwW","HpW", 39 | "FAKERATE","FAKERATE","FAKERATE", "fa","fa","FpP", "fa","fa","HpP") 40 | 41 | model0 <- BuildModel( 42 | p.map = list(A = "1", B = c("cond", "R"), t0 = "1", mean_v = c("MAPMV"), 43 | sd_v = "1", st0 = "1", N = "cond"), 44 | match.map = list(M = list(n = "N", w = "W", p = "P"), MAPMV = map_mean_v), 45 | factors = list(S = c("n","w","p"), cond = c("C","F", "H")), 46 | constants = c(N.C = 2, N.F = 3, N.H = 3, st0 = 0, B.C.P = Inf, 47 | mean_v.FAKERATE = 1, sd_v = 1), 48 | responses = c("N", "W", "P"), 49 | type = "norm") 50 | 51 | npar <- model0@npar 52 | 53 | p.vector <- c(A = .3, B.C.N = 1.3, B.F.N = 1.3, B.H.N = 1.3, 54 | B.C.W = 1.3, B.F.W = 1.4, B.H.W = 1.5, 55 | B.F.P = 1.1, B.H.P = 1.3, 56 | 57 | t0=.1, 58 | 59 | mean_v.CnN = 2.8, mean_v.CwN = -0.3, mean_v.CnW=-1, 60 | mean_v.CwW = 2.9, mean_v.FnN = 2.8, mean_v.FwN=-.3, 61 | 62 | mean_v.FpN = -1.6, mean_v.FnW = -1, mean_v.FwW = 2.9, 63 | mean_v.FpW = .5 , mean_v.fa = -2.4, mean_v.FpP = 2.5, 64 | 65 | mean_v.HnN = 2.8, mean_v.HwN = -.5, mean_v.HpN = -.6, 66 | mean_v.HnW = -.7, mean_v.HwW = 3.0, mean_v.HpW = 1.6, 67 | mean_v.HpP = 2.3) 68 | 69 | acc_tab0 <- TableParameters(p.vector, 1, model0, FALSE) 70 | acc_tab1 <- TableParameters(p.vector, "w.C.N", model0, FALSE) 71 | acc_tab2 <- TableParameters(p.vector, "w.F.P", model0, FALSE) 72 | print(acc_tab0); print(acc_tab1); print(acc_tab2) 73 | 74 | \dontrun{ 75 | dat0 <- simulate(model0, nsim=50, ps=p.vector) 76 | dmi0 <- BuildDMI(dat0, model0) 77 | } 78 | p1 <- rep(1, npar) 79 | names(p1) <- model0@pnames 80 | 81 | p.prior0 <- BuildPrior( 82 | dists = c(rep("tnorm", 9), "beta", rep("tnorm", 19)), 83 | p1 = p1, 84 | p2 = c(rep(2, 9), 1, rep(2, 19)), 85 | lower = c(rep(0, 10), rep(NA, 19)), 86 | upper = c(rep(NA, 9), 1, rep(NA, 19))) 87 | 88 | # plot(p.prior0, ps = p.vector) 89 | ## Sampling 90 | ## 18.4 & 36.17 s 91 | \dontrun{ 92 | fit0 <- StartNewsamples(dmi0, p.prior0, block = FALSE, thin=4) 93 | fit0_correct <- run(fit0, thin=4, block = FALSE) 94 | 95 | hat <- gelman(fit0_correct, verbose=TRUE); 96 | p0 <- autocorr(fit0_correct, subchain=1:3, pll=TRUE) 97 | } 98 | } 99 | -------------------------------------------------------------------------------- /man/check_pvec.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/model.R 3 | \name{check_pvec} 4 | \alias{check_pvec} 5 | \title{Does a model object specify a correct p.vector} 6 | \usage{ 7 | check_pvec(ps, model) 8 | } 9 | \arguments{ 10 | \item{ps}{parameter vector} 11 | 12 | \item{model}{a model object} 13 | } 14 | \description{ 15 | Check a parameter vector 16 | } 17 | -------------------------------------------------------------------------------- /man/dbeta_lu.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/prior.R 3 | \name{dbeta_lu} 4 | \alias{dbeta_lu} 5 | \title{A modified dbeta function} 6 | \usage{ 7 | dbeta_lu(x, p1, p2, lower, upper, lg = FALSE) 8 | } 9 | \arguments{ 10 | \item{x}{quantile} 11 | 12 | \item{p1}{shape1 parameter} 13 | 14 | \item{p2}{shape2 parameter} 15 | 16 | \item{lower}{lower bound} 17 | 18 | \item{upper}{upper bound} 19 | 20 | \item{lg}{logical; if TRUE, return log density.} 21 | } 22 | \description{ 23 | A modified dbeta function 24 | } 25 | -------------------------------------------------------------------------------- /man/dcauchy_l.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/prior.R 3 | \name{dcauchy_l} 4 | \alias{dcauchy_l} 5 | \title{A modified dcauchy functions} 6 | \usage{ 7 | dcauchy_l(x, p1, p2, lower, upper, lg = FALSE) 8 | } 9 | \arguments{ 10 | \item{x}{quantile} 11 | 12 | \item{p1}{location parameter} 13 | 14 | \item{p2}{scale parameter} 15 | 16 | \item{lower}{lower bound} 17 | 18 | \item{upper}{upper bound} 19 | 20 | \item{lg}{log density?} 21 | } 22 | \description{ 23 | A modified dcauchy functions 24 | } 25 | -------------------------------------------------------------------------------- /man/dcircle.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/RcppExports.R 3 | \name{dcircle} 4 | \alias{dcircle} 5 | \alias{dcircle300} 6 | \alias{rcircle} 7 | \alias{rcircle_process} 8 | \alias{r1d} 9 | \title{Two-dimension Diffusion Model} 10 | \usage{ 11 | dcircle(RT, A, P, tmax, kmax, sz, nw) 12 | 13 | dcircle300(P, tmax, kmax, sz, nw) 14 | 15 | rcircle(n, P, tmax, h, nw) 16 | 17 | rcircle_process(P, tmax, h) 18 | 19 | r1d(P, tmax, h) 20 | } 21 | \arguments{ 22 | \item{RT, }{a vector storing response times} 23 | 24 | \item{A}{a vector storing response angles.} 25 | 26 | \item{P}{is a parameter vector, c(v1, v2, a, t0, sigma1, sigma2, eta1, eta2). 27 | The sequence is important. v1 is the x-axis mean drift rate. v2 is the 28 | y-axis mean drift rate. sigma1 is the x-axis within-trial drift rate SD. 29 | sigma2 is the y-axix within-trial drift rate SD. a is decision threshold. 30 | sigma1 and sigma2 must be 1 and identical, because this is what has been 31 | thoroughly tested so far. Other values may return unknown results. t0 32 | non-decision time.} 33 | 34 | \item{tmax}{maximum time of the model} 35 | 36 | \item{kmax}{the tuning parameter for Bessel function. Mostly 50.} 37 | 38 | \item{nw}{the number of theta steps (w = 2 * pi / nw)} 39 | 40 | \item{n}{number of observations} 41 | 42 | \item{h, sz}{sz is the number of time steps (h = tmax / sz). h is time step. 43 | Mostly .1 ms.} 44 | 45 | \item{P}{is a parameter vector, c(v, a, z, t0, s). 46 | The sequence must be followed. v is the drift rate 47 | a is decision threshold. t0 is the non-decision time.} 48 | 49 | \item{tmax}{maximum time allowed.} 50 | 51 | \item{kmax}{the tuning parameter for Bessel function. Mostly 50.} 52 | 53 | \item{h, sz}{sz is the number of time steps (h = tmax / sz). h is 54 | the size of one time step. We usually set h = 1e-4. That is .1 ms. 55 | So when tmax is 2 second and each time step is 0.1 ms, sz will be 56 | 2e4 steps.} 57 | } 58 | \value{ 59 | rcircle returns a n x 2 matrix. Each row is an [RT R] trial. 60 | dcircle returns a n vector. 61 | 62 | rcircle returns a n x 2 matrix. Each row is an [RT R] trial. 63 | dcircle returns a n vector. 64 | } 65 | \description{ 66 | Density, random generation for the 2-D diffusion model. 67 | 68 | This function generates one 1-D diffusion process. 69 | } 70 | \details{ 71 | The model has the main parameters, v1, v2, eta1, eta2, a, sigma, and t0. 72 | tmax, kmax, sz and nw are tuning parameters for determining the set. 73 | dcircle300 produces PDF table and others. 74 | 75 | The model has five parameters, v, a, z, t0, and s. tmax and h are 76 | tuning parameters for determining the set. 77 | } 78 | \examples{ 79 | ## TODO examples 80 | 81 | } 82 | -------------------------------------------------------------------------------- /man/dconstant.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/prior.R 3 | \name{dconstant} 4 | \alias{dconstant} 5 | \title{A pseudo constant function to get constant densities} 6 | \usage{ 7 | dconstant(x, p1, p2, lower, upper, lg = FALSE) 8 | } 9 | \arguments{ 10 | \item{x}{quantile} 11 | 12 | \item{p1}{constant value} 13 | 14 | \item{p2}{unused argument} 15 | 16 | \item{lower}{dummy varlable} 17 | 18 | \item{upper}{dummy varlable} 19 | 20 | \item{lg}{log density?} 21 | } 22 | \description{ 23 | Used with constant prior 24 | } 25 | -------------------------------------------------------------------------------- /man/deviance_model.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/analysis.R 3 | \name{deviance_model} 4 | \alias{deviance_model} 5 | \title{Calculate the statistics of model complexity} 6 | \usage{ 7 | deviance_model(object, start, end, ...) 8 | } 9 | \arguments{ 10 | \item{object}{posterior samples} 11 | 12 | \item{start}{start iteration} 13 | 14 | \item{end}{end iteration} 15 | 16 | \item{...}{other plotting arguments passing through dot dot dot.} 17 | } 18 | \description{ 19 | Calculate deviance for a model object for which a 20 | log-likelihood value can be obtained, according to the formula 21 | -2*log-likelihood. 22 | } 23 | \references{ 24 | Spiegelhalter, D. J., Best, N. G., Carlin, B. P., & van der Linde, A. 25 | (2002). Bayesian Measures of Model Complexity and Fit. Journal of the Royal 26 | Statistical Society, Series B (Statistical Methodology), 64(4), 583--639. 27 | doi:10.1111/1467-9868.00353\cr 28 | 29 | Ando, T. (2007). Bayesian predictive information criterion for the 30 | evaluation of hierarchical Bayesian and empirical Bayes models. 31 | Biometrika. 94(2), 443–458. doi:10.1093/biomet/asm017. 32 | } 33 | -------------------------------------------------------------------------------- /man/dgamma_l.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/prior.R 3 | \name{dgamma_l} 4 | \alias{dgamma_l} 5 | \title{A modified dgamma function} 6 | \usage{ 7 | dgamma_l(x, p1, p2, lower, upper, lg = FALSE) 8 | } 9 | \arguments{ 10 | \item{x}{quantile} 11 | 12 | \item{p1}{shape parameter} 13 | 14 | \item{p2}{scale parameter} 15 | 16 | \item{lower}{lower bound} 17 | 18 | \item{upper}{upper bound} 19 | 20 | \item{lg}{log density?} 21 | } 22 | \description{ 23 | A modified dgamma function 24 | } 25 | -------------------------------------------------------------------------------- /man/dlnorm_l.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/prior.R 3 | \name{dlnorm_l} 4 | \alias{dlnorm_l} 5 | \title{A modified dlnorm functions} 6 | \usage{ 7 | dlnorm_l(x, p1, p2, lower, upper, lg = FALSE) 8 | } 9 | \arguments{ 10 | \item{x}{quantile} 11 | 12 | \item{p1}{meanlog parameter} 13 | 14 | \item{p2}{sdlog parameter} 15 | 16 | \item{lower}{lower bound} 17 | 18 | \item{upper}{upper bound} 19 | 20 | \item{lg}{log density?} 21 | } 22 | \description{ 23 | A modified dlnorm functions 24 | } 25 | -------------------------------------------------------------------------------- /man/dmi-class.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/model-class.R 3 | \docType{class} 4 | \name{dmi-class} 5 | \alias{dmi-class} 6 | \title{An S4 class of the Data-model Instance} 7 | \description{ 8 | The class is to represent a data-model instance, which joins a model object 9 | with a data frame. The process of BuildDMI also generates cell.index and 10 | cell.empty. 11 | } 12 | \section{Slots}{ 13 | 14 | \describe{ 15 | \item{\code{data}}{A data frame storing the would-be fit data set} 16 | 17 | \item{\code{model}}{A 3-D model array. Dimension one stores the combinations 18 | of the factor levels and response types, dimension two stores parameters, 19 | and dimension three stores response types.} 20 | 21 | \item{\code{cell.index}}{A ncell-element list. Each element represents one cell. 22 | Each element stores \code{nobs} Boolean indicators, showing whether a 23 | particular observation belongs to this cell.} 24 | 25 | \item{\code{cell.empty}}{A ncell-element logical vector, indicating whether this 26 | cell has no observation.} 27 | }} 28 | 29 | -------------------------------------------------------------------------------- /man/dtnorm.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/RcppExports.R 3 | \name{dtnorm} 4 | \alias{dtnorm} 5 | \alias{rtnorm} 6 | \alias{ptnorm} 7 | \title{Truncated Normal Distribution} 8 | \usage{ 9 | dtnorm(x, p1, p2, lower, upper, lg = FALSE) 10 | 11 | rtnorm(n, p1, p2, lower, upper) 12 | 13 | ptnorm(q, p1, p2, lower, upper, lt = TRUE, lg = FALSE) 14 | } 15 | \arguments{ 16 | \item{x, q}{vector of quantiles;} 17 | 18 | \item{p1}{mean (must be scalar).} 19 | 20 | \item{p2}{standard deviation (must be scalar).} 21 | 22 | \item{lower}{lower truncation value (must be scalar).} 23 | 24 | \item{upper}{upper truncation value (must be scalar).} 25 | 26 | \item{lg}{log probability. If TRUE (default is FALSE) probabilities p are 27 | given as \code{log(p)}.} 28 | 29 | \item{n}{number of observations. n must be a scalar.} 30 | 31 | \item{lt}{lower tail. If TRUE (default) probabilities are \code{P[X <= x]}, 32 | otherwise, \code{P[X > x]}.} 33 | } 34 | \value{ 35 | a numeric vector. 36 | } 37 | \description{ 38 | Random number generation, probability density and cumulative density 39 | functions for truncated normal distribution. 40 | } 41 | \examples{ 42 | ## rtnorm example 43 | dat1 <- rtnorm(1e5, 0, 1, 0, Inf) 44 | hist(dat1, breaks = "fd", freq = FALSE, xlab = "", 45 | main = "Truncated normal distributions") 46 | 47 | ## dtnorm example 48 | x <- seq(-5, 5, length.out = 1e3) 49 | dat1 <- dtnorm(x, 0, 1, -2, 2, 0) 50 | plot(x, dat1, type = "l", lwd = 2, xlab = "", ylab= "Density", 51 | main = "Truncated normal distributions") 52 | 53 | ## ptnorm example 54 | x <- seq(-10, 10, length.out = 1e2) 55 | mean <- 0 56 | sd <- 1 57 | lower <- 0 58 | upper <- 5 59 | dat1 <- ptnorm(x, 0, 1, 0, 5, lg = TRUE) 60 | } 61 | -------------------------------------------------------------------------------- /man/effectiveSize-methods.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/model-class.R 3 | \docType{methods} 4 | \name{effectiveSize} 5 | \alias{effectiveSize} 6 | \alias{effectiveSize,hyper-method} 7 | \alias{effectiveSize,list-method} 8 | \alias{effectiveSize,posterior-method} 9 | \title{Effective Sample Size} 10 | \usage{ 11 | effectiveSize(x, ...) 12 | 13 | \S4method{effectiveSize}{hyper}(x, hyper = TRUE, start = 1, end = NA, 14 | subchain = NA, digits = 2, verbose = FALSE) 15 | 16 | \S4method{effectiveSize}{list}(x, start = 1, end = NA, subchain = NA, 17 | digits = 2, verbose = FALSE) 18 | 19 | \S4method{effectiveSize}{posterior}(x, start = 1, end = NA, 20 | subchain = NA, digits = 2, verbose = FALSE) 21 | } 22 | \arguments{ 23 | \item{x}{posterior samples} 24 | 25 | \item{...}{other additional arguments} 26 | 27 | \item{hyper}{a Boolean switch to calculate phi} 28 | 29 | \item{start}{start from iteration} 30 | 31 | \item{end}{end at which iteraton} 32 | 33 | \item{subchain}{calculate a subset of chains. This must be an integer vector} 34 | 35 | \item{digits}{printing how many digits} 36 | 37 | \item{verbose}{printing more information} 38 | } 39 | \description{ 40 | Posterior sample size adjusted for autocorrelation. The function is based 41 | on the effectiveSize function in \code{coda} package. 42 | } 43 | \details{ 44 | \code{hyper} argument does not work for list class (i.e., posterior 45 | samples from a fixed-effect model fit). 46 | } 47 | \examples{ 48 | #################################40 49 | ## effectiveSize example 50 | #################################40 51 | \dontrun{ 52 | cat("Class:", class(fit), "\\n") 53 | es1 <- effectiveSize(fit, hyper=TRUE, verbose=FALSE) 54 | es1 <- effectiveSize(fit, hyper=TRUE, verbose=TRUE) 55 | 56 | es1 <- effectiveSize(fit, hyper=TRUE, verbose=FALSE, subchain=7:9) 57 | es1 <- effectiveSize(fit, hyper=TRUE, verbose=TRUE, subchain=7:9) 58 | 59 | es1 <- effectiveSize(fit, hyper=FALSE, verbose=FALSE) 60 | es1 <- effectiveSize(fit, hyper=FALSE, verbose=TRUE) 61 | 62 | es1 <- effectiveSize(fit, hyper=FALSE, verbose=FALSE, subchain=4:6) 63 | es1 <- effectiveSize(fit, hyper=FALSE, verbose=TRUE, subchain=4:6) 64 | 65 | cat("Starting a new fixed-effect model fit: \\n") 66 | fit0 <- StartNewsamples(dmi, p.prior, ncore=4) 67 | fit <- run(fit0, ncore=4) 68 | 69 | cat("Class:", class(fit), "\\n") 70 | es1 <- effectiveSize(fit, verbose=FALSE) 71 | es1 <- effectiveSize(fit, verbose=TRUE) 72 | es1 <- effectiveSize(fit, verbose=FALSE, subchain=4:6) 73 | es1 <- effectiveSize(fit, verbose=TRUE, subchain=4:6) 74 | 75 | } 76 | 77 | } 78 | \references{ 79 | \enumerate{ 80 | Plummer, M. Best, N., Cowles, K., Vines, K., Sarkar, D., Bates, D., Almond, R., & Magnusson, A. (2019). R package 'coda' \url{https://cran.r-project.org/web/packages/coda/} 81 | } 82 | } 83 | -------------------------------------------------------------------------------- /man/gelman-methods.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/model-class.R 3 | \docType{methods} 4 | \name{gelman} 5 | \alias{gelman} 6 | \alias{gelman,posterior-method} 7 | \alias{gelman,list-method} 8 | \alias{gelman,hyper-method} 9 | \title{Potential scale reduction factor} 10 | \usage{ 11 | gelman(x, ...) 12 | 13 | \S4method{gelman}{posterior}(x, start = 1, end = NA, conf = 0.95, 14 | multivariate = TRUE, subchain = NA, digits = 2, verbose = FALSE) 15 | 16 | \S4method{gelman}{list}(x, start = 1, end = NA, conf = 0.95, 17 | multivariate = TRUE, subchain = NA, digits = 2, verbose = FALSE) 18 | 19 | \S4method{gelman}{hyper}(x, hyper = TRUE, start = 1, end = NA, 20 | conf = 0.95, multivariate = TRUE, subchain = NA, digits = 2, 21 | verbose = FALSE) 22 | } 23 | \arguments{ 24 | \item{x}{posterior samples} 25 | 26 | \item{...}{other additional arguments} 27 | 28 | \item{start}{start iteration} 29 | 30 | \item{end}{end iteration} 31 | 32 | \item{conf}{confident inteval} 33 | 34 | \item{multivariate}{multivariate Boolean switch} 35 | 36 | \item{subchain}{whether only calculate a subset of chains} 37 | 38 | \item{digits}{print out how many digits} 39 | 40 | \item{verbose}{print more information} 41 | 42 | \item{hyper}{a Boolean switch, indicating posterior samples are from 43 | hierarchical modeling} 44 | } 45 | \description{ 46 | \code{gelman} function calls the function, \code{gelman.diag} in the 47 | \pkg{coda} package to calculates PSRF. 48 | } 49 | \examples{ 50 | \dontrun{ 51 | rhat1 <- gelman(hsam); 52 | rhat2 <- gelman(hsam, end = 51); 53 | rhat3 <- gelman(hsam, conf = .90); 54 | rhat7 <- gelman(hsam, subchain = TRUE); 55 | rhat8 <- gelman(hsam, subchain = 1:4); 56 | rhat9 <- gelman(hsam, subchain = 5:7, digits = 1, verbose = TRUE); 57 | } 58 | } 59 | -------------------------------------------------------------------------------- /man/get_os.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/utils.R 3 | \name{get_os} 4 | \alias{get_os} 5 | \title{Retrieve information of operating system} 6 | \usage{ 7 | get_os() 8 | } 9 | \description{ 10 | A wrapper function to extract system information from \code{Sys.info} 11 | and \code{.Platform} 12 | } 13 | \examples{ 14 | get_os() 15 | ## sysname 16 | ## "linux" 17 | } 18 | -------------------------------------------------------------------------------- /man/ggdmc.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/model.R 3 | \docType{package} 4 | \name{ggdmc} 5 | \alias{ggdmc} 6 | \alias{ggdmc-package} 7 | \title{Cognitive Multilevel Models} 8 | \description{ 9 | \pkg{ggdmc} provides tools for conducting Bayesian inference in cognitive 10 | models. 11 | } 12 | \references{ 13 | Lin, Y.-S. & Strickland, L., (2019). Evidence accumulation models with R: A 14 | practical guide to hierarchical Bayesian methods. 15 | \emph{The Quantitative Method in Psychology}. \cr 16 | 17 | Heathcote, A., Lin, Y.-S., Reynolds, A., Strickland, L., Gretton, M. & 18 | Matzke, D., (2018). Dynamic model of choice. 19 | \emph{Behavior Research Methods}. 20 | https://doi.org/10.3758/s13428-018-1067-y. \cr 21 | 22 | Turner, B. M., & Sederberg P. B. (2012). Approximate Bayesian computation 23 | with differential evolution, \emph{Journal of Mathematical Psychology}, 56, 24 | 375--385. \cr 25 | 26 | Ter Braak (2006). A Markov Chain Monte Carlo version of the genetic 27 | algorithm Differential Evolution: easy Bayesian computing for real 28 | parameter spaces. \emph{Statistics and Computing}, 16, 239-249. 29 | } 30 | \author{ 31 | Yi-Shin Lin \cr 32 | Andrew Heathcote 33 | } 34 | \keyword{package} 35 | -------------------------------------------------------------------------------- /man/hyper-class.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/model-class.R 3 | \docType{class} 4 | \name{hyper-class} 5 | \alias{hyper-class} 6 | \title{An S4 class to represent an object storing posterior samples at the 7 | participant and hyper level} 8 | \description{ 9 | An S4 class to represent an object storing posterior samples at the 10 | participant and hyper level 11 | } 12 | \section{Slots}{ 13 | 14 | \describe{ 15 | \item{\code{phi_loc}}{posterior samples for the location parameters} 16 | 17 | \item{\code{phi_sca}}{posterior samples for the scale parameters} 18 | 19 | \item{\code{summed_log_prior}}{summed log prior likelihoods for phi.} 20 | 21 | \item{\code{log_likelihoods}}{log likelihoods for phi} 22 | 23 | \item{\code{prior_loc}}{a S4 prior object for the location parameters} 24 | 25 | \item{\code{prior_sca}}{a S4 prior object for the scale parameters} 26 | 27 | \item{\code{start}}{the index of starting sample} 28 | 29 | \item{\code{npar}}{number of parameters} 30 | 31 | \item{\code{pnames}}{parameter names} 32 | 33 | \item{\code{nmc}}{number of Monte Carlo samples} 34 | 35 | \item{\code{thin}}{thinning length} 36 | 37 | \item{\code{nchain}}{number of Markov chains} 38 | 39 | \item{\code{individuals}}{a list storing posterior samples for each individual participant} 40 | 41 | \item{\code{snames}}{names of individual participants} 42 | }} 43 | 44 | \seealso{ 45 | \code{\link{posterior-class}} 46 | } 47 | -------------------------------------------------------------------------------- /man/iseffective.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/analysis.R, R/diagnosis.R 3 | \name{iseffective} 4 | \alias{iseffective} 5 | \title{Model checking functions} 6 | \usage{ 7 | iseffective(x, minN, nfun, verbose = FALSE) 8 | 9 | iseffective(x, minN, nfun, verbose = FALSE) 10 | } 11 | \arguments{ 12 | \item{x}{posterior samples} 13 | 14 | \item{minN}{specify the size of minimal effective samples} 15 | 16 | \item{nfun}{specify to use the \code{mean} or \code{median} function to 17 | calculate effective samples} 18 | 19 | \item{verbose}{print more information} 20 | 21 | \item{x}{posterior samples} 22 | 23 | \item{minN}{specify the size of minimal effective samples} 24 | 25 | \item{nfun}{specify to use the \code{mean} or \code{median} function to 26 | calculate effective samples} 27 | 28 | \item{verbose}{print more information} 29 | } 30 | \description{ 31 | The function tests whether we have drawn enough samples. 32 | 33 | The function tests whether we have drawn enough samples. 34 | } 35 | -------------------------------------------------------------------------------- /man/likelihood.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/RcppExports.R 3 | \name{likelihood} 4 | \alias{likelihood} 5 | \title{Calculate log likelihoods} 6 | \usage{ 7 | likelihood(pvector, data, min_lik = 1e-10, precision = 3) 8 | } 9 | \arguments{ 10 | \item{pvector}{a parameter vector} 11 | 12 | \item{data}{data model instance} 13 | 14 | \item{min_lik}{minimal likelihood.} 15 | 16 | \item{precision}{a tuning parameter for the precision of DDM likelihood. 17 | The larger the value is, the more precise the likelihood is and the slower 18 | the computation would be.} 19 | } 20 | \value{ 21 | a vector 22 | } 23 | \description{ 24 | These function calculate log likelihoods. \code{likelihood_rd} implements 25 | the equations in Voss, Rothermund, and Voss (2004). These equations 26 | calculate diffusion decision model (Ratcliff & Mckoon, 2008). Specifically, 27 | this function implements Voss, Rothermund, and Voss's (2004) equations A1 28 | to A4 (page 1217) in C++. 29 | } 30 | \examples{ 31 | model <- BuildModel( 32 | p.map = list(A = "1", B = "1", t0 = "1", mean_v = "M", sd_v = "1", 33 | st0 = "1"), 34 | match.map = list(M = list(s1 = 1, s2 = 2)), 35 | factors = list(S = c("s1", "s2")), 36 | constants = c(st0 = 0, sd_v = 1), 37 | responses = c("r1", "r2"), 38 | type = "norm") 39 | 40 | p.vector <- c(A = .25, B = .35, t0 = .2, mean_v.true = 1, mean_v.false = .25) 41 | dat <- simulate(model, 1e3, ps = p.vector) 42 | dmi <- BuildDMI(dat, model) 43 | den <- likelihood(p.vector, dmi) 44 | 45 | model <- BuildModel( 46 | p.map = list(a = "1", v = "1", z = "1", d = "1", t0 = "1", sv = "1", 47 | sz = "1", st0 = "1"), 48 | constants = c(st0 = 0, d = 0), 49 | match.map = list(M = list(s1 = "r1", s2 = "r2")), 50 | factors = list(S = c("s1", "s2")), 51 | responses = c("r1", "r2"), 52 | type = "rd") 53 | 54 | p.vector <- c(a = 1, v = 1, z = 0.5, sz = 0.25, sv = 0.2, t0 = .15) 55 | dat <- simulate(model, 1e2, ps = p.vector) 56 | dmi <- BuildDMI(dat, model) 57 | den <- likelihood (p.vector, dmi) 58 | 59 | } 60 | \references{ 61 | Voss, A., Rothermund, K., & Voss, J. (2004). Interpreting the 62 | parameters of the diffusion model: An empirical validation. 63 | \emph{Memory & Cognition}, \bold{32(7)}, 1206-1220. \cr\cr 64 | Ratcliff, R. (1978). A theory of memory retrival. \emph{Psychological 65 | Review}, \bold{85}, 238-255. 66 | } 67 | -------------------------------------------------------------------------------- /man/logLik-methods.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/model-class.R 3 | \docType{methods} 4 | \name{logLik} 5 | \alias{logLik} 6 | \alias{logLik,posterior-method} 7 | \alias{logLik,list-method} 8 | \alias{logLik,hyper-method} 9 | \title{Extract Posterior Log-Likelihood} 10 | \usage{ 11 | logLik(object, ...) 12 | 13 | \S4method{logLik}{posterior}(object, start = 1, end = NA) 14 | 15 | \S4method{logLik}{list}(object, start = 1, end = NA) 16 | 17 | \S4method{logLik}{hyper}(object, start = 1, end = NA) 18 | } 19 | \arguments{ 20 | \item{object}{posterior samples} 21 | 22 | \item{...}{other arguments passing through dot dot dot.} 23 | 24 | \item{start}{start from which iteration.} 25 | 26 | \item{end}{end at which iteration. For example, set 27 | \code{start = 101} and \code{end = 1000}, instructs the function to 28 | calculate from 101 to 1000 iteration.} 29 | 30 | \item{hyper}{whether to summarise hyper parameters} 31 | } 32 | \description{ 33 | This function is to extract posterior log-likelihood in a "model" object. 34 | } 35 | -------------------------------------------------------------------------------- /man/model-class.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/model-class.R 3 | \docType{class} 4 | \name{model-class} 5 | \alias{model-class} 6 | \title{An S4 class of the process model.} 7 | \description{ 8 | The class is to represent a process model, e.g., a DDM, a LBA model, a PM 9 | model, or a CDDM. 10 | } 11 | \section{Slots}{ 12 | 13 | \describe{ 14 | \item{\code{model}}{A 3-D model array. Dimension one stores the combinations of the 15 | factor levels and response types (when discrete), dimension two stores 16 | parameters, and dimension three stores response types.} 17 | 18 | \item{\code{all.par}}{all parameters} 19 | 20 | \item{\code{p.vector}}{parameter vector, excluding constant parameters} 21 | 22 | \item{\code{par.names}}{parameter names / labels} 23 | 24 | \item{\code{type}}{model type} 25 | 26 | \item{\code{factors}}{a list of factors and their levels} 27 | 28 | \item{\code{responses}}{response types} 29 | 30 | \item{\code{constants}}{constant parameters} 31 | 32 | \item{\code{posdrift}}{a Boolean switch indicating whether drift rates must be 33 | positive} 34 | 35 | \item{\code{n1.order}}{node 1 ordering. This is only for the LBA model} 36 | 37 | \item{\code{match.cell}}{an indicator matrix storing whether a particular trial 38 | matches a cell} 39 | 40 | \item{\code{match.map}}{a mapping mechanism for calculating whether a trial matches 41 | a positive boundary / accumulator or a negative boundary / accumulator.} 42 | 43 | \item{\code{dimnames}}{dimension names of the model array} 44 | 45 | \item{\code{pnames}}{parameter names} 46 | 47 | \item{\code{npar}}{number of parameters} 48 | }} 49 | 50 | -------------------------------------------------------------------------------- /man/names-methods.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/model-class.R 3 | \docType{methods} 4 | \name{names,prior-method} 5 | \alias{names,prior-method} 6 | \title{The Parameter Names in a Prior Object} 7 | \usage{ 8 | \S4method{names}{prior}(x) 9 | } 10 | \arguments{ 11 | \item{x}{a prior object.} 12 | } 13 | \value{ 14 | a string vector 15 | } 16 | \description{ 17 | Extract parameter names from a prior object. This function extends the 18 | \code{names} funciton in the \code{base} package. 19 | } 20 | -------------------------------------------------------------------------------- /man/plot-methods.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/plotting.R 3 | \docType{methods} 4 | \name{plot} 5 | \alias{plot} 6 | \alias{plot,prior-method} 7 | \alias{plot,posterior-method} 8 | \alias{plot,hyper-method} 9 | \alias{plot,list-method} 10 | \title{ggdmc Plotting Methods} 11 | \usage{ 12 | plot(x, y = NULL, ...) 13 | 14 | \S4method{plot}{prior}(x, y = NULL, ps = NULL, save = FALSE, ...) 15 | 16 | \S4method{plot}{posterior}(x, y = NULL, hyper = FALSE, start = 1, 17 | end = NA, pll = TRUE, save = FALSE, den = FALSE, 18 | subchain = FALSE, nsubchain = 3, chains = NA, ...) 19 | 20 | \S4method{plot}{hyper}(x, y = NULL, hyper = TRUE, start = 1, 21 | end = NA, pll = TRUE, save = FALSE, den = FALSE, 22 | subchain = FALSE, nsubchain = 3, chains = NA, ...) 23 | 24 | \S4method{plot}{list}(x, y = NULL, start = 1, end = NA, pll = TRUE, 25 | save = FALSE, den = FALSE, subchain = FALSE, nsubchain = 3, 26 | chains = NA, ...) 27 | } 28 | \arguments{ 29 | \item{x}{a prior object or posterior samples.} 30 | 31 | \item{y}{NULL} 32 | 33 | \item{...}{Additional argument passing via dot dot dot.} 34 | 35 | \item{ps}{a parameter vector} 36 | 37 | \item{save}{a Boolean switch whether to save plotting data} 38 | 39 | \item{hyper}{a Boolean switch, indicating posterior samples are from 40 | hierarchical modeling} 41 | 42 | \item{start}{start from iteration} 43 | 44 | \item{end}{end at which iteraton} 45 | 46 | \item{pll}{a Boolean switch whether to plot posterior log likelihoods} 47 | 48 | \item{den}{a Boolean switch whether for density plots} 49 | 50 | \item{subchain}{a Boolean switch whether to plot a subset of chains.} 51 | 52 | \item{nsubchain}{number of subchain} 53 | 54 | \item{chains}{indicate the subchains to plot. This must be an integer vector} 55 | } 56 | \description{ 57 | The function plots prior distributions or posterior samples depending on 58 | whether the first argument \code{x} is a prior object or an object 59 | storing posterior samples. 60 | } 61 | \examples{ 62 | p.prior <- BuildPrior( 63 | dists = rep("tnorm", 7), 64 | p1 = c(a = 2, v.f1 = 4, v.f2 = 3, z = 0.5, sv = 1, 65 | sz = 0.3, t0 = 0.3), 66 | p2 = c(a = 0.5, v.f1 = .5, v.f2 = .5, z = 0.1, sv = .3, 67 | sz = 0.1, t0 = 0.05), 68 | lower = c(0,-5, -5, 0, 0, 0, 0), 69 | upper = c(5, 7, 7, 1, 2, 1, 1)) 70 | plot(p.prior) 71 | } 72 | -------------------------------------------------------------------------------- /man/posterior-class.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/model-class.R 3 | \docType{class} 4 | \name{posterior-class} 5 | \alias{posterior-class} 6 | \title{An S4 class to represent an object storing posterior samples at the 7 | participant level. Posterior samples storing both the participant and the 8 | hyper lever are represented by an S4 class hyper} 9 | \description{ 10 | An S4 class to represent an object storing posterior samples at the 11 | participant level. Posterior samples storing both the participant and the 12 | hyper lever are represented by an S4 class hyper 13 | } 14 | \section{Slots}{ 15 | 16 | \describe{ 17 | \item{\code{theta}}{posterior samples for one-participant fit.} 18 | 19 | \item{\code{summed_log_prior}}{summed log prior likelihoods.} 20 | 21 | \item{\code{log_likelihoods}}{log likelihoods} 22 | 23 | \item{\code{dmi}}{a S4 object of data model instance} 24 | 25 | \item{\code{prior}}{a S4 prior object} 26 | 27 | \item{\code{start}}{the index of starting sample} 28 | 29 | \item{\code{npar}}{number of parameters} 30 | 31 | \item{\code{pnames}}{parameter names} 32 | 33 | \item{\code{nmc}}{number of Monte Carlo samples} 34 | 35 | \item{\code{thin}}{thinning length} 36 | 37 | \item{\code{nchain}}{number of Markov chains} 38 | }} 39 | 40 | \seealso{ 41 | \code{\link{hyper-class}} 42 | } 43 | -------------------------------------------------------------------------------- /man/print-methods.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/model-class.R 3 | \docType{methods} 4 | \name{print} 5 | \alias{print} 6 | \alias{print,model-method} 7 | \alias{print,prior-method} 8 | \title{ggdmc Printing Methods} 9 | \usage{ 10 | print(x, ...) 11 | 12 | \S4method{print}{model}(x, ps = NULL, ...) 13 | 14 | \S4method{print}{prior}(x, ...) 15 | } 16 | \arguments{ 17 | \item{x}{a model object.} 18 | 19 | \item{...}{Additional argument passing via dot dot dot.} 20 | 21 | \item{ps}{a parameter vector} 22 | } 23 | \value{ 24 | The original model object, a list of parameter matrices or a prior 25 | matrix 26 | } 27 | \description{ 28 | The function is an extension of the print function in \code{base} pacakge. 29 | It prints a model object set up by \code{BuildModel} and a prior object 30 | set up by \code{BuildPrior}. 31 | } 32 | \details{ 33 | The print method for a prior object merely rearranges a prior object 34 | as a data frame for the inspection convenience. 35 | } 36 | \examples{ 37 | model <- BuildModel( 38 | p.map = list(A = "1", B = "1", t0 = "1", mean_v = "M", 39 | sd_v = "1", st0 = "1"), 40 | match.map = list(M = list(s1 = 1, s2 = 2)), 41 | factors = list(S = c("s1", "s2")), 42 | constants = c(st0 = 0, sd_v = 1), 43 | responses = c("r1", "r2"), 44 | type = "norm") 45 | 46 | p.vector <- c(A = .75, B = 1.25, t0 = .15, mean_v.true = 2.5, 47 | mean_v.false = 1.5) 48 | 49 | print(model) 50 | print(model, ps=p.vector) 51 | 52 | dat <- simulate(model, nsim = 10, ps = p.vector); 53 | dmi <- BuildDMI(dat, model) 54 | p.prior <- BuildPrior( 55 | dists = c("tnorm", "tnorm", "beta", "tnorm", "tnorm"), 56 | p1 = c(A = 1, B = 1, t0 = 1, mean_v.true = 1, mean_v.false = 1), 57 | p2 = c(1, 1, 1, 1, 1), 58 | lower = c(rep(0, 3), rep(NA, 2)), 59 | upper = c(rep(NA, 2), 1, rep(NA, 2))) 60 | 61 | print(p.prior) 62 | 63 | ## A different example printing a prior object 64 | pop.mean <- c(a=1, v.f1=1, v.f2=.2, z=.5, sz=.3, sv.f1=.25, sv.f2=.23, 65 | t0=.3) 66 | pop.scale <- c(a=.2, v.f1=.2, v.f2=.2, z=.1, sz=.05, sv.f1=.05, sv.f2=.05, 67 | t0=.05) 68 | 69 | p.prior <- BuildPrior( 70 | dists = rep("tnorm", 8), 71 | p1 = pop.mean, 72 | p2 = pop.scale, 73 | lower = c(0, -5, -5, 0, 0, 0, 0, 0), 74 | upper = c(2, 5, 5, 1, 2, 2, 1, 1)) 75 | 76 | print(p.prior) 77 | } 78 | -------------------------------------------------------------------------------- /man/prior-class.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/model-class.R 3 | \docType{class} 4 | \name{prior-class} 5 | \alias{prior-class} 6 | \title{An S4 class to represent an object storing prior distributions} 7 | \description{ 8 | An S4 class to represent an object storing prior distributions 9 | } 10 | \section{Slots}{ 11 | 12 | \describe{ 13 | \item{\code{npar}}{the number of parameters} 14 | 15 | \item{\code{pnames}}{the names of parameters} 16 | 17 | \item{\code{priors}}{a list storing the location parameter, scale parameter, upper 18 | bound, lower bound, log indicator (0=FALSE, 1=TRUE), distribution type and 19 | transform information.} 20 | }} 21 | 22 | -------------------------------------------------------------------------------- /man/random.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/random.R 3 | \name{random} 4 | \alias{random} 5 | \title{Random number generation} 6 | \usage{ 7 | random(type, pmat, n, seed = NULL, ...) 8 | } 9 | \arguments{ 10 | \item{type}{a character string of the model type} 11 | 12 | \item{pmat}{a matrix of response x parameter} 13 | 14 | \item{n}{number of observations. This must be an integer.} 15 | 16 | \item{seed}{an integer specifying a random seed} 17 | 18 | \item{...}{other arguments} 19 | } 20 | \description{ 21 | A wrapper function for generating random numbers from different model types, 22 | \code{rd}, \code{norm}, \code{norm_pda}, \code{norm_pda_gpu}, or 23 | \code{cddm}. \code{pmat} is generated usually by \code{TableParameter}. 24 | } 25 | \details{ 26 | Note PM model uses \code{norm} type. 27 | } 28 | \examples{ 29 | model <- BuildModel( 30 | p.map = list(a = "1", v="1", z="1", d="1", sz="1", sv="1", t0="1", st0="1"), 31 | match.map = list(M = list(s1 = "r1", s2 = "r2")), 32 | factors = list(S = c("s1", "s2")), 33 | responses = c("r1","r2"), 34 | constants = c(st0 = 0, d = 0, sv = 0, sz = 0), 35 | type = "rd") 36 | 37 | p.vector <- c(a=1, v=1.5, z=0.6, t0=.15) 38 | 39 | pmat <- TableParameters(p.vector, 1, model, FALSE) 40 | type <- model@type; 41 | res1 <- random(type, pmat, 1) 42 | res2 <- random(type, pmat, 10) 43 | 44 | model <- BuildModel( 45 | p.map = list(A = "1", B = "R", t0 = "1", mean_v = c("D", "M"), 46 | sd_v = "M", st0 = "1"), 47 | match.map = list(M = list(s1 = 1, s2 = 2)), 48 | factors = list(S = c("s1", "s2"), D = c("d1", "d2")), 49 | constants = c(sd_v.false = 1, st0 = 0), 50 | responses = c("r1", "r2"), 51 | type = "norm") 52 | 53 | p.vector <- c(A=.51, B.r1=.69, B.r2=.88, t0=.24, mean_v.d1.true=1.1, 54 | mean_v.d2.true=1.0, mean_v.d1.false=.34, mean_v.d2.false=.02, 55 | sd_v.true=.11) 56 | 57 | pmat <- TableParameters(p.vector, 1, model, FALSE) 58 | type <- model@type; 59 | res1 <- random(type, pmat, 1) 60 | res2 <- random(type, pmat, 10) 61 | } 62 | -------------------------------------------------------------------------------- /man/rlba_norm.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/RcppExports.R 3 | \name{rlba_norm} 4 | \alias{rlba_norm} 5 | \title{Generate Random Deviates of the LBA Distribution} 6 | \usage{ 7 | rlba_norm(n, A, b, mean_v, sd_v, t0, st0, posdrift) 8 | } 9 | \arguments{ 10 | \item{n}{is the numbers of observation.} 11 | 12 | \item{A}{start point upper bound, a vector of a scalar.} 13 | 14 | \item{b}{decision threshold, a vector or a scalar.} 15 | 16 | \item{mean_v}{mean drift rate vector} 17 | 18 | \item{sd_v}{standard deviation of drift rate vector} 19 | 20 | \item{t0}{nondecision time, a vector.} 21 | 22 | \item{st0}{nondecision time variation, a vector.} 23 | 24 | \item{posdrift}{if exclude negative drift rates} 25 | } 26 | \value{ 27 | a n x 2 matrix of RTs (first column) and responses (second column). 28 | } 29 | \description{ 30 | \code{rlba_norm}, only slightly faster than \code{maker}, calls C++ 31 | function directly. 32 | } 33 | -------------------------------------------------------------------------------- /man/rprior-methods.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/model-class.R 3 | \docType{methods} 4 | \name{rprior} 5 | \alias{rprior} 6 | \alias{rprior,prior-method} 7 | \title{Generate Random Numbers} 8 | \usage{ 9 | rprior(x, ...) 10 | 11 | \S4method{rprior}{prior}(x, n = 1) 12 | } 13 | \arguments{ 14 | \item{x}{a prior object.} 15 | 16 | \item{...}{Additional argument passing via dot dot dot.} 17 | 18 | \item{n}{number of observations} 19 | } 20 | \description{ 21 | Random number generation based on a prior object 22 | } 23 | \examples{ 24 | p.prior <- BuildPrior( 25 | dists = c("tnorm", "tnorm", "beta", "tnorm", "beta", "beta"), 26 | p1 = c(a = 1, v = 0, z = 1, sz = 1, sv = 1, t0 = 1), 27 | p2 = c(a = 1, v = 2, z = 1, sz = 1, sv = 1, t0 = 1), 28 | lower = c(0,-5, NA, NA, 0, NA), 29 | upper = c(2, 5, NA, NA, 2, NA)) 30 | 31 | rprior(p.prior, 9) 32 | ## a v z sz sv t0 33 | ## [1,] 0.97413686 0.78446178 0.9975199 -0.5264946 0.5364492 0.55415052 34 | ## [2,] 0.72870190 0.97151662 0.8516604 1.6008591 0.3399731 0.96520848 35 | ## [3,] 1.63153685 1.96586939 0.9260939 0.7041254 0.4138329 0.78367440 36 | ## [4,] 1.55866180 1.43657110 0.6152371 0.1290078 0.2957604 0.23027759 37 | ## [5,] 1.32520281 -0.07328408 0.2051155 2.4040387 0.9663111 0.06127237 38 | ## [6,] 0.49628528 -0.19374770 0.5142829 2.1452972 0.4335482 0.38410626 39 | ## [7,] 0.03655549 0.77223432 0.1739831 1.4431507 0.6257398 0.63228368 40 | ## [8,] 0.71197612 -1.15798082 0.8265523 0.3813370 0.4465184 0.23955415 41 | ## [9,] 0.38049166 3.32132034 0.9888108 0.9684292 0.8437480 0.13502154 42 | 43 | } 44 | -------------------------------------------------------------------------------- /man/rvonmises.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/RcppExports.R 3 | \name{rvonmises} 4 | \alias{rvonmises} 5 | \alias{dvonmises} 6 | \alias{pvonmises} 7 | \title{Generate random deviates from a von Mises distribution} 8 | \usage{ 9 | rvonmises(n, mu, kappa) 10 | 11 | dvonmises(x, mu, kappa) 12 | 13 | pvonmises(q, mu, kappa, tol = 1e-20) 14 | } 15 | \arguments{ 16 | \item{n}{number of observations} 17 | 18 | \item{mu}{mean direction of the distribution. Must be a scalar.} 19 | 20 | \item{kappa}{concentration parameter. A positive value 21 | for the concentration parameter of the distribution. Must be a scalar.} 22 | 23 | \item{x, q}{x and q are the quantiles. These must be one a scalar.} 24 | 25 | \item{tol}{the tolerance imprecision for von Mist distribution function.} 26 | } 27 | \value{ 28 | a column vector 29 | } 30 | \description{ 31 | This function generates random numbers in radian unit from a von Mises 32 | distribution using the location (ie mean) parameter, mu and the 33 | concentration (ie precision) parameter kappa. 34 | } 35 | \details{ 36 | A random number for a circular normal distribution has the form:\cr 37 | \deqn{f(theta; mu, kappa) = 1 / (2*pi*I0(kappa)) * exp(kappa*cos(theta-mu))} 38 | theta is between 0 and 2*pi. 39 | 40 | \code{I0(kappa)} in the normalizing constant is the modified Bessel 41 | function of the first kind and order zero. 42 | } 43 | \examples{ 44 | n <- 1e2 45 | mu <- 0 46 | k <- 10 47 | 48 | \dontrun{ 49 | vm1 <- circular:::RvonmisesRad(n, mu, k) 50 | vm2 <- rvm(n, mu, k) 51 | vm3 <- circular:::conversion.circular(circular:::circular(vm1)) 52 | vm4 <- circular:::conversion.circular(circular:::circular(vm2)) 53 | plot(vm3) 54 | plot(vm4) 55 | } 56 | } 57 | \references{ 58 | \enumerate{ 59 | Ulric Lund, Claudio Agostinelli, et al's (2017). R package 'circular': 60 | Circular Statistics (version 0.4-91). 61 | \url{https://r-forge.r-project.org/projects/circular/} 62 | } 63 | } 64 | -------------------------------------------------------------------------------- /man/simulate-methods.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/model-class.R 3 | \docType{methods} 4 | \name{simulate,model-method} 5 | \alias{simulate,model-method} 6 | \title{Simulate Choice Responses} 7 | \usage{ 8 | \S4method{simulate}{model}(object, nsim = 1, seed = NULL, nsub, 9 | prior = NA, ps = NA) 10 | } 11 | \arguments{ 12 | \item{object}{a model object.} 13 | 14 | \item{nsim}{number of observations. \code{nsim} can be a single number 15 | for a balanced design or a matrix for an unbalanced design, where rows 16 | are participants and columns are design cells. If the matrix has one row 17 | than all participants have the same \code{nsim} in each cell, if it has one 18 | column then all cells have the same \code{nsim}; Otherwise each entry 19 | specifies the \code{nsim} for a particular participant x design cell 20 | combination.} 21 | 22 | \item{seed}{a user specified random seed.} 23 | 24 | \item{nsub}{number of participants} 25 | 26 | \item{prior}{a prior object} 27 | 28 | \item{ps}{a true parameter vector or matrix.} 29 | 30 | \item{...}{additional optional arguments.} 31 | } 32 | \value{ 33 | a data frame 34 | } 35 | \description{ 36 | The function is an extension of the simulate function in \code{stats} 37 | pacakge. It simulates the data from either two-alternative force choice 38 | tasks, multiple-alternative force choice task, or continuous report tasks. 39 | } 40 | \details{ 41 | The function simulates data either for one participant or multiple 42 | participants. The simulation process is based on the model object, entering 43 | via \code{object} argument. For simulating one participant, one must supply 44 | a true parameter vector to the \code{ps} argument. 45 | 46 | For simulating multiple participants, one can enter a matrix or a row 47 | vector as true parameters. Each row is used to generate the data for a 48 | participant. This process is usually dubbed the fixed-effect modelling. 49 | To generate data via the random-effect modelling, one must supply a set of 50 | prior distributions. In this case, \code{ps} argument is unused. Note in 51 | some cases, a random-effect modelling may fail to draw data from the model, 52 | because true parameters are randomly drawn 53 | from prior distributions. This would happen sometimes for example in the 54 | diffusion decision model, because certain parameter combinations are 55 | considered invalid (e.g., t0 < 0, zr > a) for obvious reasons. 56 | 57 | \code{ps} can be a row vector, in which case each participant has one set 58 | of identical parameters. It can also be a matrix with one row per 59 | participant, in which case it must have \code{ns} rows. The true values will 60 | be saved as \code{parameters} attribute in the output. 61 | } 62 | \examples{ 63 | model <- BuildModel( 64 | p.map = list(A = "1", B = "1", t0 = "1", mean_v = "M", sd_v = "1", 65 | st0 = "1"), 66 | match.map = list(M = list(s1 = 1, s2 = 2)), 67 | factors = list(S = c("s1", "s2")), 68 | constants = c(st0 = 0, sd_v = 1), 69 | responses = c("r1", "r2"), 70 | type = "norm") 71 | 72 | p.vector <- c(A = .75, B = 1.25, t0 = .15, mean_v.true = 2.5, 73 | mean_v.false = 1.5) 74 | ntrial <- 100 75 | dat <- simulate(model, nsim = ntrial, ps = p.vector) 76 | } 77 | -------------------------------------------------------------------------------- /man/summary-methods.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/model-class.R 3 | \docType{methods} 4 | \name{summary} 5 | \alias{summary} 6 | \alias{summary,posterior-method} 7 | \alias{summary,list-method} 8 | \alias{summary,hyper-method} 9 | \title{ggdmc Summary Methods} 10 | \usage{ 11 | summary(object, ...) 12 | 13 | \S4method{summary}{posterior}(object, start = 1, end = NA, 14 | prob = c(0.025, 0.25, 0.5, 0.75, 0.975), recovery = FALSE, ps = NA, 15 | verbose = FALSE, digits = max(3, getOption("digits") - 3)) 16 | 17 | \S4method{summary}{list}(object, start = 1, end = NA, prob = c(0.025, 18 | 0.25, 0.5, 0.75, 0.975), recovery = FALSE, ps = NA, 19 | verbose = FALSE, digits = max(3, getOption("digits") - 3)) 20 | 21 | \S4method{summary}{hyper}(object, hyper = TRUE, start = 1, end = NA, 22 | prob = c(0.025, 0.25, 0.5, 0.75, 0.975), recovery = FALSE, ps = NA, 23 | type = 1, verbose = FALSE, digits = max(3, getOption("digits") - 24 | 3)) 25 | } 26 | \arguments{ 27 | \item{object}{an object storing posterior samples.} 28 | 29 | \item{...}{Additional argument passing via dot dot dot.} 30 | 31 | \item{start}{start from which iteration.} 32 | 33 | \item{end}{end at which iteration. For example, set 34 | \code{start = 101} and \code{end = 1000}, instructs the function to 35 | calculate from 101st to 1000th iteration.} 36 | 37 | \item{prob}{a numeric vector, indicating the quantiles to calculate} 38 | 39 | \item{recovery}{a Boolean switch indicating if samples are from a recovery 40 | study.} 41 | 42 | \item{ps}{true parameter values. This is only for recovery studies} 43 | 44 | \item{verbose}{print more information} 45 | 46 | \item{digits}{printing digits} 47 | 48 | \item{hyper}{a Boolean switch to plot hyper parameters} 49 | 50 | \item{type}{calculate type 1 = location or type 2 = scale hyper parameters} 51 | } 52 | \description{ 53 | Summarise posterior samples. Note when recovery = TRUE, the prob vector 54 | will be fixed at the default values. 55 | } 56 | \examples{ 57 | \dontrun{ 58 | model <- BuildModel( 59 | p.map = list(a = "1", v = "F", z = "1", d = "1", sz = "1", sv = "1", 60 | t0 = "1", st0 = "1"), 61 | match.map = list(M = list(s1 = "r1", s2 = "r2")), 62 | factors = list(S = c("s1", "s2"), F = c("f1", "f2")), 63 | constants = c(st0 = 0, d = 0), 64 | responses = c("r1", "r2"), 65 | type = "rd") 66 | npar <- model@npar 67 | 68 | ## Population distribution 69 | pop.mean <- c(a=2, v.f1=4, v.f2=3, z=0.5, sz=0.3, sv=1, t0=0.3) 70 | pop.scale <- c(a=0.5, v.f1=.5, v.f2=.5, z=0.1, sz=0.1, sv=.3, t0=0.05) 71 | pop.prior <- BuildPrior( 72 | dists = rep("tnorm", npar), 73 | p1 = pop.mean, 74 | p2 = pop.scale, 75 | lower = c(0,-5, -5, 0, 0, 0, 0), 76 | upper = c(5, 7, 7, 1, 2, 1, 1)) 77 | 78 | ## Simulate some data 79 | dat <- simulate(model, nsub = 30, nsim = 30, prior = pop.prior) 80 | dmi <- BuildDMI(dat, model) 81 | ps <- attr(dat, "parameters") 82 | 83 | p.prior <- BuildPrior( 84 | dists = rep("tnorm", npar), 85 | p1 = pop.mean, 86 | p2 = pop.scale*5, 87 | lower = c(0,-5, -5, 0, 0, 0, 0), 88 | upper = c(5, 7, 7, 1, 2, 1, 1)) 89 | 90 | mu.prior <- ggdmc::BuildPrior( 91 | dists = rep("tnorm", npar), 92 | p1 = pop.mean, 93 | p2 = pop.scale*5, 94 | lower = c(0,-5, -5, 0, 0, 0, 0), 95 | upper = c(5, 7, 7, 1, 2, 1, 1) 96 | ) 97 | sigma.prior <- BuildPrior( 98 | dists = rep("beta", npar), 99 | p1 = c(a=1, v.f1=1,v.f2 = 1, z=1, sz=1, sv=1, t0=1), 100 | p2 = rep(1, npar), 101 | upper = rep(2, npar)) 102 | 103 | priors <- list(pprior=p.prior, location=mu.prior, scale=sigma.prior) 104 | 105 | ## Sampling 106 | ## Processing time: 394.37 secs. 107 | fit0 <- StartNewsamples(dmi, priors, thin = 2) 108 | fit <- run(fit0) 109 | fit <- run(fit, 1e2, add=TRUE) 110 | 111 | ## By default the type = 1 for location parameters 112 | ## When recovery = TRUE, one must enter the true parameter to ps 113 | est0 <- summary(fit, recovery = TRUE, ps = pop.mean, verbose = TRUE) 114 | ## Explicitly enter type = 1 115 | est0 <- summary(fit, recovery = TRUE, ps = pop.mean, type=1, verbose = TRUE) 116 | est0 <- summary(fit, recovery = TRUE, ps = pop.scale, type=2, verbose = TRUE) 117 | 118 | ## When recovery = FALSE (default), the function return parameter estimates 119 | est0 <- summary(fit, verbose = TRUE, type=1) 120 | est0 <- summary(fit, verbose = TRUE, type=2) 121 | 122 | ## To estimate individual participants, one must enter hyper = FALSE for a 123 | ## hierarchical model fit 124 | est0 <- summary(fit, hyper=FALSE, verbose = TRUE) 125 | } 126 | } 127 | -------------------------------------------------------------------------------- /man/trial_loglik_hier.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/utils.R 3 | \name{trial_loglik_hier} 4 | \alias{trial_loglik_hier} 5 | \title{Extract trial log likelihoods} 6 | \usage{ 7 | trial_loglik_hier(samples, thin = 1, verbose = FALSE) 8 | } 9 | \arguments{ 10 | \item{samples}{posterior samples} 11 | 12 | \item{thin}{thinnng length} 13 | 14 | \item{verbose}{whether print information} 15 | } 16 | \description{ 17 | This function simply run trial_loglik to loop through one subject after 18 | another to extracts trial_log_likes from a list of subject fits and 19 | concatanates the result into an array. 20 | } 21 | -------------------------------------------------------------------------------- /man/unstick_one.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/analysis.R, R/diagnosis.R 3 | \name{unstick_one} 4 | \alias{unstick_one} 5 | \title{Unstick posterios samples (One subject)} 6 | \usage{ 7 | unstick_one(x, bad) 8 | 9 | unstick_one(x, bad) 10 | } 11 | \arguments{ 12 | \item{x}{posterior samples} 13 | 14 | \item{bad}{a numeric vector, indicating which chains to remove} 15 | 16 | \item{x}{posterior samples} 17 | 18 | \item{bad}{a numeric vector, indicating which chains to remove} 19 | } 20 | \description{ 21 | Unstick posterios samples (One subject) 22 | 23 | Unstick posterios samples (One subject) 24 | } 25 | -------------------------------------------------------------------------------- /src/Density.cpp: -------------------------------------------------------------------------------- 1 | // Copyright (C) <2019> 2 | // 3 | // This program is free software; you can redistribute it and/or modify 4 | // it under the terms of the GNU General Public License as published by 5 | // the Free Software Foundation; either version 2 of the License, or 6 | // (at your option) any later version. 7 | // 8 | // This program is distributed in the hope that it will be useful, 9 | // but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | // GNU General Public License for more details. 12 | // 13 | // You should have received a copy of the GNU General Public License along 14 | // with this program; if not, write to the Free Software Foundation, Inc., 15 | // 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. 16 | #include 17 | 18 | using namespace Rcpp; 19 | 20 | //' Calculate likelihoods 21 | //' 22 | //' These function calculate likelihoods. \code{likelihood_rd} implements 23 | //' the equations in Voss, Rothermund, and Voss (2004). These equations 24 | //' calculate diffusion decision model (Ratcliff & Mckoon, 2008). Specifically, 25 | //' this function implements Voss, Rothermund, and Voss's (2004) equations A1 26 | //' to A4 (page 1217) in C++. 27 | //' 28 | //' @param pvector a parameter vector 29 | //' @param data data model instance 30 | //' @param min_lik minimal likelihood. 31 | //' @param precision a tuning parameter for the precision of DDM likelihood. 32 | //' The larger the value is, the more precise the likelihood is and the slower 33 | //' the computation would be. 34 | //' @return a vector 35 | //' @references Voss, A., Rothermund, K., & Voss, J. (2004). Interpreting the 36 | //' parameters of the diffusion model: An empirical validation. 37 | //' \emph{Memory & Cognition}, \bold{32(7)}, 1206-1220. \cr\cr 38 | //' Ratcliff, R. (1978). A theory of memory retrival. \emph{Psychological 39 | //' Review}, \bold{85}, 238-255. 40 | //' 41 | //' @examples 42 | //' model <- BuildModel( 43 | //' p.map = list(A = "1", B = "1", t0 = "1", mean_v = "M", sd_v = "1", 44 | //' st0 = "1"), 45 | //' match.map = list(M = list(s1 = 1, s2 = 2)), 46 | //' factors = list(S = c("s1", "s2")), 47 | //' constants = c(st0 = 0, sd_v = 1), 48 | //' responses = c("r1", "r2"), 49 | //' type = "norm") 50 | //' 51 | //' p.vector <- c(A = .25, B = .35, t0 = .2, mean_v.true = 1, mean_v.false = .25) 52 | //' dat <- simulate(model, 1e3, ps = p.vector) 53 | //' dmi <- BuildDMI(dat, model) 54 | //' den <- likelihood(p.vector, dmi) 55 | //' 56 | //' model <- BuildModel( 57 | //' p.map = list(a = "1", v = "1", z = "1", d = "1", t0 = "1", sv = "1", 58 | //' sz = "1", st0 = "1"), 59 | //' constants = c(st0 = 0, d = 0), 60 | //' match.map = list(M = list(s1 = "r1", s2 = "r2")), 61 | //' factors = list(S = c("s1", "s2")), 62 | //' responses = c("r1", "r2"), 63 | //' type = "rd") 64 | //' 65 | //' p.vector <- c(a = 1, v = 1, z = 0.5, sz = 0.25, sv = 0.2, t0 = .15) 66 | //' dat <- simulate(model, 1e2, ps = p.vector) 67 | //' dmi <- BuildDMI(dat, model) 68 | //' den <- likelihood (p.vector, dmi) 69 | //' 70 | //' @export 71 | // [[Rcpp::export]] 72 | std::vector likelihood (arma::vec pvector, S4 data, 73 | double min_lik=1e-10, double precision=3.0) 74 | // used only by R 75 | { 76 | Design * obj0 = new Design(data); 77 | Likelihood * obj1 = new Likelihood(data, obj0, precision); 78 | arma::vec tmp = obj1->likelihood(pvector); 79 | 80 | std::vector out(obj0->m_nRT); 81 | for(size_t i=0; im_nRT; i++) 82 | { 83 | out[i] = R::fmax2(tmp[i], min_lik); 84 | } 85 | 86 | delete obj1; 87 | return out; 88 | } 89 | 90 | // [[Rcpp::export]] 91 | arma::mat p_df(arma::vec pvector, std::string cell, std::string mtype, 92 | 93 | std::vector pnames, 94 | std::vector parnames, 95 | std::vector dim0, 96 | std::vector dim1, 97 | std::vector dim2, 98 | 99 | std::vector allpar, 100 | arma::ucube model, 101 | 102 | arma::uvec isr1, 103 | arma::umat n1idx, 104 | bool n1order) 105 | // Used only in random.R 106 | { 107 | Design * obj0 = new Design(pnames, parnames, dim0, dim1, dim2, 108 | allpar, model); 109 | Likelihood * obj1 = new Likelihood(mtype, isr1, n1idx, n1order, obj0); 110 | 111 | arma::mat pmat = obj1->get_pmat(pvector, cell); // 112 | 113 | delete obj1; // obj0 is freed in obj1; 114 | return pmat; 115 | 116 | } 117 | 118 | // [[Rcpp::export]] 119 | arma::vec ac_(arma::vec x, unsigned int nlag) { 120 | 121 | unsigned int n = x.n_elem; 122 | unsigned int nm1 = n - 1; 123 | arma::vec out(nlag); 124 | arma::mat tmp0 = arma::cor(x, x); 125 | out(0) = arma::as_scalar(tmp0); 126 | arma::vec tmp1, tmp2; 127 | for (size_t i = 1; i < nlag; i++) 128 | { 129 | tmp1 = arma::shift(x, (int)i); 130 | tmp0 = arma::cor(x.rows(i, nm1), tmp1.rows(i, nm1)); // pairwise.complete.obs 131 | out(i) = arma::as_scalar(tmp0); 132 | } 133 | return out; 134 | } 135 | 136 | // [[Rcpp::export]] 137 | arma::cube trial_loglik(S4 samples, unsigned int thin_pointwise) 138 | { 139 | S4 dmi = samples.slot("dmi"); 140 | unsigned int nobs, n, j; 141 | arma::vec tmp, nmc_thin; 142 | 143 | unsigned int nchain = samples.slot("nchain"); 144 | unsigned int pnmc = samples.slot("nmc"); 145 | arma::cube theta = samples.slot("theta"); // npar x nchain x nmc 146 | Design * d0 = new Design (dmi); 147 | nobs = d0->m_nRT;; 148 | nmc_thin = arma::regspace(thin_pointwise, thin_pointwise, pnmc) - 1; 149 | n = nmc_thin.n_elem; 150 | 151 | arma::cube out(nobs, nchain, n); out.fill(R_NegInf); 152 | 153 | Rcout << "Processing chains: "; 154 | for (size_t k=0; k ds(nsub); 187 | // std::vector ls(nsub); 188 | // 189 | // for (size_t i = 0; i < nsub; i++) 190 | // { 191 | // List subjecti = samples_in[i]; 192 | // List datai = subjecti["data"]; // Must cast out first 193 | // 194 | // ds[i] = new Design (datai); 195 | // ls[i] = new Likelihood (datai, ds[i], 3.0); // diff. RTs, Rs for diff. subjs 196 | // } 197 | // 198 | // 199 | // Rcout << "Start sampling: "; 200 | // 201 | // 202 | // } 203 | -------------------------------------------------------------------------------- /src/LBA.cpp: -------------------------------------------------------------------------------- 1 | // Copyright (C) <2019> 2 | // 3 | // This program is free software; you can redistribute it and/or modify 4 | // it under the terms of the GNU General Public License as published by 5 | // the Free Software Foundation; either version 2 of the License, or 6 | // (at your option) any later version. 7 | // 8 | // This program is distributed in the hope that it will be useful, 9 | // but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | // GNU General Public License for more details. 12 | // 13 | // You should have received a copy of the GNU General Public License along 14 | // with this program; if not, write to the Free Software Foundation, Inc., 15 | // 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. 16 | #include 17 | 18 | using namespace Rcpp; 19 | 20 | arma::vec fptpdf(arma::vec rt, double A, double b, double mean_v, double sd_v, 21 | double t0, double st0, bool posdrift) 22 | { 23 | lba * obj = new lba(A, b, mean_v, sd_v, t0, st0, posdrift, rt); 24 | arma::vec out(obj->m_nrt); 25 | 26 | if(!obj->ValidateParams(false)) 27 | { 28 | out.fill(1e-10); 29 | } 30 | else 31 | { 32 | out = obj->d(); 33 | } 34 | 35 | delete obj; 36 | return out; 37 | } 38 | 39 | arma::vec fptcdf(arma::vec rt, double A, double b, double mean_v, double sd_v, 40 | double t0, double st0, bool posdrift) 41 | { 42 | lba * obj = new lba(A, b, mean_v, sd_v, t0, st0, posdrift, rt); 43 | arma::vec out(obj->m_nrt); 44 | 45 | if(!obj->ValidateParams(false)) 46 | { 47 | out.fill(1e-10); 48 | } 49 | else 50 | { 51 | out = obj->p(); 52 | } 53 | 54 | delete obj; 55 | return out; 56 | } 57 | 58 | arma::vec n1PDFfixedt0(arma::vec rt, arma::vec A, arma::vec b, arma::vec mean_v, 59 | arma::vec sd_v, arma::vec t0, arma::vec st0, 60 | bool posdrift) { 61 | 62 | unsigned int nmean_v = mean_v.n_elem; // Number of accumulators/responses. 63 | unsigned int n = rt.n_elem; // Number of trials 64 | unsigned int nsd_v = sd_v.n_elem; // Check for matrix operations 65 | unsigned int nA = A.n_elem; 66 | unsigned int nb = b.n_elem; 67 | unsigned int nt0 = t0.n_elem; 68 | unsigned int nst0 = st0.n_elem; // reduntant 69 | 70 | if (nsd_v == 1) sd_v = arma::repmat(sd_v, nmean_v, 1); 71 | if (nA == 1) A = arma::repmat(A, nmean_v, 1); 72 | if (nb == 1) b = arma::repmat(b, nmean_v, 1); 73 | if (nt0 == 1) t0 = arma::repmat(t0, nmean_v, 1); 74 | if (nst0 == 1) st0 = arma::repmat(st0, nmean_v, 1); 75 | 76 | arma::vec onevec = arma::ones(n); 77 | arma::vec node1den = fptpdf(rt, A[0], b[0], mean_v[0], sd_v[0], t0[0], st0[0], 78 | posdrift); 79 | 80 | if (nmean_v > 1) 81 | { 82 | for (size_t i = 1; i < nmean_v; i++) 83 | { 84 | node1den = node1den % (onevec - fptcdf(rt, A[i], b[i], mean_v[i], 85 | sd_v[i], t0[i], st0[i], posdrift)); 86 | } 87 | } 88 | 89 | return node1den; 90 | } 91 | 92 | //' Generate Random Deviates of the LBA Distribution 93 | //' 94 | //' \code{rlba_norm}, only slightly faster than \code{maker}, calls C++ 95 | //' function directly. 96 | //' 97 | //' @param n is the numbers of observation. 98 | //' @param A start point upper bound, a vector of a scalar. 99 | //' @param b decision threshold, a vector or a scalar. 100 | //' @param mean_v mean drift rate vector 101 | //' @param sd_v standard deviation of drift rate vector 102 | //' @param t0 nondecision time, a vector. 103 | //' @param st0 nondecision time variation, a vector. 104 | //' @param posdrift if exclude negative drift rates 105 | //' 106 | //' @return a n x 2 matrix of RTs (first column) and responses (second column). 107 | //' @export 108 | // [[Rcpp::export]] 109 | arma::mat rlba_norm(unsigned int n, arma::vec A, arma::vec b, 110 | arma::vec mean_v, arma::vec sd_v, arma::vec t0, 111 | arma::vec st0, bool posdrift) { 112 | unsigned int nmean_v = mean_v.size(); 113 | unsigned int nA = A.n_elem; 114 | unsigned int nb = b.n_elem; 115 | unsigned int nt0 = t0.n_elem; 116 | unsigned int nst0= st0.n_elem; 117 | 118 | if (nA == 1) A = arma::repmat(A, nmean_v, 1); 119 | if (nb == 1) b = arma::repmat(b, nmean_v, 1); 120 | if (nt0 == 1) t0 = arma::repmat(t0, nmean_v, 1); 121 | if (sd_v.n_elem == 1) sd_v = arma::repmat(sd_v, nmean_v, 1); 122 | if (nst0 == 1) st0 = arma::repmat(st0, nmean_v, 1); 123 | 124 | double * mv = new double[nmean_v]; 125 | double * sdv = new double[nmean_v]; 126 | 127 | double * A_vec = new double[nmean_v]; 128 | double * b_vec = new double[nmean_v]; 129 | double * t0_vec = new double[nmean_v]; 130 | double * st0_vec = new double[nmean_v]; 131 | for(size_t i=0; ir_vec(n, out); 147 | 148 | delete obj; 149 | delete [] sdv; 150 | delete [] mv; 151 | 152 | delete [] A_vec; 153 | delete [] b_vec; 154 | delete [] t0_vec; 155 | delete [] st0_vec; 156 | 157 | return out; 158 | } 159 | 160 | 161 | // double test_sumloglike(arma::vec pvec, List data) 162 | // { 163 | // Design * d0 = new Design (data); 164 | // Likelihood * l0 = new Likelihood (data, d0); 165 | // 166 | // double out = l0->sumloglike(pvec); 167 | // delete l0; 168 | // return out; 169 | // } 170 | -------------------------------------------------------------------------------- /src/Makevars.in: -------------------------------------------------------------------------------- 1 | ## -*- mode: makefile; -*- 2 | 3 | PKG_CXXFLAGS = -I../inst/include @OPENMP_FLAG@ 4 | PKG_LIBS= @OPENMP_FLAG@ $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS) -L$(LIB_GSL)/lib/x64 -lgsl -lgslcblas 5 | 6 | ## PKG_CXXFLAGS = -I../inst/include 7 | ## PKG_LIBS= $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS) -L$(LIB_GSL)/lib/x64 -lgsl -lgslcblas 8 | 9 | ## And with R 3.4.0, and RcppArmadillo 0.7.960.*, we turn C++11 on as OpenMP 10 | ## support within Armadillo prefers / requires it 11 | CXX_STD = CXX11 12 | ## CXX_STD = CXX98 13 | -------------------------------------------------------------------------------- /src/Makevars.win: -------------------------------------------------------------------------------- 1 | ## -*- mode: makefile; -*- 2 | 3 | ## Not GSL in Windows 4 | PKG_CXXFLAGS = -I../inst/include -I. $(SHLIB_OPENMP_CXXFLAGS) 5 | PKG_LIBS = $(SHLIB_OPENMP_CXXFLAGS) $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS) 6 | 7 | ## And with R 3.4.0, and RcppArmadillo 0.7.960.*, we turn C++11 on as OpenMP 8 | ## support within Armadillo prefers / requires it 9 | CXX_STD = CXX11 10 | 11 | 12 | -------------------------------------------------------------------------------- /src/Parameters.cpp: -------------------------------------------------------------------------------- 1 | /* - Parameters class is not from fast-dm. It is from the src folder in 2 | * rtdists 0.9-0 by M. Gretton. I extended it for FCalculator_new. 3 | * - density.c - compute the densities g- and g+ of the first exit time (based 4 | * on fast-dm) 5 | */ 6 | #include 7 | 8 | /*--------------------------------------------------------------------------- 9 | Original public functions in Parameters.h. The version with std::vector is 10 | an overloaded constructor. Show function is to debug. 11 | ---------------------------------------------------------------------------*/ 12 | Parameters::Parameters(std::vector params, double precision, int boundary) 13 | { 14 | // Used in prd 15 | s = params[PARAM_s]; 16 | d = params[PARAM_d]; 17 | szr = params[PARAM_szr]; 18 | st0 = params[PARAM_st0]; 19 | 20 | a = (s == 1) ? params[PARAM_a] : (params[PARAM_a] / params[PARAM_s]); 21 | sv = (s == 1) ? params[PARAM_sv] : (params[PARAM_sv] / params[PARAM_s]); 22 | zr = (boundary == BOUNDARY_UPPER) ? 1-params[PARAM_zr] : params[PARAM_zr]; 23 | 24 | t0 = (st0 == 0) ? params[PARAM_t0] : params[PARAM_t0] + .5*params[PARAM_st0]; 25 | 26 | 27 | if (s==1 && boundary == BOUNDARY_UPPER) 28 | { 29 | v = -params[PARAM_v]; 30 | } 31 | else if (s!=1 && boundary == BOUNDARY_UPPER) 32 | { 33 | v = -params[PARAM_v] / params[PARAM_s]; 34 | } 35 | else if (s==1 && boundary == BOUNDARY_LOWER) 36 | { 37 | v = params[PARAM_v]; 38 | } else 39 | { 40 | v = params[PARAM_v] / params[PARAM_s]; 41 | } 42 | 43 | SetPrecision (precision); 44 | } 45 | 46 | Parameters::Parameters(std::vector params, double precision) 47 | { 48 | // Used in F_calculator 49 | s = params[PARAM_s]; 50 | d = params[PARAM_d]; 51 | zr = params[PARAM_zr]; 52 | szr = params[PARAM_szr]; 53 | st0 = params[PARAM_st0]; 54 | 55 | a = (s == 1) ? params[PARAM_a] : (params[PARAM_a] / params[PARAM_s]); 56 | v = (s == 1) ? params[PARAM_v] : (params[PARAM_v] / params[PARAM_s]); 57 | sv = (s == 1) ? params[PARAM_sv] : (params[PARAM_sv] / params[PARAM_s]); 58 | 59 | // MG's recalc_t0 [MG 20150616] 60 | // In line with LBA, adjust t0 to be the lower bound of the non-decision time 61 | // distribution rather than the average 62 | t0 = (st0 == 0) ? params[PARAM_t0] : params[PARAM_t0] + .5*params[PARAM_st0]; 63 | 64 | SetPrecision (precision); 65 | } 66 | 67 | Parameters::Parameters(double * params, double precision) 68 | { 69 | a = params[PARAM_a]; 70 | v = params[PARAM_v]; 71 | zr = params[PARAM_zr]; 72 | d = params[PARAM_d]; 73 | szr = params[PARAM_szr]; 74 | sv = params[PARAM_sv]; 75 | t0 = params[PARAM_t0]; 76 | st0 = params[PARAM_st0]; 77 | s = params[PARAM_s]; 78 | 79 | SetPrecision (precision); 80 | } 81 | 82 | bool Parameters::ValidateParams (bool print) 83 | { 84 | using namespace Rcpp; 85 | bool valid = true; 86 | 87 | if (a <= 0) { valid = false; if (print) Rcout << "error: invalid parameter a = " << a << std::endl; } 88 | if (szr < 0 || szr > 1) { valid = false; if (print) Rcout << "error: invalid parameter szr = " << szr << std::endl; } 89 | if (st0 < 0) { valid = false; if (print) Rcout << "error: invalid parameter st0 = " << st0 << std::endl; } 90 | if (sv < 0) { valid = false; if (print) Rcout << "error: invalid parameter sv = " << sv << std::endl; } 91 | if (t0 - std::fabs(0.5*d) - 0.5*st0 < 0) { valid = false; if (print) Rcout << "error: invalid parameter combination t0 = " << t0 << ", d = " << d << ", st0 =" << st0 << std::endl; } 92 | if (zr - 0.5*szr <= 0) { valid = false; if (print) Rcout << "error: invalid parameter combination zr = " << zr << ", szr = " << szr << std::endl;} 93 | if (zr + 0.5*szr >= 1) { valid = false; if (print) Rcout << "error: invalid parameter combination zr = " << zr << ", szr = " << szr << std::endl;} 94 | if (s <= 0) { valid = false; if (print) Rcout << "error: invalid diffusion constant " << s; } 95 | return valid; 96 | } 97 | 98 | void Parameters::Show(std::string str) const 99 | { 100 | Rcout << str << ":\n"; 101 | Rcout << "[a\tv\tt0\td] = " << "[" << a << "\t" << v << "\t" << t0 102 | << "\t" << d << "]" << std::endl; 103 | Rcout << "[szr\tsv\tst0\tzr] = " << "[" << szr << "\t" << sv << "\t" 104 | << st0 << "\t" << zr << "]" << std::endl; 105 | } 106 | 107 | /*--------------------------------------------------------------------------- 108 | static functions were from Density.h (rtdists) & density.c (fast-dm). 109 | * ------------------------------------------------------------------------ 110 | * A verbatim copy of Jochen Voss & Andreas Voss's copyright. 111 | * ------------------------------------------------------------------------ 112 | * Copyright (C) 2012 Andreas Voss, Jochen Voss. 113 | * 114 | * This program is free software; you can redistribute it and/or 115 | * modify it under the terms of the GNU General Public License as 116 | * published by the Free Software Foundation; either version 2 of the 117 | * License, or (at your option) any later version. 118 | * 119 | * This program is distributed in the hope that it will be useful, but 120 | * WITHOUT ANY WARRANTY; without even the implied warranty of 121 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 122 | * General Public License for more details. 123 | * 124 | * You should have received a copy of the GNU General Public License 125 | * along with this program; if not, write to the Free Software 126 | * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 127 | * 02110-1301 USA. 128 | ---------------------------------------------------------------------------*/ 129 | static double g_minus_small_time (double t, double zr, int N) 130 | // A3 Formula on p1217; Appendix Mathematical Details V, R, & V (2004) 131 | // See also Feller (1971, p359 & p370 Problem 22); Note zr = z/a. v = 0 & a = 1 132 | { 133 | if (t <= 0) Rcpp::stop("t must be greater than 0."); 134 | 135 | int i; // i must be int not unsigned int 136 | double d, s = 0; 137 | for (i = -N/2; i <= N/2; i++) // i = na 138 | { 139 | d = 2*i + zr; 140 | s += std::exp(-d*d / (2*t)) * d; 141 | } 142 | 143 | return s / std::sqrt(M_2PI*t*t*t); 144 | } 145 | 146 | static double g_minus_large_time (double t, double zr, int N) 147 | // A4, p1217 148 | { 149 | int i; 150 | double d, s = 0; 151 | for (i = 1; i <= N; i++) 152 | { 153 | d = i * M_PI; 154 | s += std::exp(-0.5*d*d*t) * std::sin(d*zr) * i; 155 | } 156 | return s * M_PI; 157 | } 158 | 159 | static double g_minus_no_var (double t, double a, double zr, double v) 160 | // Depending on g_minus_small_time and g_minus_large_time 161 | // Determine the refinement for the infinite serie 162 | { 163 | int N_small, N_large; 164 | double simple, factor, eps, ta = t/(a*a); 165 | 166 | factor = std::exp(-a*zr*v - 0.5*(v*v)*t) / (a*a); // Front term in A3 167 | if ( !R_FINITE(factor) ) { return 0; } 168 | eps = EPSILON / factor; 169 | 170 | N_large = (int)std::ceil(1. / (M_PI*std::sqrt(t))); 171 | 172 | if (M_PI*ta*eps < 1.) { // std::max as imax 173 | N_large = R::imax2(N_large, 174 | (int)std::ceil(std::sqrt(-2.0*std::log(M_PI*ta*eps) / ((M_PI*M_PI)*ta)))); 175 | } 176 | 177 | if (2.*std::sqrt(M_2PI*ta)*eps < 1.) { // std::max as fmax 178 | N_small = (int)std::ceil(R::fmax2(std::sqrt(ta) + 1, 179 | 2. + std::sqrt(-2.0*ta*log(2.0*eps*std::sqrt(M_2PI*ta))))); 180 | } else { 181 | N_small = 2; 182 | } 183 | 184 | if (N_small < N_large) { 185 | simple = g_minus_small_time(ta, zr, N_small); // Note it's ta not t 186 | } else { 187 | simple = g_minus_large_time(ta, zr, N_large); 188 | } 189 | return factor * simple; 190 | } 191 | 192 | static double integral_v_g_minus (double t, double zr, Parameters *params) 193 | // integrate over a range of v based on a formula; ie sv != 0 194 | { 195 | int N_small, N_large; 196 | double a=params->a, v=params->v, sv=params->sv; 197 | double simple, factor, eps, ta = t/(a*a); 198 | 199 | // The factor is where difference is 200 | // Here uses a*zr to get z (zr = z/a). Must not change the multiplication 201 | // sequence of a*zr*a*zr*sv*sv; otherwise it will produce rounding errors 202 | factor = 1 / (a*a * std::sqrt(t * sv*sv + 1)) * 203 | std::exp(-0.5 * (v*v*t + 2*v*a*zr - a*zr*a*zr*sv*sv) / (t*sv*sv+1)); 204 | 205 | // Early exit 1 206 | if (!R_FINITE(factor)) { return 0; } 207 | eps = EPSILON / factor; 208 | 209 | // Early exit 2 210 | if (sv == 0) { return g_minus_no_var(t, a, zr, v); } 211 | 212 | // Below is identical as in g_minus_no_var 213 | N_large = (int)std::ceil(1./(M_PI*std::sqrt(t))); 214 | if (M_PI*ta*eps < 1.) { 215 | N_large = R::imax2(N_large, 216 | (int)std::ceil(sqrt(-2.*std::log(M_PI*ta*eps) / (M_PI*M_PI*ta)))); 217 | } 218 | 219 | if (2.*std::sqrt(M_2PI*ta)*eps < 1.) { 220 | N_small = (int)std::ceil(R::imax2(sqrt(ta) + 1., 221 | 2. + sqrt(-2.*ta*log(2.*eps*std::sqrt(M_2PI*ta))))); 222 | } else { 223 | N_small = 2; 224 | } 225 | 226 | if (N_small < N_large) { 227 | simple = g_minus_small_time(ta, zr, N_small); 228 | } else { 229 | simple = g_minus_large_time(ta, zr, N_large); 230 | } 231 | return factor * simple; 232 | } 233 | 234 | static double integrate_v_over_zr (Parameters *params, double a, double b, 235 | double t, double step_width) 236 | // used by integral_z_g_minus 237 | { 238 | double x, s=0, width=b-a; 239 | int N = R::imax2(4, (int) (width / step_width)); // usually less than 10 240 | double step=width/N; 241 | for(x = a+0.5*step; x < b; x += step) 242 | { 243 | s += step * integral_v_g_minus (t, x, params); // width * height = area 244 | } 245 | return s; 246 | } 247 | 248 | static double integral_z_g_minus (double t, Parameters *params) 249 | // integral over a uniform, fixed range of zr, depending on 250 | // integrate_v_over_zr and integral_v_g_minus. 251 | { 252 | double out; 253 | if (t <= 0) { return 0; }; 254 | 255 | if (params->szr < params->TUNE_SZ_EPSILON) { 256 | out = integral_v_g_minus(t, params->zr, params); 257 | } else { 258 | out = integrate_v_over_zr( 259 | params, 260 | params->zr - .5*params->szr, 261 | params->zr + .5*params->szr, 262 | t, params->TUNE_INT_Z) / params->szr; 263 | } 264 | return out; 265 | } 266 | 267 | static double integrate_z_over_t (Parameters *params, double a, double b, 268 | double step_width) 269 | { 270 | double x, s=0, width=b-a; 271 | int N = R::imax2(4, (int) (width / step_width)); 272 | double step=width/N; 273 | for(x = a+0.5*step; x < b; x += step) 274 | { 275 | s += step * integral_z_g_minus(x, params); 276 | } 277 | return s; 278 | } 279 | 280 | static double integral_t0_g_minus (double t, Parameters *params) 281 | // integral over a uniform, fixed range of t, depending on integrate_z_over_t, 282 | // and integral_z_g_minus, which depends on integrate_v_over_zr and 283 | // integral_v_g_minus. 284 | { 285 | double out; 286 | if (params->st0 < params->TUNE_ST0_EPSILON) { 287 | out = integral_z_g_minus(t, params); 288 | } else { 289 | out = integrate_z_over_t( 290 | params, 291 | t - .5*params->st0, 292 | t + .5*params->st0, 293 | params->TUNE_INT_T0) / params->st0; 294 | } 295 | return out; 296 | } 297 | 298 | /*--------------------------------------------------------------------------- 299 | Non-static functions decleared in Parameters.hpp. Other functions can call 300 | them. 301 | ---------------------------------------------------------------------------*/ 302 | double g_minus(double t, Parameters *params) 303 | { 304 | return integral_t0_g_minus (t - params->t0 - 0.5*params->d, params); 305 | } 306 | 307 | double g_plus(double t, Parameters *params) 308 | { 309 | Parameters params_(*params); 310 | params_.zr = 1 - params->zr; 311 | params_.v = - params->v; 312 | return integral_t0_g_minus (t - params_.t0 + 0.5*params_.d, ¶ms_); 313 | } 314 | -------------------------------------------------------------------------------- /src/Prior.cpp: -------------------------------------------------------------------------------- 1 | // Copyright (C) <2019> 2 | // 3 | // This program is free software; you can redistribute it and/or modify 4 | // it under the terms of the GNU General Public License as published by 5 | // the Free Software Foundation; either version 2 of the License, or 6 | // (at your option) any later version. 7 | // 8 | // This program is distributed in the hope that it will be useful, 9 | // but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | // GNU General Public License for more details. 12 | // 13 | // You should have received a copy of the GNU General Public License along 14 | // with this program; if not, write to the Free Software Foundation, Inc., 15 | // 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. 16 | #include 17 | // #include 18 | 19 | using namespace Rcpp; 20 | 21 | void set_seed(unsigned int seed) { 22 | Environment base_env("package:base"); 23 | Function set_seed_r = base_env["set.seed"]; 24 | set_seed_r(seed); 25 | } 26 | 27 | Prior::Prior (List & pprior) 28 | { 29 | using namespace arma; 30 | 31 | std::vector pnames = pprior.attr("names"); 32 | m_npar = pnames.size(); 33 | 34 | vec p0(m_npar), p1(m_npar), l(m_npar), u(m_npar); 35 | uvec d(m_npar), lg(m_npar); 36 | 37 | for (size_t i = 0; i < m_npar; i++) { 38 | List a_list = pprior[pnames[i]]; 39 | unsigned int a_dist = a_list.attr("dist"); 40 | 41 | d[i] = a_dist; 42 | p0[i] = a_list[0]; 43 | p1[i] = a_list[1]; 44 | l[i] = a_list[2]; 45 | u[i] = a_list[3]; 46 | lg[i] = a_list[4]; 47 | } 48 | m_d = d; 49 | m_p0 = p0; 50 | m_p1 = p1; 51 | m_l = l; 52 | m_u = u; 53 | m_lg = lg; 54 | } 55 | Prior::Prior (S4 & pprior) 56 | { 57 | using namespace arma; 58 | 59 | std::vector pnames = pprior.slot("pnames"); 60 | Rcpp::List priors = pprior.slot("priors"); 61 | 62 | m_npar = pnames.size(); 63 | 64 | vec p0(m_npar), p1(m_npar), l(m_npar), u(m_npar); 65 | uvec d(m_npar), lg(m_npar); 66 | 67 | for (size_t i = 0; i < m_npar; i++) { 68 | List a_list = priors[pnames[i]]; 69 | unsigned int a_dist = a_list.attr("dist"); 70 | 71 | d[i] = a_dist; 72 | p0[i] = a_list[0]; 73 | p1[i] = a_list[1]; 74 | l[i] = a_list[2]; 75 | u[i] = a_list[3]; 76 | lg[i] = a_list[4]; 77 | } 78 | m_d = d; 79 | m_p0 = p0; 80 | m_p1 = p1; 81 | m_l = l; 82 | m_u = u; 83 | m_lg = lg; 84 | } 85 | Prior::~Prior() 86 | { 87 | // Rcout << "Prior destructor\n"; 88 | } 89 | 90 | void Prior::dprior(double * pvector, double * out) 91 | { 92 | double x, l, u; 93 | 94 | for (size_t i = 0; i < m_npar; i++) 95 | { 96 | // NA go here; NA will be converted to 0 (unsigned int type) 97 | if ( ISNAN(m_p1[i]) || ISNAN(m_d[i]) ) { 98 | out[i] = m_lg[i] ? R_NegInf : 0; 99 | } else if ( m_d[i] == TNORM ) { 100 | 101 | l = ISNAN(m_l[i]) ? R_NegInf : m_l[i]; 102 | u = ISNAN(m_u[i]) ? R_PosInf : m_u[i]; 103 | 104 | tnorm * obj = new tnorm(m_p0[i], m_p1[i], l, u, m_lg[i]); 105 | out[i] = obj->d(pvector[i]); 106 | delete obj; 107 | 108 | } else if ( m_d[i] == BETA_LU ) { 109 | 110 | l = ISNAN(m_l[i]) ? 0 : m_l[i]; // In case the user enters NAs. 111 | u = ISNAN(m_u[i]) ? 1 : m_u[i]; 112 | 113 | x = (pvector[i] - l) / (u - l); 114 | 115 | // Note m_l differs from m_lg !!! 116 | out[i] = !m_lg[i] ? R::dbeta(x, m_p0[i], m_p1[i], false) / (u - l) : 117 | R::dbeta(x, m_p0[i], m_p1[i], true) - std::log(u - l); 118 | 119 | } else if ( m_d[i] == GAMMA_L ) { 120 | 121 | l = ISNAN(m_l[i]) ? 0 : m_l[i]; 122 | x = ( !R_FINITE(l) ) ? pvector[i] : pvector[i] - l; 123 | out[i] = R::dgamma(x, m_p0[i], m_p1[i], m_lg[i]); 124 | 125 | } else if ( m_d[i] == LNORM_L ) { 126 | 127 | l = ISNAN(m_l[i]) ? 0 : m_l[i]; 128 | x = ( !R_FINITE(l) ) ? pvector[i] : pvector[i] - l; 129 | out[i] = R::dlnorm(x, m_p0[i], m_p1[i], m_lg[i]); 130 | 131 | } else if ( m_d[i] == UNIF_ ) { 132 | 133 | out[i] = R::dunif(pvector[i], m_p0[i], m_p1[i], m_lg[i]); 134 | 135 | } else if ( m_d[i] == CONSTANT ) { 136 | 137 | out[i] = m_lg[i] ? R_NegInf : 0; 138 | 139 | } else if ( m_d[i] == TNORM_TAU ) { 140 | l = ISNAN(m_l[i]) ? R_NegInf : m_l[i]; 141 | u = ISNAN(m_u[i]) ? R_PosInf : m_u[i]; 142 | 143 | tnorm * obj = new tnorm(m_p0[i], m_p1[i], l, u, m_lg[i]); 144 | out[i] = obj->d2(pvector[i]); 145 | delete obj; 146 | 147 | } else if (m_d[i] == CAUCHY_L ) { 148 | // Rcpp::Rcout << "The Cauchy Density\n"; 149 | out[i] = R::dcauchy(pvector[i], m_p0[i], m_p1[i], m_lg[i]); 150 | 151 | } else { 152 | Rcpp::Rcout << "Distribution type undefined \n"; 153 | out[i] = m_lg[i] ? R_NegInf : 0; 154 | } 155 | } 156 | 157 | } 158 | 159 | arma::vec Prior::dprior(arma::vec pvector) 160 | { 161 | double * pvec = new double[m_npar]; 162 | double * tmp = new double[m_npar]; 163 | 164 | for (size_t i = 0; i < m_npar; i++) pvec[i] = pvector[i]; 165 | 166 | dprior(pvec, tmp); 167 | 168 | arma::vec out(m_npar); 169 | for (size_t i = 0; i < m_npar; i++) 170 | { 171 | // Rcout << "tmp[i] " << tmp[i] << " - " << R_FINITE(tmp[i]) << "\n"; 172 | 173 | if ( !R_FINITE(tmp[i]) ) 174 | { 175 | out[i] = m_lg[i] ? -23.02585 : 1e-10; // critical to hierarchical? 176 | } 177 | else 178 | { 179 | out[i] = tmp[i]; 180 | } 181 | } 182 | 183 | delete [] pvec; 184 | delete [] tmp; 185 | 186 | return(out); 187 | 188 | } 189 | 190 | // Used in ininitlise.cpp & prior.R 191 | arma::vec Prior::rprior() 192 | { 193 | // replace DMC modified r-function; used in initialise.cpp internally 194 | double l, u; 195 | arma::vec out(m_npar); out.fill(NA_REAL); 196 | 197 | // [p1 p2]: [mean sd]; [shape1 shape2]; [shape scale]; [meanlog sdlog] 198 | for (size_t i = 0; i < m_npar; i++) { 199 | if ( ISNAN(m_d[i]) ) { 200 | out[i] = NA_REAL; 201 | 202 | } else if ( m_d[i] == TNORM ) { 203 | l = ISNAN(m_l[i]) ? R_NegInf : m_l[i]; 204 | u = ISNAN(m_u[i]) ? R_PosInf : m_u[i]; 205 | 206 | tnorm * obj = new tnorm(m_p0[i], m_p1[i], l, u); 207 | out[i] = obj->r(); 208 | delete obj; 209 | 210 | } else if ( m_d[i] == BETA_LU ) { 211 | l = ISNAN(m_l[i]) ? 0 : m_l[i]; 212 | u = ISNAN(m_u[i]) ? 1 : m_u[i]; 213 | out[i] = l + R::rbeta(m_p0[i], m_p1[i]) * (u - l); 214 | 215 | } else if ( m_d[i] == GAMMA_L ) { 216 | l = ISNAN(m_l[i]) ? 0 : m_l[i]; 217 | out[i] = R::rgamma(m_p0[i], m_p1[i]) + l; 218 | 219 | } else if ( m_d[i] == LNORM_L ) { 220 | l = ISNAN(m_l[i]) ? 0 : m_l[i]; 221 | out[i] = R::rlnorm(m_p0[i], m_p1[i]) + l; 222 | 223 | } else if ( m_d[i] == UNIF_ ) { 224 | out[i] = R::runif(m_p0[i], m_p1[i]); 225 | 226 | } else if ( m_d[i] == CONSTANT ){ // constant 227 | out[i] = m_p0[i]; 228 | 229 | } else if ( m_d[i] == TNORM_TAU ) { // tnorm2 230 | 231 | Rcout << "Distribution type not supported\n"; 232 | 233 | // l = ISNAN(lower[i]) ? R_NegInf : lower[i]; 234 | // u = ISNAN(upper[i]) ? R_PosInf : upper[i]; 235 | // out[i] = rtn_scalar2(p1[i], p2[i], l, u); 236 | 237 | } else if ( m_d[i] == CAUCHY_L ) { 238 | // Lower bound is not implemented. 239 | out[i] = R::rcauchy(m_p0[i], m_p1[i]); 240 | 241 | }else { 242 | Rcout << "Distribution type not supported\n"; 243 | out[i] = NA_REAL; 244 | } 245 | } 246 | 247 | return out; 248 | } 249 | 250 | double Prior::sumlogprior(arma::vec pvector) 251 | { 252 | arma::vec out = dprior(pvector); 253 | // den.replace(arma::datum::inf, 1e-10); 254 | // out.replace(R_PosInf, 1e-10); 255 | 256 | return arma::accu(out); 257 | } 258 | 259 | void Prior::print(std::string str) const 260 | { 261 | Rcpp::Rcout << str << ":\n"; 262 | Rcpp::Rcout << "[Location, scale, lower, upper]:\n"; 263 | 264 | for (size_t i=0; irprior(); 286 | for (size_t j=0; jsumlogprior(pvec);; 299 | delete p0; 300 | return out; 301 | } 302 | 303 | // [[Rcpp::export]] 304 | Rcpp::NumericVector test_dprior(arma::vec pvec, S4 pprior) 305 | { 306 | std::vector pnames = pprior.slot("pnames"); 307 | Rcpp::List priors = pprior.slot("priors"); 308 | 309 | Prior * p0 = new Prior (priors); 310 | arma::vec tmp = p0->dprior(pvec); 311 | delete p0; 312 | 313 | Rcpp::NumericVector out(tmp.size()); 314 | for (size_t i=0; idprior(pvec); 331 | // delete p0; 332 | // return out; 333 | // } -------------------------------------------------------------------------------- /src/pda.cpp: -------------------------------------------------------------------------------- 1 | // Copyright (C) <2019> 2 | // 3 | // This program is free software; you can redistribute it and/or modify 4 | // it under the terms of the GNU General Public License as published by 5 | // the Free Software Foundation; either version 2 of the License, or 6 | // (at your option) any later version. 7 | // 8 | // This program is distributed in the hope that it will be useful, 9 | // but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | // GNU General Public License for more details. 12 | // 13 | // You should have received a copy of the GNU General Public License along 14 | // with this program; if not, write to the Free Software Foundation, Inc., 15 | // 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. 16 | #include 17 | 18 | using namespace Rcpp; 19 | 20 | // [[Rcpp::export]] 21 | arma::vec spdf(arma::vec x, arma::vec RT, int n, double h_in, 22 | bool debug) { 23 | unsigned int nx = x.n_elem; 24 | unsigned int nRT = RT.n_elem; // if defective densities, nRT != n 25 | double h, z0, z1, z1minusz0, dt, fil0_constant, minRT, maxRT; 26 | unsigned int ngrid=1024, half_ngrid=512; 27 | arma::vec out(nx); 28 | 29 | minRT = RT.min(); 30 | maxRT = RT.max(); 31 | h = (h_in == 0) ? (0.8*arma::stddev(RT)*std::pow(nRT, -0.2)) : h_in; 32 | z0 = (minRT - 3.0*h < 0) ? 1e-10 : (minRT - 3.0*h); 33 | if (z0 < 0) { z0 = 0; if (debug) Rcout <<"z0 in SPDF is less than 0\n"; } 34 | z1 = maxRT > 10.0 ? 10.0 : maxRT + 3.0*h; 35 | 36 | if (nRT <= 10) { 37 | out.fill(1e-10); 38 | } else if (z1 <= z0) { 39 | 40 | if (debug) 41 | { 42 | Rcpp::Rcout << "[minRT maxRT nsRT] " << minRT << " " << maxRT << " " << 43 | nRT << "\n"; 44 | } 45 | out.fill(1e-10); 46 | 47 | } else { 48 | 49 | 50 | 51 | arma::vec z = arma::linspace(z0, z1, ngrid); 52 | dt = z[1] - z[0]; 53 | 54 | z1minusz0 = z1 - z0; 55 | fil0_constant = (-2.0*h*h*M_PI*M_PI) / (z1minusz0*z1minusz0); 56 | 57 | arma::vec filter0(ngrid); 58 | arma::vec h_binedge0(ngrid + 1); 59 | arma::vec signal0(ngrid); 60 | 61 | // Get binedge (1025), filter (1024) and histogram (1024) at one go ----------------- 62 | for(size_t i=0; i < ngrid; i++) 63 | { 64 | h_binedge0[i] = z0 + dt*((double)i - 0.5); // Binedge 65 | 66 | if (i < (1 + half_ngrid)) { // Filter 67 | filter0[i] = std::exp(fil0_constant * (double)(i*i)); 68 | } else { 69 | int j = 2*(i - half_ngrid); // flipping 70 | filter0[i] = filter0[i-j]; 71 | } 72 | } 73 | 74 | h_binedge0[ngrid] = (z0 + ((double)(ngrid - 1))*dt); 75 | 76 | arma::vec h_hist0 = arma::conv_to::from(arma::histc(RT, h_binedge0)); // 1025 77 | signal0 = h_hist0.rows(0, ngrid-1) / (dt * (double)(n)); 78 | 79 | arma::vec sPDF = arma::real(arma::ifft(filter0 % arma::fft(signal0))) ; 80 | arma::vec eDen; // a container for estiamted densities 81 | 82 | if (z.has_nan()) { 83 | eDen.fill(1e-10); 84 | Rcpp::stop("z has nan"); 85 | } else { 86 | arma::vec uniquez = arma::unique(z); 87 | if (uniquez.size() <= 1) { 88 | eDen.fill(1e-10); 89 | Rcpp::stop("z has only 1 or 0 element"); 90 | } else { 91 | arma::interp1(z, sPDF, x, eDen); 92 | } 93 | } 94 | 95 | for(size_t i=0; i < nx; i++) 96 | { 97 | out[i] = (eDen[i] < 1e-10 || std::isnan(eDen[i])) ? 1e-10 : eDen[i]; 98 | } 99 | } 100 | 101 | return out; 102 | } 103 | 104 | -------------------------------------------------------------------------------- /src/tnorm.cpp: -------------------------------------------------------------------------------- 1 | // Copyright (C) <2019> 2 | // 3 | // This program is free software; you can redistribute it and/or modify 4 | // it under the terms of the GNU General Public License as published by 5 | // the Free Software Foundation; either version 2 of the License, or 6 | // (at your option) any later version. 7 | // 8 | // This program is distributed in the hope that it will be useful, 9 | // but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | // GNU General Public License for more details. 12 | // 13 | // You should have received a copy of the GNU General Public License along 14 | // with this program; if not, write to the Free Software Foundation, Inc., 15 | // 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. 16 | #include 17 | 18 | tnorm::tnorm (double mu, double sig, double lower, double upper, bool lg) : 19 | m(mu), s(sig), l(lower), u(upper), lp(lg) 20 | // Constructor. Initialize with mu and sigma. The default with no arguments 21 | // is tnorm(0, 1, 0, Inf). 22 | { 23 | // TODO: Reorganize this class to be in line with other classes. 24 | // Bayesian optimization must allow bad values!? 25 | // if (sig < 0.) 26 | // { 27 | // Rcpp::Rcout << "Invalid sigma = " << sig << std::endl; 28 | // Rcpp::stop("Bad sigma in dtnorm"); 29 | // } 30 | } 31 | 32 | tnorm::tnorm (double mu, double sig, double lower, double upper, bool lg, 33 | bool lower_tail) : 34 | m(mu), s(sig), l(lower), u(upper), lp(lg), lt(lower_tail) 35 | { 36 | if (sig < 0.) 37 | { 38 | Rcpp::Rcout << "Invalid sigma = " << sig << std::endl; 39 | Rcpp::stop("Bad sigma in ptnorm"); 40 | } 41 | } 42 | 43 | tnorm::tnorm (double mu, double sig, double lower, double upper) : 44 | m(mu), s(sig), l(lower), u(upper) 45 | { 46 | if (sig < 0.) 47 | { 48 | Rcpp::Rcout << "Invalid sigma = " << sig << std::endl; 49 | Rcpp::stop("Bad sigma in rtnorm"); 50 | } 51 | } 52 | 53 | 54 | double tnorm::d (double x) 55 | { 56 | double out, numer, denom; 57 | 58 | // if (s < 0) 59 | // { 60 | // out = lp ? R_NegInf : 0; 61 | // } 62 | if ((x >= l) && (x <= u)) 63 | { 64 | // 4th arg: lower.tail (lt)=1; 5th arg: log.p (lg)=0 65 | denom = R::pnorm(u, m, s, true, false) - R::pnorm(l, m, s, true, false); 66 | numer = R::dnorm(x, m, s, lp); 67 | out = lp ? (numer - std::log(denom)) : (numer/denom); 68 | } 69 | else 70 | { 71 | out = lp ? R_NegInf : 0; 72 | } 73 | 74 | return out; 75 | } 76 | 77 | void tnorm::d (std::vector & x, std::vector & output) 78 | { 79 | for(size_t i=0; i= l) && (x <= u)) { 91 | // 4th arg: lower.tail (lt)=1; 5th arg: log.p (lg)=0 92 | sd = 1/std::sqrt(s); 93 | // 4th arg: lower.tail (lt)=1; 5th arg: log.p (lg)=0 94 | denom = R::pnorm(u, m, sd, true, false) - R::pnorm(l, m, sd, true, false); 95 | numer = R::dnorm(x, m, sd, lp); 96 | out = lp ? (numer - std::log(denom)) : (numer/denom); 97 | } else { 98 | out = lp ? R_NegInf : 0; 99 | } 100 | return(out); 101 | 102 | } 103 | 104 | double tnorm::p (double x) 105 | { 106 | double out, denom, qtmp; 107 | if (lt) { 108 | out = (x < l) ? 0 : 1; 109 | } else { 110 | out = (x < l) ? 1 : 0; 111 | } 112 | 113 | if ( (x >= l) && (x <= u) ) 114 | { 115 | // 4th arg: lower.tail (lt)=1; 5th arg: log.p (lg)=0 116 | denom = R::pnorm(u, m, s, true, false) - R::pnorm(l, m, s, true, false); 117 | 118 | qtmp = lt ? 119 | (R::pnorm(x, m, s, true, false) - R::pnorm(l, m, s, true, false)) : 120 | (R::pnorm(u, m, s, true, false) - R::pnorm(x, m, s, true, false)) ; 121 | 122 | out = lp ? (std::log(qtmp)-std::log(denom)) : (qtmp/denom); 123 | } 124 | return out; 125 | } 126 | 127 | void tnorm::p (std::vector & x, std::vector & output) 128 | { 129 | for(size_t i=0; i mean 148 | // Algorithm (2): Use -x ~ N_+ (-mu, -mu^+, sigma^2) on page 123. 149 | // lower==-INFINITY 150 | // rejection sampling with exponential proposal. Use if upper < mean. 151 | // Algorithm (3, else): rejection sampling with uniform proposal. 152 | // Use if bounds are narrow and central. 153 | a0 = (stdl < 0 && u == R_PosInf) || (stdl == R_NegInf && stdu > 0) || 154 | (std::isfinite(stdl) && std::isfinite(u) && stdl < 0 && stdu > 0 && 155 | (stdu - stdl) > SQRT_2PI); 156 | eq_a1 = stdl + (2.0 * std::sqrt(M_E) / (stdl + std::sqrt(stdl2 + 4.0))) * 157 | (std::exp( 0.25 * (2.0*stdl - stdl*std::sqrt(stdl2 + 4.0)))); 158 | a1 = (stdl >= 0) && (stdu > eq_a1); 159 | eq_a2 = -stdu + (2.0 * std::sqrt(M_E) / (-stdu + std::sqrt(stdu2 + 4.0))) * 160 | (std::exp(0.25 * (2.0*stdu + stdu*std::sqrt(stdu2 + 4.0)))); 161 | a2 = (stdu <= 0) && (-stdl > eq_a2); 162 | 163 | if (a0) { 164 | z = rtnorm0(stdl, stdu); 165 | } else if (a1) { 166 | z = rtnorm1(stdl, stdu); 167 | } else if (a2) { 168 | z = rtnorm2(stdl, stdu); 169 | } else { 170 | z = rtnorm3(stdl, stdu); 171 | } 172 | return z*s + m; 173 | } 174 | 175 | //' Truncated Normal Distribution 176 | //' 177 | //' Random number generation, probability density and cumulative density 178 | //' functions for truncated normal distribution. 179 | //' 180 | //' @param x,q vector of quantiles; 181 | //' @param n number of observations. n must be a scalar. 182 | //' @param p1 mean (must be scalar). 183 | //' @param p2 standard deviation (must be scalar). 184 | //' @param lower lower truncation value (must be scalar). 185 | //' @param upper upper truncation value (must be scalar). 186 | //' @param lt lower tail. If TRUE (default) probabilities are \code{P[X <= x]}, 187 | //' otherwise, \code{P[X > x]}. 188 | //' @param lg log probability. If TRUE (default is FALSE) probabilities p are 189 | //' given as \code{log(p)}. 190 | //' @return a numeric vector. 191 | //' @examples 192 | //' ## rtnorm example 193 | //' dat1 <- rtnorm(1e5, 0, 1, 0, Inf) 194 | //' hist(dat1, breaks = "fd", freq = FALSE, xlab = "", 195 | //' main = "Truncated normal distributions") 196 | //' 197 | //' ## dtnorm example 198 | //' x <- seq(-5, 5, length.out = 1e3) 199 | //' dat1 <- dtnorm(x, 0, 1, -2, 2, 0) 200 | //' plot(x, dat1, type = "l", lwd = 2, xlab = "", ylab= "Density", 201 | //' main = "Truncated normal distributions") 202 | //' 203 | //' ## ptnorm example 204 | //' x <- seq(-10, 10, length.out = 1e2) 205 | //' mean <- 0 206 | //' sd <- 1 207 | //' lower <- 0 208 | //' upper <- 5 209 | //' dat1 <- ptnorm(x, 0, 1, 0, 5, lg = TRUE) 210 | //' @export 211 | // [[Rcpp::export]] 212 | std::vector dtnorm(std::vector x, double p1, double p2, 213 | double lower, double upper, bool lg = false) { 214 | if (upper < lower) Rcpp::stop("upper must be greater than lower."); 215 | if (p2 < 0) Rcpp::stop("sd must be greater than 0.\n"); 216 | if (p2 == R_NegInf || p2 == R_PosInf) Rcpp::stop("sd must have a finite value.\n"); 217 | if (p1 == R_NegInf || p1 == R_PosInf) Rcpp::stop("mean must have a finite value.\n"); 218 | 219 | std::vector out(x.size()); 220 | 221 | tnorm * obj = new tnorm(p1, p2, lower, upper, lg); 222 | obj->d(x, out); 223 | 224 | delete obj; 225 | return out; 226 | } 227 | 228 | 229 | //' @rdname dtnorm 230 | //' @export 231 | // [[Rcpp::export]] 232 | std::vector rtnorm(unsigned int n, double p1, double p2, double lower, 233 | double upper) { 234 | 235 | std::vector out(n); 236 | tnorm * obj = new tnorm(p1, p2, lower, upper); 237 | for(size_t i = 0; i r(); 238 | delete obj; 239 | return out; 240 | } 241 | 242 | //' @rdname dtnorm 243 | //' @export 244 | // [[Rcpp::export]] 245 | std::vector ptnorm(std::vector q, double p1, double p2, 246 | double lower, double upper, bool lt = true, 247 | bool lg = false) { 248 | if (upper < lower) {Rcpp::stop("'upper' must be greater than 'lower'.");} 249 | if (p2 < 0) {Rcpp::stop("'sd' must be greater than 0.\n");} 250 | if (p2 == R_NegInf || p2 == R_PosInf) {Rcpp::stop("'sd' must have a finite value.\n");} 251 | if (p1 == R_NegInf || p1 == R_PosInf) {Rcpp::stop("'mean' must have a finite value.\n");} 252 | 253 | std::vector out(q.size()); 254 | tnorm * obj = new tnorm(p1, p2, lower, upper, lg, lt); 255 | obj->d(q, out); 256 | delete obj; 257 | return out; 258 | } 259 | 260 | 261 | 262 | -------------------------------------------------------------------------------- /src/vonmises.cpp: -------------------------------------------------------------------------------- 1 | // Copyright (C) <2019> 2 | // 3 | // This program is free software; you can redistribute it and/or modify 4 | // it under the terms of the GNU General Public License as published by 5 | // the Free Software Foundation; either version 2 of the License, or 6 | // (at your option) any later version. 7 | // 8 | // This program is distributed in the hope that it will be useful, 9 | // but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | // GNU General Public License for more details. 12 | // 13 | // You should have received a copy of the GNU General Public License along 14 | // with this program; if not, write to the Free Software Foundation, Inc., 15 | // 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. 16 | #include 17 | 18 | using namespace Rcpp; 19 | 20 | inline double pvm_(double q, double kappa, double tol) { 21 | bool flag = true; 22 | double p = 1; 23 | double sum = 0; 24 | while (flag) { 25 | double term = (R::bessel_i(kappa, p, 1.) * std::sin(p * q)) / p; 26 | sum += term; 27 | p++; 28 | if (std::abs(term) < tol) flag = false; 29 | } 30 | 31 | double out = q/M_2PI + sum / (M_PI * R::bessel_i(kappa, 0, 1.)); 32 | return out; 33 | } 34 | 35 | inline arma::vec fmod(arma::vec dividend, double divisor) 36 | { 37 | // a float point modulus operator taking armadillo vector and a double-type 38 | // divisor 39 | return dividend - arma::floor(dividend / divisor)*divisor; 40 | } 41 | 42 | //' Generate random deviates from a von Mises distribution 43 | //' 44 | //' This function generates random numbers in radian unit from a von Mises 45 | //' distribution using the location (ie mean) parameter, mu and the 46 | //' concentration (ie precision) parameter kappa. 47 | //' 48 | //' A random number for a circular normal distribution has the form:\cr 49 | //' \deqn{f(theta; mu, kappa) = 1 / (2*pi*I0(kappa)) * exp(kappa*cos(theta-mu))} 50 | //' theta is between 0 and 2*pi. 51 | //' 52 | //' \code{I0(kappa)} in the normalizing constant is the modified Bessel 53 | //' function of the first kind and order zero. 54 | //' 55 | //' @param x,q x and q are the quantiles. These must be one a scalar. 56 | //' @param n number of observations 57 | //' @param tol the tolerance imprecision for von Mist distribution function. 58 | //' @param mu mean direction of the distribution. Must be a scalar. 59 | //' @param kappa concentration parameter. A positive value 60 | //' for the concentration parameter of the distribution. Must be a scalar. 61 | //' 62 | //' @return a column vector 63 | //' @references 64 | //' \enumerate{ 65 | //' Ulric Lund, Claudio Agostinelli, et al's (2017). R package 'circular': 66 | //' Circular Statistics (version 0.4-91). 67 | //' \url{https://r-forge.r-project.org/projects/circular/} 68 | //' } 69 | //' @examples 70 | //' n <- 1e2 71 | //' mu <- 0 72 | //' k <- 10 73 | //' 74 | //' \dontrun{ 75 | //' vm1 <- circular:::RvonmisesRad(n, mu, k) 76 | //' vm2 <- rvm(n, mu, k) 77 | //' vm3 <- circular:::conversion.circular(circular:::circular(vm1)) 78 | //' vm4 <- circular:::conversion.circular(circular:::circular(vm2)) 79 | //' plot(vm3) 80 | //' plot(vm4) 81 | //' } 82 | //' @export 83 | // [[Rcpp::export]] 84 | arma::vec rvonmises(unsigned int n, double mu, double kappa) { 85 | 86 | double U, a, b, r, z, f, c, tmp; 87 | arma::vec out(n); 88 | arma::vec::iterator i = out.begin() ; 89 | 90 | // If kappa is small, sample angles from a uniform distribution [0 2*pi] 91 | if (kappa < 1e-10 ) { 92 | do { *i = R::runif(0.0, M_2PI); i++; } while (i < out.end()); 93 | } else { 94 | a = 1.0 + std::sqrt(1.0 + 4.0 * kappa * kappa); 95 | b = (a - std::sqrt(2.0 * a)) / (2.0 * kappa); 96 | r = (1.0 + b * b) / (2.0 * b); 97 | 98 | do { 99 | z = std::cos(M_PI * R::runif(0.0, 1.0)); 100 | f = (1.0 + r*z) / (r + z); 101 | c = kappa*(r - f); 102 | U = R::runif(0.0, 1.0); 103 | 104 | if (c * (2.0 - c) > U) { 105 | tmp = (R::runif(0.0, 1.0) > 0.50) ? std::acos(f) + mu : -std::acos(f) + mu; 106 | *i = tmp - std::floor(tmp/M_2PI)*M_2PI; // store in out 107 | i++; 108 | } else { 109 | if (std::log(c/U) + 1.0 >= c) { 110 | tmp = (R::runif(0.0, 1.0) > 0.50) ? std::acos(f) + mu : -std::acos(f) + mu; 111 | *i = tmp - std::floor(tmp/M_2PI)*M_2PI; 112 | i++; 113 | } 114 | } 115 | } while(i < out.end()); 116 | } 117 | 118 | return out; 119 | } 120 | 121 | 122 | //' @rdname rvonmises 123 | //' @export 124 | // [[Rcpp::export]] 125 | arma::vec dvonmises(arma::vec x, double mu, double kappa) 126 | { 127 | arma::vec out(x.n_elem); 128 | 129 | if (kappa == 0) { 130 | out.fill(1/M_2PI); 131 | } else if (kappa < 1e5) { 132 | out = arma::exp(kappa * arma::cos(x - mu)) / 133 | ( M_2PI * R::bessel_i(kappa, 0, 1.) ); 134 | } else { 135 | for (size_t i = 0; i < x.n_elem; i++) { 136 | double num = x(i) - mu; 137 | double tmp = std::fmod(num, M_2PI); 138 | out(i) = tmp == 0 ? INFINITY : 0; 139 | } 140 | } 141 | 142 | return out; 143 | } 144 | 145 | //' @rdname rvonmises 146 | //' @export 147 | // [[Rcpp::export]] 148 | arma::vec pvonmises(arma::vec q, double mu, double kappa, double tol = 1e-20) 149 | { 150 | arma::vec qmod = fmod(q, M_2PI); 151 | unsigned int n = q.n_elem; 152 | // double mu_mod = std::fmod(mu, M_2PI); 153 | arma::vec out(n); out.fill(NA_REAL); 154 | if (mu == 0) { 155 | for (size_t i = 0; i < qmod.n_elem; i++) 156 | out(i) = pvm_(qmod(i), kappa, tol); 157 | } else { 158 | double upper, lower; 159 | for (size_t i = 0; i < qmod.n_elem; i++) { 160 | if (qmod(i) <= mu) { 161 | upper = std::fmod(qmod(i) - mu, M_2PI); 162 | if (upper == 0) upper = M_2PI; 163 | lower = std::fmod(-mu, M_2PI); 164 | out(i) = pvm_(upper, kappa, tol) - pvm_(lower, kappa, tol); 165 | } else { 166 | upper = qmod(i) - mu; 167 | lower = std::fmod(mu, M_2PI); 168 | out(i) = pvm_(upper, kappa, tol) + pvm_(lower, kappa, tol); 169 | } 170 | } 171 | } 172 | 173 | return out; 174 | } 175 | 176 | --------------------------------------------------------------------------------