coda/0000755000176200001440000000000013507650333011165 5ustar liggesuserscoda/inst/0000755000176200001440000000000013507641554012147 5ustar liggesuserscoda/inst/CITATION0000644000176200001440000000133313343454654013305 0ustar liggesuserscitHeader("To cite package coda in publications use:") citEntry(entry="Article", title = "CODA: Convergence Diagnosis and Output Analysis for MCMC", author = personList(as.person("Martyn Plummer"), as.person("Nicky Best"), as.person("Kate Cowles"), as.person("Karen Vines")), journal = "R News", year = 2006, volume = 6, number = 1, pages = "7--11", url = "https://journal.r-project.org/archive/", pdf = "https://www.r-project.org/doc/Rnews/Rnews_2006-1.pdf", textVersion = "Martyn Plummer, Nicky Best, Kate Cowles and Karen Vines (2006). CODA: Convergence Diagnosis and Output Analysis for MCMC, R News, vol 6, 7-11") coda/inst/AUTHORS0000644000176200001440000000331113343454654013216 0ustar liggesusersThe main authors of CODA ------------------------ Mary Kathryn Cowles University of Nebraska Medical Center, USA Nicky Best Imperial college, London, UK Karen Vines Open University, Milton Keynes, UK Martyn Plummer International Agency for Research on Cancer, Lyon, France CODA was conceived and motivated by Mary Kathryn Cowles, who developed the original program as part of her PhD thesis concerning practical issues in implementing the Gibbs sampler. It was modified by Nicky Best to provide software suitable for general release, including contributions by Karen Vines. Martyn Plummer ported CODA to R and modified the code so that the user is not bound by the menu-driven interface. All authors, and the MRC Biostatistic Unit, have given permission for the license terms to be changed to GPL. Other authors of CODA --------------------- Deepayan Sarkar provided lattice graphics functions (See ?densityplot.mcmc) Douglas Bates wrote the HPDinterval function. Russell Almond , provided a number of cleanups and wrote the functions autocorr.diag, batchSE, and rejectionRate. Arni Magnusson wrote the cumuplot function. Further credits --------------- The function "gelman.diag" is based on the "itsim" function contributed to the Statlib archive by Andrew Gelman . The function "raftery.diag" is based on the "gibbsit" function contributed to the Statlib archive by Steven Lewis . Andrew Martin added namespace facilities and fixed a large number of bugs that this change uncovered (see CHANGELOG) coda/NAMESPACE0000644000176200001440000000661713343454654012424 0ustar liggesusers## export functions export( acfplot, HPDinterval, as.array.mcmc.list, as.mcmc, as.mcmc.list, autocorr, ##RGA autocorr.diag, autocorr.plot, ##RGA batchSE, bugs2jags, chanames, coda.options, codamenu, crosscorr, crosscorr.plot, cumuplot, densplot, display.coda.options, effectiveSize, gelman.diag, gelman.plot, geweke.diag, geweke.plot, heidel.diag, is.mcmc, is.mcmc.list, mcmc, mcmc.list, mcmcUpgrade, mcpar, multi.menu, nchain, niter, nvar, pcramer, raftery.diag, read.and.check, read.coda.interactive, read.coda, read.jags, read.openbugs, ##RGA rejectionRate, spectrum0, spectrum0.ar, thin, traceplot, varnames, "varnames<-") ## export data # export(line) # this doesn't need to be exported, not sure why, but it works fine # as is. # [1] [.mcmc as.matrix.mcmc end.mcmc frequency.mcmc plot.mcmc # [6] print.mcmc start.mcmc summary.mcmc thin.mcmc time.mcmc # [11] window.mcmc # [1] [.mcmc.list as.matrix.mcmc.list as.mcmc.mcmc.list # [4] end.mcmc.list plot.mcmc.list start.mcmc.list # [7] summary.mcmc.list thin.mcmc.list time.mcmc.list # [10] window.mcmc.list ## register S3 methods S3method(as.mcmc, default) S3method(as.mcmc.list, default) S3method(as.ts, mcmc) ## as.matrix S3method(as.matrix, mcmc) S3method(as.matrix, mcmc.list) ## mcmc S3method("[", mcmc) S3method(end, mcmc) S3method(frequency, mcmc) S3method(plot, mcmc) S3method(print, mcmc) S3method(start, mcmc) S3method(summary, mcmc) S3method(thin, mcmc) S3method(time, mcmc) S3method(window, mcmc) S3method(head, mcmc) S3method(tail, mcmc) ##RGA S3method(autocorr.diag, mcmc) S3method(rejectionRate, mcmc) S3method(batchSE,mcmc) S3method(as.data.frame,mcmc) ##DMB S3method(HPDinterval, mcmc) ## mcmc.list S3method("[", mcmc.list) S3method(as.matrix, mcmc.list) S3method(as.mcmc, mcmc.list) S3method(as.array, mcmc.list) S3method(end, mcmc.list) S3method(plot, mcmc.list) S3method(start, mcmc.list) S3method(summary, mcmc.list) S3method(thin, mcmc.list) S3method(time, mcmc.list) S3method(window, mcmc.list) S3method(head, mcmc.list) S3method(tail, mcmc.list) ##RGA S3method(autocorr.diag, mcmc.list) S3method(rejectionRate, mcmc.list) S3method(batchSE,mcmc.list) ##DMB S3method(HPDinterval, mcmc.list) ## misc S3method(print, gelman.diag) S3method(print, geweke.diag) S3method(print, heidel.diag) S3method(print, raftery.diag) S3method(print, summary.mcmc) ## Imports importFrom(grDevices, dev.cur, dev.interactive, dev.off, postscript, topo.colors, nclass.Sturges) importFrom(graphics, abline, axis, hist, legend, lines, matplot, par, plot, polygon, text, title, barplot) importFrom(lattice, xyplot, qqmath, densityplot, levelplot, panel.abline, panel.xyplot, trellis.par.get, do.breaks, panel.superpose, prepanel.qqmathline, splom) importFrom(stats, Gamma, IQR, acf, aggregate, ar, as.formula, as.ts, cor, density, end, fft, frequency, glm, lm, lowess, predict, qf, qnorm, quantile, residuals, sd, start, time, ts, var, window) importFrom(utils, head, menu, read.table, tail) ## lattice methods S3method(xyplot, mcmc) S3method(qqmath, mcmc) S3method(densityplot, mcmc) S3method(acfplot, mcmc) S3method(levelplot, mcmc) S3method(xyplot, mcmc.list) S3method(qqmath, mcmc.list) S3method(densityplot, mcmc.list) S3method(acfplot, mcmc.list) coda/CHANGELOG0000644000176200001440000003524713507641542012414 0ustar liggesusers0.19-3 Martyn.plumemr - Obsolete documentation for .Coda.options removed 0.19-2 Martyn Plummer - Maintainer address update 0.19-1 Martyn Plummer - gelman.plot() now avoids superfluous calculation of multivariate diagnostic. Thanks to Gert van Valkenhoef. - Fixed various issues with the histogram produced by densplot() for discrete-valued distributions. Thanks to Robert Goudie. - Obsolete INDEX file removed - Dimnames bug in geweke.plot fixed. Thanks to Jiri Moravec 0.18-1 Martyn Plummer - Arni Magnusson is fully credited as coauthor - Fixed bug in "varnames<-", which failed when the mcmc object was not a matrix. Thanks to Evangelos Evangelou and Pavel Krivitsky. - NAMESPACE file now includes imports of functions from base packages. - codamenu no longer gives option to save mcmc object on exit. 0.17-2 Martyn Plummer - Avoid redundant copies when subsetting mcmc.list objects 0.17-1 Martyn Plummer - Moved lattice package from Depends to Imports in DESCRIPTION file. This means that you must load the lattice package to use any of the lattice methods provided for mcmc objects. - Russell Almond is fully credited as co-author - Moved AUTHORS file into inst/ sub-directory - Fixed bug that stopped trellis graphics from working with vector mcmc objects (thinned chains). Thanks to Chris Andrews. - Added additional arguments (...) to as.mcmc() - coda.options() no longer writes to the global environment 0.16-1 - Fixed main title bug in densplot - Substitute spectrum0.ar for spectrum0 internally - densplot parameters fixed when drawing multiple plots 0.15-3 - Correct x axis labelling in xyplot. Thanks to Pavel Krivitsky. 0.15-2 - Allow default plotting parameters to be overridden in densplot and traceplot. - Stop overplotting of user-supplied title in densplot. - Fix xyplot for univariate chains. Thanks to Pavel Krivitsky. 0.15-1 - Use Authors@R field in DESCRIPTION - Fixe geweke.diag for long mcmc samples. Thanks to Philip Johnson 0.14-7 - In gelman.diag, the multivariate potential scale reduction factor is now optional and can be turned off with the argument multivariate=FALSE. 0.14-6 - Removed deprecated top-level file COPYING 0.14-5 - Replaced defunct restart() function in codamenu with with try() - Changed as.ts.mcmc to be a method for generic function as.ts 0.14-4 - Arguments of gelman.plot are now consistent with gelman.diag. 0.14-3 - Fixed documentation errors in gelman.diag (Thanks to Peng Yu) - Added CITATION file 0.14-2 - Fix documentation bugs (Thanks to Kurt Hornik) 0.14-1 - traceplot and plot.mcmc no longer plot a smooth line by default, although it can be added using smooth=TRUE - new head and tail methods for mcmc and mcmc.list objects 0.13-1 - as.mcmc.list generic and default method are exported in namespace 0.12-1 - Added further changes for S-PLUS from Dawn Woodward. 0.11-3 - Fixed documentation on subsetting methods for mcmc and mcmc.list objects 0.11-2 - The codamenu function has been modified so that it no longer works with coda.dat and work.dat in the global environment, solving global binding issues. - The sample size test at the beginning of codamenu has been corrected for the case of multiple chains. Thanks to Luwis Diya and Pablo G Goicoechea for these bug reports - Syntax errors fixed in help pages. - Description of Gelman and Rubin diagnostic corrected 0.11-1 - Added changes from Dawn Woodward for S-PLUS. - Fixed global binding problems 0.10-7 - Documentation clarification for bugs2jags() - Made linearity test in codamenu less stringent. Thanks to Bengt Sennblad. - Fixed rejectionRate() for single-variable chains. Thanks to Rob Scharpf. 0.10-6 - Fixed HPDinterval() for univariate chains Thanks to David LeBlond - Fixed optional parameters in as.data.frame method for mcmc objects 0.10-5 - Registered default method for as.mcmc in NAMESPACE Thanks to Christian Grose 0.10-4 - fixed eternal loop in codamenu() when saving plot as PostScript. Thanks to Bengt Sennblad. 0.12-3 - added 'data' in lattice generics for compatibility 0.10-2 - Import generics from lattice - In plotting functions, "ask" now defaults to dev.interactive(), and not the default value in par(), as introduced in 0.9-2 0.10-1 - Added "mcmc" and "mcmc.list" methods for several lattice functions (xyplot, qqmath, densityplot and acfplot (with generic here as well)). There's a levelplot method too, which is currently experimental. These are Trellis analogs of existing coda functions, and may in future replace them. 0.9-5 - Fixed bug in summary.mcmc (safespec0 misspelled) which affected univariate chains. 0.9-4 - Fixed documentation errors. 0.9-3 - Added date stamp check in read.openbugs to ensure files were created at the same time. 0.9-2 - [RGA] Added an autoburnin flag (default) true to gelman.diag to suppress automatic windowing for burn in (so I can do it manually). - [RGA] Fixed a problem where summary.mcmc.list would not give correct pooled standard errors. - [RGA] Fixed propagation of standard par and titles to plot.mcmc and plot.mcmc.list. Also fixed so that ask will default to value in par(). - [RGA] Fixed a problem where autocorr would apply thinning twice to mcmc.list objects. - [RGA] Changed effectiveSize for mcmc.list to sum across all chains. Original behavior can be recovered by using lapply(x,effectiveSize) - [RGA] Added autocorr.diag function. - [RGA] Patched summary.mcmc and summary.mcmc.list so it would give standard error of NA when spectrum0 blows ups. - [RGA] Added a rejectionRate method. - [RGA] Added a batch Standard Error Function 0.9-1 - spectrum0 function now has default max.length argument of 200. This means that the output will be batched to a length between 100 and 200 before fitting the glm to the spectrogram. This should improve robustness for chains with high autocorrelation, or markedly non-gaussian distributions. - The read.bugs() function has been removed; read.coda() has been modified to allow specification of both output and index files; read.bugs.interactive() has been modified in the same way; read.openbugs() is a new wrapper function around read.coda() for OpenBUGS output. 0.8-3 - Fixed documentation errors in coda.menu.Rd and linepost.Rd 0.8-2 - Added generic function thin to list of exported functions 0.8-1 Continuing problems with namespace: - Addition of namespace requires new version number for coda, as saved workspaces are not backwards compatible. - Ensured that mcmc attributes are not assumed for objects returned by as.matrix.mcmc, as this now no longer returns an mcmc object. This occurred in, for example, effectiveSize (which returned NA) and gelman.diag (which dropped variable names). - Changed "[.mcmc.list" and "[.mcmc" so that they return an mcmc.list/mcmc object respectively when subsetting columns. plot.mcmc() and plot.mcmc.list() now work again when there is only one variable. - Imported the required time series generics from package stats. Failure to do this may result in a saved workspace that cannot be reloaded. Other problems - Removed S compatibility (statements conditional on is.R and wrapper function coda.global.assign). Note that S compatibility never worked at all, and I now have no intention of supporting it. - Fixed (old) bug in "[.mcmc" which made column subsets of mcmc objects return invisibly. - Changed the plotting functions so it is no longer necessary to press return to see the first page of plots. 0.7-3 (changes done by Andrew Martin ) - Added NAMESPACE - export only functions that I think should have been exported (based on the documentation and common sense). - Registered all S3 methods. - Fixed documentation for non-exported functions. - Patched the "mcmc" function to deal with really big thinning intervals. - Patched the "as.matrix.mcmc" function so it really returns matrices. - Fixed plot method, by having plot.mcmc pass an mcmc object rather than a matrix, and by fixing the [.mcmc.list method so it returns an mcmc.list not a matrix. - Fixed "varnames<-" which was broken when the as.matrix method was fixed. - Fixed documentation mcmc.convert.Rd such that the usage is consistent with S3 class definition (this fixed an error thrown in the QC tools). 0.7-2 - The spectrum0() function now returns zero when it is given a constant vector. summary.mcmc() (which calls spectrum0) now works correctly. 0.7 - Modified to run on R 1.9.0 with new organization of base library 0.6-2 - Fixed documentation bug in raftery.diag 0.6-1 - spectrum0.ar no longer crashes when the chain is a linear function of the iteration number - codamenu automatically drops variables that are linear functions of the iteration number - read.bugs renamed to read.coda. read.bugs exists as an alias. - initial support for JAGS: bugs2jags function converts WinBUGS data to R dump format used by JAGS. - added cumuplot function (not yet in codamenu system) 0.5-14 - Fixed reporting of sample size in densplot(), for variables that are in the range [0,1] or [0,Inf). Thanks to Roy Levy. 0.5-13 - mcmc() now works with data frames (provided that they contain only numeric values). 0.5-12 - Documentation errors in coda.options.Rd and nchain.Rd fixed. Thanks to Kurt Hornik. 0.5-11 - Fixed bug in mcmc() function that causes problems in Geweke diagnostic - Fixed geweke.plot so that it works with samples running from iteration N to 2N. These were previously mis-diagnosed as being too short. Thanks to Vasco Leemans for finding both bugs. - In autocorr.plot, the `ask' argument was not used. Thanks to Dennis A Wolf. 0.5-10 - Eliminated use of "=" for assignment operator. This is a syntax error for R < 1.4.0 0.5-9 - Further documentation bugs removed 0.5-8 - Removed further documentation bugs found by "R CMD check coda" using R-1.4 (pre-release) 0.5-7 - Removed obsolete line.doc and line.old.doc files from data directory. - New spectrum0.ar provides model-based estimate of spectral density at frequency zero. - New effectiveSize diagnostic gives effective sample size. - codamenu includes automatic check on effective sample size. 0.5-6 - Removed further documentation bugs found by "R CMD check coda" using R-1.3 (pre-release) 0.5-5 - Ironed out last warnings generated by "R CMD check coda" 0.5-4 - Provided documentation for all functions and datasets. (Thanks to Kurt Hornik for the prompting) 0.5-3 - Fixed bug in example for mcmc.list. Row subsetting no longer preserves mcmc objects (Thanks to Kurt Hornik). 0.5-2 - Fixed bug in gelman.transform which did not work for univariate chains (Thanks to Mark A. Beaumont) - Fixed confidence limits in geweke.plot (Thanks to Mark A. Beaumont) - Allow user to set ylim in densplot (Thanks to Niels Peter Baadsgaard) 0.5-1 - Replaced time series functions with functions from "ts" library (R-base >= 0.65.0) - Removed calls to Version() (deprecated). Use is.R() instead. - Added new function read.yesno - Source files maintained using ESS - Allowed restart() in codamenu.options.plot.kernel - Simplified print.coda.options - Removed "onepage" option in coda.options() (Subsumed in user.layout) - Removed "mrows" and "mcols" options in coda.options (use par instead) Changes to Geweke's diagnostic - Uses new function spectrum0() to estimate spectral density at zero - Gelman-Rubin-Brooks plot never discards more than half the chain to preserve necessary asymptotic conditions. Changes to Gelman and Rubin's diagnostic - Multivariate psrf added. - Documentation for Gelman-Rubin-Brooks plot update to give clearer motivation. Changes to Heidelberger and Welch's diagnostic - Simplified formula for Cramer-von Mises statistic - Using new function spectrum0() to estimate spectral density at zero - Can set p-value threshold for passing convergence test. - p-value is printed in output, using new function pcramer(). - Prints starting iteration of truncated chain instead of number of iterations to discard. 0.4-7 Fixed bug in read.bugs.interactive() leading to failure when user enters both ".ind" and ".out" names (Thanks to John Logsdon). 0.4-6 Archive 0.4-5 was incorrectly compressed with "compress" instead of "gzip". Corrected by Friedrich Leisch. 0.4-5 Bug fixes - densplot failed with show.obs=TRUE when scale was "positive" or "proportion". - as.matrix.mcmc failed to preserve start, end and thin. - codamenu did not tidy up on exit. 0.4-4 Started S3 compatibility Fixed bug which caused options menus to crash Fixed legend bug in gelman.plot Confirmed that these bugs are fixed: * densplot "missing" and "scale" bugs (Thanks to Greg Warnes) * autocorr "improper time series parameters" bug ("acf" function rewritten by Paul Gilbert) * integer overflow bug in raftery.diag (Thanks to Morten Frydenberg) * read.bugs.interactive will search for the files it needs and print their names. codamenu now assigns default variable and chain names to data when these are NULL. 0.4-3 Fixed help page errors pointed out by Brian Ripley. Fixed coda.credits 0.4-2 Whoops. 0.4-1 was a mistake. 0.4-1 updated manual pages new class mcmc.list added to deal with multiple chains. ugrade.mcmc function introduced to deal with old mcmc objects. plot functions changed to use the "ask" parameter instead of "pause" functions. spec.pgram now handles matrix time-series. acf function now calculates cross-correlations. Thanks to Paul Gilbert. codamenu functions now use title argument in "menu" corrected spelling mistakes in help pages changed instances of "T" and "F" to "TRUE" and "FALSE" (R coding standards) densplot now recognizes discrete distributions and prints histogram ... ... also prints histogram if IQR=0 (large mass on one point) fixed bug in mcmc which allowed non-integer thinning intervals Fixed manual pages with bad use of "alias" command. 0.3-4 Fixed bug in "tspar<-" which breaks much of the code in R-0.62 0.3-3 Package was in obsolete format. Corrected by Fritz. ** Pre-release changes for R version Created class "mcmc" with associated constructor and extractor functions as well as plot, print and summary methods. Modified diagnostics so they all work on objects of class "mcmc" and can be called directly by the user. All diagnostics return objects with associated print methods. Renamed some functions and arguments for ease of use. Changed the menu driven interface - now called by the function "codamenu" - to avoid recursive calling of menu functions. Put frequently used code inside utility functions. Got rid of functions written by Mathsoft Wrote drop-in replacements for some time series functions which are found in S-PLUS but not R. The logfile facility has been removed. Sorry. Changed license terms to GPL. coda/data/0000755000176200001440000000000013507641554012103 5ustar liggesuserscoda/data/line.rda0000644000176200001440000002257713507641554013537 0ustar liggesusersy81fEmJ҆KjPJ(KHBdIZ)H(YRIDlč1f^ {f=;xĸ_}]u^yl8Q(RRR2R8"2i)Y)?}RR8egp㰋o1t?"^/ʪ@ N;dɎ=H֋[o$>mU7gdlGļ4$|كJ6"ɔsf@xav|Dzܔͣ"q*E[$y gF%Rh)xv3»Z5e"\nq>eF{"~-3"`Y?D>ݴFn"<(ϪOpCxƁ+^-A⒉-^Qi/"y8NFxMH`+R"0teѓONVܥr+D7=Dp^U'G鉊ב |$=|-DmZ ={ȱ4!":әdiqXH5x4zDxs]aj=n$eWRٴ2;^Bo-C7kgF+8!~"D4&]5/{T> "GRCg1G#3. BukMR)` "[QR%a%8r*D(GG "^ 8ME+xDr[/OYtUkgzףqdqň`<ف6ÕY*#~ " 0Ae9&"21 Df.ݓWwlG2y[ءq+.uclG$jOstβ~ww"bpZV"HVw6w.G^4ÓUq_63ԣ.["| ??.j#%IFi!iy*yDBWZnXȎ=Uu~~9"ʮ{9\9(e˖[H-ȯEb}Fn!"4dcđ>bzͲZ*"ލԌ8Yk\8uxU$[H{gNF0ei|dZy[G"`Dye2k7s\LPm[6 H ]&?0?vt%D%bIE'qw4%"]'("B vjNk!# cy4>E;|zT;9b;#-|~i~ب,+o^_t19wɾ@ GRl wT,8t5SMn陸⾹ϐziwyKH|t( &7ilFEΎ#ЖԺlIm}xG\eᵳi r; c pX?~;?<&h-  hntj6O'3@'phߏ'(5:|OΛ 5m@-l,ثښZgsh7F}{3u XCLs X7ܠi )ÏsR[hs;9]WeОpO6.{!`e-B#%v*0l _km^Xj~ wݝO,;}..s{;%n n?ƍ#_xӀފ=ĝ0g2RzIk'J– W$zB6 :sG=B53UZnVaPִZIuц0- lӁ񥗠ptV.U \^t_:?lc0DxYEMWUmw.X!p*rsN(w?ƭ>oJbNOGۖ -B;讋 =u|OCkk;Glmr!L%|l:zbFx}.>T ]m7i)m \혵n%tm) 4u>tc뎙N{̚ '_Fբx߯g|xK0>_^dW!-!yйhәv.W}Xi ?wIu;dU#@ŵq5ؒmsxgv;!|Ȩ,w̠wv#6NkwQo8A hkE5 f>UUszLcֻFQ tGhO\RkJ}yж?bxh  譈2ׯ/K?;:/܇!>Á#RE;Tգ ]LC8{TJȱY36.lsAU_y=㳖fUb2J% 5 >\hXhm9{&^9lW3 fDo`-D*L5r q@(}^ xkg<g/;z3 wvhVЭjI(5Nh!0)C8}|i6I'=\}Q 7mf-+yr~$?A5n.,V [D8؏˥䚭ж5l7y@wM@#Zh@]F:PONP7Bk]*m([C/жi X< >C: iIqNMa|!|uڒ &2-[ sc\{`{.OFf WX?.^БCRЦj3t L کf+wDh+dT(PT5\ +5\)[NUBCہFo5:F.Od^{w*PwY<{zs½M;L:D·r6,?ͱ u*[$W [ޙЯ<@&pl RZJR&qcOlOl&C[2$LYXS󁳁gM畆w¡ہ{Xxnew@ \BjkճoKza`|7SB}ᗇc{)0⍙~ѣ}4".z+h|U7a=ö*Zm=Xs:]+BQCh L]a8J5o&&@yZ:6-MsN^hy+{_hs6WT(t>h1Xpz,Wsˍ<'55\h5~"hJC՜x9 {}/ɓ:8>{z)=ZU&?Pe 2aՙy."xXU&j4Ms޳ l@=߽PSw@}];;,z[?kg 5VWK} jYbv~tZ C3Fc%0*s`ГODu??zi'<{29h9qϘD7_FZt30fOAk0[\ ayULa*lK$NcԴ'|iX)ܜg{wlXKeW {AǡrܷW'ZԩJ]6qticǢTJ`j9o3.^0z%U.|JjDHJ~D=T :[A^#NK+#F2"ؼQsÆ.}  (QE$U~#SѸ ʅ`$8򨳋.Ru8+[>"T\g ȔBIC?f6n^ԶdM3x=*iH.,|`DD"RLQ""Q]-@Fv* P® ݛ5#90\-̨{ު!^7KZ{[ ɲ#AtQR I2PC4쳚|Q!0-D=>~1i*DVPط}mo*aahm; fJ,6X GCJ`Q}u*,ƕx7Y)Ni^zq('sY#A˘#"}5*oL6x/.yɕBEρqse>MH*j@8I &Jhz[$?ÖMd-D!qJ5"׳Vr!R{!uK#RuP(Ti+ç)- :qEZ2CxA(Od tBg%"npKWCCE$#;!:o<ZWnMpNFб}U"83= $/׊v'AUhj2d <9;&Y\Ṱ=pDn<Xw͞mȝb: Aed6~pZ`JM`xc}op%4m|Ywv#̚)=j !6Ō0++輜F)42Xg7m:}"뒾;2- nLzӌ^,W. 0YXh~m; U#)'SnG螜tOl^z XΓ۬m,T@PssMq,k-(}`Oу?fBq' ٰ g\:61ۡkq(=9g/>tֵ|e/o۪zSh)NZ >5^wܩfW| zyE7Һn8m L;n2ۀ=@O>ۖխvK4_ 2cF\~{ibnmv{oP'ȯ -3=(ͦWOA(=O|۵Ivm`?wO3zȸy0DHmh.գQ車(3Ѿ- JК;)Y-E. ^/AwkNDzYٔ*蹳`W_uC͖ q&nlZ"?+됃?"]bEqld3EP_%g4%UwTW>v:\ICgWf?hpQtT £u9.> ,d!<]R 8%n(h>xޣ e6mF?aW׌ 왃Jme+ܪT.# y#JB˰|%jEM`J<yL{:+gϤV~¦u.CN\y` mcq!jܮK*v6 Sz˘/7`¨_>f:p"5j5|'}6O,ͮSuXbM8en7^ YǜMm9N׀l˥yrЖ79MDn8 fcC:_%] C_xcQA:xf[^\mдc{mH; lWa~s9(CӪ:^!0 QGX /eYGh]+&E24._V B :DOpͫ]AV\mX%:vˆޟ=˅kB]ʪ@<NVy٠5@ti/XCGSQzH}ö= @03iXKA0co2^S ];q'^4(hƯԊy3:/i{YfCkէRѰu)\އnBIe[Xʣgh,{ 6q"|xQ) _=;mq+=yLo|@;#$vJ_&?6a_ ӣ&A{$۔[eTQwSA")%"ބ 9lgXoYPk犠kT6ECkʓh~@8ߴ~+t/̦z`3:[m fWX,kt?g̝r+ec B,?;Zٖ_T[\^$qRZ,~) gagԗ$2<U`D o=~n4ZGU @|} ԩƝѻ;.=Z/`|MRIދ=PaV6: j mlцn$S.JPL`id`kIzzD}f##DP5$Ӯ!<\H:bQ Dl p=~b7~'[E{#ſz4=\u"bdD,# iگ!aa,ªbJ#hRnkjLb/4 u`K*zh?=';-G=/~%%Q3C7% o 1) { for (chain in 2:length(ac)) { result <- result + ac[[chain]] } } return (result/length(ac)) } coda/R/trellisplots.R0000644000176200001440000004343713343454654014272 0ustar liggesusers ### Copyright (C) 2005 Deepayan Sarkar ### , Douglas Bates ### . See file COPYING for license ### terms. ### unexported helper function to obtain a valid subset argument. ### Mostly to ensure that we don't up with a huge vector of integer ### indices in the trivial cases. thinned.indices <- function(object, n = NROW(object), start = 1, thin = 1) { if (is.mcmc(object) && (start * thin != 1) && !all(mcpar(object)[-2] == 1)) warning("mcmc object is already thinned") if (start < 1) stop("Invalid start") else if (start == 1) { if (thin < 1) stop("Invalid thin") else if (thin == 1) TRUE else rep(c(TRUE, FALSE), c(1, thin-1)) } else { if (thin < 1) stop("Invalid thin") else if (thin == 1) -seq(length = start-1) else start + thin * (0:(floor(n - start) / thin)) } } ## most functions will have methods for mcmc and mcmclist objects. In ## the second case, another grouping variable is added. By default, ## this will be used for ``grouped displays'' (when possible), but ## could also be used for conditioning by setting groups=FALSE ## levelplot, analog of plot.crosscorr. Defaults changed to match ## those of plot.crosscorr as much as possible. levelplot.mcmc <- function(x, data = NULL, main = attr(x, "title"), start = 1, thin = 1, ..., xlab = "", ylab = "", cuts = 10, at = do.breaks(c(-1.001, 1.001), cuts), col.regions = topo.colors(100), subset = thinned.indices(x, start = start, thin = thin)) { if (!is.R()) { stop("This function is not yet available in S-PLUS") } cormat <- cor(x[subset, ]) cormat <- cormat[, rev(seq(length = ncol(cormat)))] levelplot(cormat, main = main, ..., cuts = cuts, at = at, col.regions = col.regions, xlab = xlab, ylab = ylab) } ## the mcmc.list method wouldn't do any grouping (so should have ## outer=TRUE by default). It hasn't been written yet because ## The splom (FIXME: not yet written) method may be more useful ## in progress, unexported. Planning to make it be like levelplot on ## the lower diagonal (maybe ellipses instead of plain boxes) and ## normal splom on the upper diagonal. Not much point in having tick ## marks. Names in the middle save space, unlike in levelplot which ## stupidly shows correlation=1 on the diagonal. splom.mcmc <- function(x, data = NULL, main = attr(x, "title"), start = 1, thin = 1, as.matrix = TRUE, xlab = "", ylab = "", cuts = 10, at = do.breaks(c(-1.001, 1.001), cuts), col.regions = topo.colors(100), ..., pscales = 0, subset = thinned.indices(x, start = start, thin = thin)) { ## cormat <- cor(x[subset, ]) ## cormat <- cormat[, rev(seq(length = ncol(cormat)))] if (!is.R()) { stop("This function is not yet available in S-PLUS") } splom(as.data.frame(x[subset, ]), as.matrix = as.matrix, main = main, ..., pscales = pscales, cuts = cuts, at = at, lower.panel = function(x, y, ...) { corval <- cor(x, y) grid::grid.text(lab = round(corval, 2)) }, col.regions = col.regions, xlab = xlab, ylab = ylab) } ### methods for densityplot (mcmc and mcmc.list) densityplot.mcmc <- function(x, data = NULL, outer, aspect = "xy", default.scales = list(relation = "free"), start = 1, thin = 1, main = attr(x, "title"), xlab = "", plot.points = "rug", ..., subset = thinned.indices(x, start = start, thin = thin)) { if (!is.R()) { stop("This function is not yet available in S-PLUS") } if (!missing(outer)) warning("specification of outer ignored") data <- as.data.frame(x) form <- as.formula(paste("~", paste(lapply(names(data), as.name), collapse = "+"))) ### The following is one possible approach, but it does not generalize ### to mcmclist objects. ## densityplot(form, data = data, ## outer = outer, ## aspect = aspect, ## default.scales = default.scales, ## main = main, ## xlab = xlab, ## plot.points = plot.points, ## subset = eval(subset), ## ...) ### This one does, with the only downside I can think of being that ### subscripts, if used, will give indices in subsetted data, not ### original. But that's true even if the original mcmc object was ### itself already thinned. densityplot(form, data = data[subset, , drop=FALSE], outer = TRUE, aspect = aspect, default.scales = default.scales, main = main, xlab = xlab, plot.points = plot.points, ...) } densityplot.mcmc.list <- function(x, data = NULL, outer = FALSE, groups = !outer, aspect = "xy", default.scales = list(relation = "free"), start = 1, thin = 1, main = attr(x, "title"), xlab = "", plot.points = "rug", ..., subset = thinned.indices(x[[1]], start = start, thin = thin)) { if (!is.R()) { stop("This function is not yet available in S-PLUS") } if (groups && outer) warning("'groups=TRUE' ignored when 'outer=TRUE'") datalist <- lapply(x, function(x) as.data.frame(x)[subset, ,drop=FALSE]) data <- do.call("rbind", datalist) form <- if (outer) as.formula(paste("~", paste(lapply(names(data), as.name), collapse = "+"), "| .run")) ## as.formula(paste("~", ## paste(names(data), ## collapse = "+"), ## "| .run")) else as.formula(paste("~", paste(lapply(names(data), as.name), collapse = "+"))) ## as.formula(paste("~", ## paste(names(data), ## collapse = "+"))) ##data[["index"]] <- seq(length = nrow(x[[1]]))[subset] .run <- gl(length(datalist), nrow(datalist[[1]])) if (groups && !outer) densityplot(form, data = data, outer = TRUE, groups = .run, aspect = aspect, default.scales = default.scales, main = main, xlab = xlab, plot.points = plot.points, ...) else densityplot(form, data = data, outer = TRUE, aspect = aspect, default.scales = default.scales, main = main, xlab = xlab, plot.points = plot.points, ...) } ### methods for qqmath (mcmc and mcmc.list) qqmath.mcmc <- function(x, data = NULL, outer, aspect = "xy", default.scales = list(y = list(relation = "free")), prepanel = prepanel.qqmathline, start = 1, thin = 1, main = attr(x, "title"), ylab = "", ..., subset = thinned.indices(x, start = start, thin = thin)) { if (!is.R()) { stop("This function is not yet available in S-PLUS") } if (!missing(outer)) warning("specification of outer ignored") data <- as.data.frame(x) form <- as.formula(paste("~", paste(lapply(names(data), as.name), collapse = "+"))) qqmath(form, data = data[subset, ,drop=FALSE], outer = TRUE, aspect = aspect, prepanel = prepanel, default.scales = default.scales, main = main, ylab = ylab, ...) } qqmath.mcmc.list <- function(x, data = NULL, outer = FALSE, groups = !outer, aspect = "xy", default.scales = list(y = list(relation = "free")), prepanel = prepanel.qqmathline, start = 1, thin = 1, main = attr(x, "title"), ylab = "", ..., subset = thinned.indices(x[[1]], start = start, thin = thin)) { if (!is.R()) { stop("This function is not yet available in S-PLUS") } if (groups && outer) warning("'groups=TRUE' ignored when 'outer=TRUE'") datalist <- lapply(x, function(x) as.data.frame(x)[subset, , drop=FALSE]) data <- do.call("rbind", datalist) form <- if (outer) as.formula(paste("~", paste(lapply(names(data), as.name), collapse = "+"), "| .run")) else as.formula(paste("~", paste(lapply(names(data), as.name), collapse = "+"))) ##data[["index"]] <- seq(length = nrow(x[[1]]))[subset] ##data[[".run"]] <- gl(length(datalist), nrow(datalist[[1]])) .run <- gl(length(datalist), nrow(datalist[[1]])) if (groups && !outer) qqmath(form, data = data, outer = TRUE, groups = .run, aspect = aspect, prepanel = prepanel, default.scales = default.scales, main = main, ylab = ylab, ...) else qqmath(form, data = data, outer = TRUE, aspect = aspect, default.scales = default.scales, main = main, ylab = ylab, ...) } ### methods for xyplot (mcmc and mcmc.list) xyplot.mcmc <- function(x, data = NULL, outer, layout = c(1, nvar(x)), default.scales = list(y = list(relation = "free")), type = 'l', start = 1, thin = 1, xlab = "Iteration number", ylab = "", main = attr(x, "title"), ..., subset = thinned.indices(x, start = start, thin = thin)) { if (!is.R()) { stop("This function is not yet available in S-PLUS") } if (!missing(outer)) warning("specification of outer ignored") data <- as.data.frame(x) form <- eval(parse(text = paste(paste(lapply(names(data), as.name), collapse = "+"), "~.index"))) data[[".index"]] <- time(x) xyplot(form, data = data[subset, ], outer = TRUE, layout = layout, default.scales = default.scales, type = type, xlab = xlab, ylab = ylab, main = main, ...) } xyplot.mcmc.list <- function(x, data = NULL, outer = FALSE, groups = !outer, aspect = "xy", layout = c(1, nvar(x)), default.scales = list(y = list(relation = "free")), type = 'l', start = 1, thin = 1, xlab = "Iteration number", ylab = "", main = attr(x, "title"), ..., subset = thinned.indices(x[[1]], start = start, thin = thin)) { if (!is.R()) { stop("This function is not yet available in S-PLUS") } if (groups && outer) warning("'groups=TRUE' ignored when 'outer=TRUE'") datalist <- lapply(x, function(x) as.data.frame(x)[subset,,drop=FALSE]) data <- do.call("rbind", datalist) form <- if (outer) eval(parse(text = paste(paste(lapply(names(data), as.name), collapse = "+"), "~.index | .run"))) else eval(parse(text = paste(paste(lapply(names(data), as.name), collapse = "+"), "~.index"))) ## form <- ## if (outer) ## as.formula(paste(paste(names(data), ## collapse = "+"), ## "~ index | .run")) ## else ## as.formula(paste(paste(names(data), ## collapse = "+"), ## "~ index")) data[[".index"]] <- time(x) .run <- gl(length(datalist), nrow(datalist[[1]])) if (groups && !outer) xyplot(form, data = data, outer = TRUE, layout = layout, groups = .run, default.scales = default.scales, type = type, main = main, xlab = xlab, ylab = ylab, ...) else xyplot(form, data = data, outer = TRUE, layout = layout, default.scales = default.scales, type = type, main = main, xlab = xlab, ylab = ylab, ...) } ### methods for acfplot (mcmc and mcmc.list) panel.acfplot <- function(..., groups = NULL) { if (!is.R()) { stop("This function is not yet available in S-PLUS") } reference.line <- trellis.par.get("reference.line") panel.abline(h = 0, col = reference.line$col, lty = reference.line$lty, lwd = reference.line$lwd, alpha = reference.line$alpha) if (is.null(groups)) panel.xyplot(...) else panel.superpose(..., groups = groups) } acfplot <- function(x, data, ...) UseMethod("acfplot") acfplot.mcmc <- function(x, data = NULL, outer, prepanel = function(x, y, ...) list(ylim= c(-1, 1) * max(abs(y[-1]))), panel = panel.acfplot, type = "h", aspect = "xy", start = 1, thin = 1, lag.max = NULL, ylab = "Autocorrelation", xlab = "Lag", main = attr(x, "title"), ..., subset = thinned.indices(x, start = start, thin = thin)) { if (!is.R()) { stop("This function is not yet available in S-PLUS") } if (!missing(outer)) warning("specification of outer ignored") getAcf <- function(x, lag.max) { as.vector(acf(x, lag.max = lag.max, plot = FALSE)$acf) } data <- as.data.frame(apply(as.matrix(x)[subset, ,drop=FALSE], 2, getAcf, lag.max = lag.max)) form <- eval(parse(text = paste(paste(lapply(names(data), as.name), collapse = "+"), "~.lag"))) data[[".lag"]] <- seq(length = nrow(data)) xyplot(form, data = data, outer = TRUE, prepanel = prepanel, panel = panel, type = type, aspect = aspect, xlab = xlab, ylab = ylab, main = main, ...) } acfplot.mcmc.list <- function(x, data = NULL, outer = FALSE, groups = !outer, prepanel = function(x, y, ..., groups = NULL, subscripts) { if (is.null(groups)) list(ylim= c(-1, 1) * max(abs(y[-1]))) else list(ylim = c(-1, 1) * max(sapply(split(y, groups[subscripts]), function(x) max(abs(x[-1]), na.rm = TRUE )))) }, panel = panel.acfplot, type = if (groups) 'b' else 'h', aspect = "xy", start = 1, thin = 1, lag.max = NULL, ylab = "Autocorrelation", xlab = "Lag", main = attr(x, "title"), ..., subset = thinned.indices(x[[1]], start = start, thin = thin)) { if (!is.R()) { stop("This function is not yet available in S-PLUS") } if (groups && outer) warning("'groups=TRUE' ignored when 'outer=TRUE'") getAcf <- function(x, lag.max) { as.vector(acf(x, lag.max = lag.max, plot = FALSE)$acf) } if (groups || outer) { datalist <- lapply(x, function(x) as.data.frame(apply(as.matrix(x)[subset, ,drop=FALSE], 2, getAcf, lag.max = lag.max))) data <- do.call("rbind", datalist) } else { ## this is not quite valid, as we are combining multiple ## series, but shouldn't be too bad (FIXME: should we warn?) datalist <- lapply(x, function(x) as.matrix(x)[subset, ,drop=FALSE]) data <- as.data.frame(apply(do.call("rbind", datalist), 2, getAcf, lag.max = lag.max)) } form <- if (outer) as.formula(paste(paste(lapply(names(data), as.name), collapse = "+"), "~ .lag | .run")) else as.formula(paste(paste(lapply(names(data), as.name), collapse = "+"), "~ .lag")) data[[".lag"]] <- seq(length = nrow(datalist[[1]])) ## repeated .run <- gl(length(datalist), nrow(datalist[[1]])) if (groups && !outer) xyplot(form, data = data, outer = TRUE, groups = .run, prepanel = prepanel, panel = panel, type = type, aspect = aspect, xlab = xlab, ylab = ylab, main = main, ...) else xyplot(form, data = data, outer = TRUE, prepanel = prepanel, panel = panel, type = type, aspect = aspect, xlab = xlab, ylab = ylab, main = main, ...) } coda/R/output.R0000644000176200001440000004116113343454654013062 0ustar liggesusers"autocorr" <- function (x, lags = c(0, 1, 5, 10, 50), relative = TRUE) { ## RGA moved MCMC list processing first, else thinning gets ## applied twice. Thanks to Denise Chang for finding this. if (is.mcmc.list(x)) return(lapply(x, autocorr, lags = lags, relative = relative)) lag.max <- max(lags) if (relative) lags <- lags * thin(x) else if (any(lags%%thin(x) != 0)) stop("Lags do not conform to thinning interval") lags <- lags[lags < niter(x) * thin(x)] x <- as.mcmc(x) y <- array(dim = c(length(lags), nvar(x), nvar(x))) dimnames(y) <- list(paste("Lag", lags), varnames(x), varnames(x)) acf.out <- acf(as.ts.mcmc(x), lag.max = lag.max, plot = FALSE)$acf y[, , ] <- if (is.array(acf.out)) acf.out[lags%/%thin(x) + 1, , ] else acf.out[lags%/%thin(x) + 1] return(y) } "autocorr.plot" <- function (x, lag.max, auto.layout = TRUE, ask, ...) { if (missing(ask)) { ask <- if (is.R()) { dev.interactive() } else { interactive() } } oldpar <- NULL on.exit(par(oldpar)) if (auto.layout) oldpar <- par(mfrow = set.mfrow(Nchains = nchain(x), Nparms = nvar(x))) if (!is.mcmc.list(x)) x <- mcmc.list(as.mcmc(x)) for (i in 1:nchain(x)) { xacf <- if (missing(lag.max)) acf(as.ts.mcmc(x[[i]]), plot = FALSE) else acf(as.ts.mcmc(x[[i]]), lag.max = lag.max, plot = FALSE) for (j in 1:nvar(x)) { plot(xacf$lag[, j, j], xacf$acf[, j, j], type = "h", ylab = "Autocorrelation", xlab = "Lag", ylim = c(-1, 1), ...) title(paste(varnames(x)[j], ifelse(is.null(chanames(x)), "", ":"), chanames(x)[i], sep = "")) if (i==1 && j==1) oldpar <- c(oldpar, par(ask = ask)) } } invisible(x) } "crosscorr" <- function (x) { cor(as.matrix(x)) } "crosscorr.plot" <- function (x, col = topo.colors(10), ...) { Nvar <- nvar(x) pcorr <- crosscorr(x) dens <- ((pcorr + 1) * length(col))%/%2 + (pcorr < 1) + (pcorr < -1) cutoffs <- format(seq(from = 1, to = -1, length = length(col) + 1), digits = 2) leg <- paste("(", cutoffs[-1], ",", cutoffs[-length(cutoffs)], "]", sep = "") oldpar <- NULL on.exit(par(oldpar)) oldpar <- c(par(pty = "s", adj = 0.5), oldpar) plot(0, 0, type = "n", xlim = c(0, Nvar), ylim = c(0, Nvar), xlab = "", ylab = "", xaxt = "n", yaxt = "n", ...) if (!is.R()){ # In S-PLUS, specify that the y-axis labels should be right-justified par(adj = 1) } axis(1, at = 1:Nvar - 0.5, labels = abbreviate(varnames(x, allow.null = FALSE), minlength = 7)) axis(2, at = 1:Nvar - 0.5, labels = abbreviate(varnames(x, allow.null = FALSE), minlength = 7)[Nvar:1]) for (cl in 1:Nvar) { for (rw in 1:(Nvar - cl + 1)) polygon(y = c(cl - 1, cl - 1, cl, cl, cl - 1), x = c(rw - 1, rw, rw, rw - 1, rw - 1), col = col[dens[nrow(dens) - cl + 1, rw]]) } yval <- seq(from = Nvar/2, to = Nvar, length = length(col) + 1) ydelta <- Nvar/(2 * (length(col) + 1)) for (i in 1:length(col)) { polygon(y = c(yval[i], yval[i + 1], yval[i + 1], yval[i], yval[i]), col = col[i], x = c(Nvar - ydelta, Nvar - ydelta, Nvar, Nvar, Nvar - ydelta)) } text(Nvar - ydelta, Nvar, "1", adj = c(1, 1)) text(Nvar - ydelta, 0.5 * Nvar, "-1", adj = c(1, 0)) text(Nvar - ydelta, 0.75 * Nvar, "0", adj = c(1, 0.5)) invisible() } "pretty.discrete" <- function(y, right) { ## Used to created break points for hist() for discrete data. ## Works around some limitations of pretty() for discrete data. ## The acid test is that the histogram produced by densplot for ## discrete data should be visually uniform if the underlying ## discrete distribution is uniform. ybreaks <- pretty(y, nclass.Sturges(y)) yunique <- unique(y) if (length(yunique) == 1) { return(ybreaks) } if (length(ybreaks) > length(yunique)) { ## Pretty puts in too many breaks ybreaks <- sort(yunique) } nb <- length(ybreaks) if (right) { if (max(y) < ybreaks[nb]) { ## Last bin is too wide ybreaks[nb] <- max(y) } if (min(y) > ybreaks[1]) { ## First bin is too wide ybreaks[1] <- min(y) - 1 } else if (min(y) == ybreaks[1]) { ## The hist() function adds some fuzz to its break ## points causing the first two categories to be ## merged. Work around this by adding extra ## breakpoints on the left. ybreaks <- c(ybreaks[1] - 1, ybreaks) } } else { if (min(y) > ybreaks[1]) { ## First bin is too wide ybreaks[1] <- min(y) } if (max(y) < ybreaks[nb]) { ## Last bin is too wide ybreaks[nb] <- max(y) + 1 } else if (max(y) == ybreaks[nb]) { ## The hist() function adds some fuzz to its break ## points causing the first two categories to be ## merged. Work around this by adding extra ## breakpoints on the left. ybreaks <- c(ybreaks[nb] + 1, ybreaks) } } ybreaks } "densplot" <- function (x, show.obs = TRUE, bwf, ylim, xlab, ylab = "", type = "l", main, right=TRUE, ...) { xx <- as.matrix(x) for (i in 1:nvar(x)) { y <- xx[, i, drop = TRUE] if (missing(bwf)) bwf <- function(x) { x <- x[!is.na(as.vector(x))] return(1.06 * min(sd(x), IQR(x)/1.34) * length(x)^-0.2) } bw <- bwf(y) width <- 4 * bw ## Override the default main titles generated by histogram and ## plot.density main.par <- if (missing(main)) { ## Suppress default title given by plot.density if (is.null(varnames(x))) "" else paste("Density of", varnames(x)[i]) } else main if (max(abs(y - floor(y))) == 0 || bw == 0 || length(unique(y)) == 1) { ## Draw histogram for discrete data or constant data or if ## bandwidth is zero. ybreaks <- pretty.discrete(y, right) ## Set default values for graphical parameters if (missing(xlab)) { xlab <- "" } if (missing(ylim)) { ylim.par <- NULL } yhist <- hist(y, breaks=ybreaks, right=right, plot=FALSE) plot(yhist, xlab=xlab, ylab=ylab, ylim=ylim.par, main=main.par, xaxt="n", freq=FALSE, ...) axis(side=1, at=ybreaks) } else { ## Draw density plot ## Reflect data at boundary, if necessary scale <- "open" if (max(y) <= 1 && 1 - max(y) < 2 * bw) { if (min(y) >= 0 && min(y) < 2 * bw) { scale <- "proportion" y <- c(y, -y, 2 - y) } } else if (min(y) >= 0 && min(y) < 2 * bw) { scale <- "positive" y <- c(y, -y) } else scale <- "open" dens <- density(y, width = width) if (scale == "proportion") { dens$y <- 3 * dens$y[dens$x >= 0 & dens$x <= 1] dens$x <- dens$x[dens$x >= 0 & dens$x <= 1] } else if (scale == "positive") { dens$y <- 2 * dens$y[dens$x >= 0] dens$x <- dens$x[dens$x >= 0] } ## Set default graphics parameters ylim.par <- if (missing(ylim)) NULL else ylim xlab.par <- if (missing(xlab)) { if (is.R()) { paste("N =", niter(x), " Bandwidth =", formatC(dens$bw)) } else { ##In S-PLUS the bandwidth is not returned by the ##"density" function paste("N =", niter(x), " Bandwidth =", formatC(bw)) } } else xlab plot(dens, xlab=xlab.par, ylab = ylab, type = type, ylim = ylim.par, main = main.par, ...) if (show.obs) { lines(y[1:niter(x)], rep(max(dens$y)/100, niter(x)), type = "h") } } } return(invisible(x)) } if (!is.R()){ "IQR"<- function(x, na.rm = FALSE) diff(quantile(as.numeric(x), c(0.25, 0.75), na.rm = na.rm)) } "read.jags" <- function (file = "jags.out", start, end, thin, quiet=FALSE) { nc <- nchar(file) if (nc > 3 && substring(file, nc - 3, nc) == ".out") root <- substring(file, 1, nc - 4) else root <- file index.file = paste(root, ".ind", sep="") read.coda(file, index.file, start, end, thin, quiet) } "read.openbugs" <- function (stem = "", start, end, thin, quiet = FALSE) { index.file <- paste(stem, "CODAindex.txt", sep = "") if (!file.exists(index.file)) stop("No index file found") index.date <- file.info(index.file)$ctime nchain <- 0 while (TRUE) { output.file <- paste(stem, "CODAchain", nchain + 1, ".txt", sep = "") if (file.exists(output.file)) { nchain <- nchain + 1 output.date <- file.info(output.file)$ctime dt <- difftime(index.date, output.date, units="mins") if(abs(as.numeric(dt)) > 1 ) { warning(paste("Files \"",index.file,"\" and \"",output.file, "\" were created at different times\n",sep="")) } } else break } if (nchain == 0) stop("No output files found") ans <- vector("list", nchain) for (i in 1:nchain) { output.file <- paste(stem, "CODAchain", i, ".txt", sep = "") ans[[i]] <- read.coda(output.file, index.file, start, end, thin, quiet) } return(mcmc.list(ans)) } "read.coda" <- function (output.file, index.file, start, end, thin,quiet=FALSE) { index <- read.table(index.file, row.names = 1, col.names = c("", "begin", "end")) vnames <- row.names(index) if (is.R()) { temp <- scan(output.file, what = list(iter = 0, val = 0), quiet = TRUE) } else { temp <- scan(output.file, what = list(iter = 0, val = 0)) } ## Do one pass through the data to see if we can construct ## a regular time series easily ## start.vec <- end.vec <- thin.vec <- numeric(nrow(index)) for (i in 1:length(vnames)) { iter.i <- temp$iter[index[i, "begin"]:index[i, "end"]] thin.i <- unique(diff(iter.i)) thin.vec[i] <- if (length(thin.i) == 1) thin.i else NA start.vec[i] <- iter.i[1] end.vec[i] <- iter.i[length(iter.i)] } if (any(is.na(start.vec)) || any(thin.vec != thin.vec[1]) || any((start.vec - start.vec[1])%%thin.vec[1] != 0)) { ## ## Do it the brute force way ## iter <- sort(unique(temp$iter)) old.thin <- unique(diff(iter)) if (length(old.thin) == 1) is.regular <- TRUE else { if (all(old.thin%%min(old.thin) == 0)) old.thin <- min(old.thin) else old.thin <- 1 is.regular <- FALSE } } else { iter <- seq(from = min(start.vec), to = max(end.vec), by = thin.vec[1]) old.thin <- thin.vec[1] is.regular <- TRUE } if (missing(start)) start <- min(start.vec) else if (start < min(start.vec)) { warning("start not changed") start <- min(start.vec) } else if (start > max(end.vec)) stop("Start after end of data") else iter <- iter[iter >= start] if (missing(end)) end <- max(end.vec) else if (end > max(end.vec)) { warning("end not changed") end <- max(end.vec) } else if (end < min(start.vec)) stop("End before start of data") else iter <- iter[iter <= end] if (missing(thin)) thin <- old.thin else if (thin%%old.thin != 0) { thin <- old.thin warning("thin not changed") } else { new.iter <- iter[(iter - start)%%thin == 0] new.thin <- unique(diff(new.iter)) if (length(new.thin) != 1 || new.thin != thin) warning("thin not changed") else { iter <- new.iter end <- max(iter) is.regular <- TRUE } } out <- matrix(NA, nrow = length(iter), ncol = nrow(index)) dimnames(out) <- list(iter, vnames) for (v in vnames) { if(!quiet) cat("Abstracting", v, "... ") inset <- index[v, "begin"]:index[v, "end"] iter.v <- temp$iter[inset] if (!is.regular) { use.v <- duplicated(c(iter, iter.v))[-(1:length(iter))] use <- duplicated(c(iter.v, iter))[-(1:length(iter.v))] } else { use.v <- (iter.v - start)%%thin == 0 & iter.v >= start & iter.v <= end use <- (iter.v[use.v] - start)%/%thin + 1 } if (length(use) > 0 && any(use.v)) out[use, v] <- temp$val[inset[use.v]] if(!quiet) cat(length(use), "valid values\n") } if (is.regular) out <- mcmc(out, start = start, end = end, thin = thin) else warning("not returning an mcmc object") return(out) } "traceplot" <- function (x, smooth = FALSE, col = 1:6, type = "l", xlab = "Iterations", ylab = "", ...) { x <- mcmc.list(x) args <- list(...) for (j in 1:nvar(x)) { xp <- as.vector(time(x)) yp <- if (nvar(x) > 1) x[, j, drop = TRUE] else x yp <- do.call("cbind", yp) matplot(xp, yp, xlab = xlab, ylab = ylab, type = type, col = col, ...) if (!is.null(varnames(x)) && is.null(list(...)$main)) title(paste("Trace of", varnames(x)[j])) if (smooth) { scol <- rep(col, length = nchain(x)) for (k in 1:nchain(x)) lines(lowess(xp, yp[, k]), col = scol[k]) } } } "plot.mcmc" <- function (x, trace = TRUE, density = TRUE, smooth = FALSE, bwf, auto.layout = TRUE, ask = dev.interactive(), ...) { oldpar <- NULL on.exit(par(oldpar)) if (auto.layout) { mfrow <- set.mfrow(Nchains = nchain(x), Nparms = nvar(x), nplots = trace + density) oldpar <- par(mfrow = mfrow) } for (i in 1:nvar(x)) { y <- mcmc(as.matrix(x)[, i, drop=FALSE], start(x), end(x), thin(x)) if (trace) ## RGA fixed to propagate ... argument. traceplot(y, smooth = smooth, ...) if (density) { if (missing(bwf)) ## RGA fixed to propagate ... argument. densplot(y, ...) else densplot(y, bwf = bwf, ...) } if (i==1) oldpar <- c(oldpar, par(ask=ask)) } } ### RGA This is a wrapper for spectrum0 which returns NA if ### spectrum0 crashes. This has happened to me several times when ### there was bug in my MCMC algorithm. "safespec0" <- function (x) { result <- try(spectrum0.ar(x)$spec) ## R if (class(result) == "try-error") result <- NA ## S-Plus if (class(result) == "try") result <- NA result } "summary.mcmc" <- function (object, quantiles = c(0.025, 0.25, 0.5, 0.75, 0.975), ...) { x <- as.mcmc(object) statnames <- c("Mean", "SD", "Naive SE", "Time-series SE") varstats <- matrix(nrow = nvar(x), ncol = length(statnames), dimnames = list(varnames(x), statnames)) ## RGA replaced with safespec0 #sp0 <- function(x) spectrum0(x)$spec if (is.matrix(x)) { xmean <- apply(x, 2, mean) xvar <- apply(x, 2, var) xtsvar <- apply(x, 2, safespec0) varquant <- t(apply(x, 2, quantile, quantiles)) } else { xmean <- mean(x, na.rm = TRUE) xvar <- var(x, na.rm = TRUE) xtsvar <- safespec0(x) varquant <- quantile(x, quantiles) } varstats[, 1] <- xmean varstats[, 2] <- sqrt(xvar) varstats[, 3] <- sqrt(xvar/niter(x)) varstats[, 4] <- sqrt(xtsvar/niter(x)) varstats <- drop(varstats) varquant <- drop(varquant) out <- list(statistics = varstats, quantiles = varquant, start = start(x), end = end(x), thin = thin(x), nchain = 1) if (is.R()) { class(out) <- "summary.mcmc" } else { oldClass(out) <- "summary.mcmc" } return(out) } "print.summary.mcmc" <- function (x, digits = max(3, .Options$digits - 3), ...) { cat("\n", "Iterations = ", x$start, ":", x$end, "\n", sep = "") cat("Thinning interval =", x$thin, "\n") cat("Number of chains =", x$nchain, "\n") cat("Sample size per chain =", (x$end - x$start)/x$thin + 1, "\n") cat("\n1. Empirical mean and standard deviation for each variable,") cat("\n plus standard error of the mean:\n\n") print(x$statistics, digits = digits, ...) cat("\n2. Quantiles for each variable:\n\n") print(x$quantiles, digits = digits, ...) cat("\n") invisible(x) } coda/R/gelman.R0000644000176200001440000002061513343454654012766 0ustar liggesusers"gelman.diag" <- function (x, confidence = 0.95, transform = FALSE, autoburnin=TRUE, multivariate=TRUE) ## Gelman and Rubin's diagnostic ## Gelman, A. and Rubin, D (1992). Inference from iterative simulation ## using multiple sequences. Statistical Science, 7, 457-551. ## ## Correction and Multivariate generalization: ## Brooks, S.P. and Gelman, A. (1997) General methods for monitoring ## convergence of iterative simulations. Journal of Computational and ## Graphical Statistics, 7, 434-455. { x <- as.mcmc.list(x) if (nchain(x) < 2) stop("You need at least two chains") ## RGA added an autoburnin parameter here, because if I have already ## trimmed burn in, I don't want to do it again. if (autoburnin && start(x) < end(x)/2 ) x <- window(x, start = end(x)/2 + 1) Niter <- niter(x) Nchain <- nchain(x) Nvar <- nvar(x) xnames <- varnames(x) if(transform) x <- gelman.transform(x) ## ## Estimate mean within-chain variance (W) and between-chain variance ## (B/Niter), and calculate sampling variances and covariance of the ## estimates (varW, varB, covWB) ## ## Multivariate (upper case) x <- lapply(x, as.matrix) S2 <- array(sapply(x, var, simplify=TRUE), dim=c(Nvar,Nvar,Nchain)) W <- apply(S2, c(1,2), mean) xbar <- matrix(sapply(x, apply, 2, mean, simplify=TRUE), nrow=Nvar, ncol=Nchain) B <- Niter * var(t(xbar)) if(Nvar > 1 && multivariate) { ## We want the maximal eigenvalue of the square matrix X that ## solves WX = B. It is numerically easier to work with a ## symmetric matrix that has the same eigenvalues as X. if (is.R()) { CW <- chol(W) emax <- eigen(backsolve(CW, t(backsolve(CW, B, transpose=TRUE)), transpose=TRUE), symmetric=TRUE, only.values=TRUE)$values[1] } else { emax <- eigen(qr.solve(W,B), symmetric=FALSE, only.values=TRUE)$values } mpsrf <- sqrt( (1 - 1/Niter) + (1 + 1/Nvar) * emax/Niter ) } else mpsrf <- NULL ## Univariate (lower case) w <- diag(W) b <- diag(B) s2 <- matrix(apply(S2, 3, diag), nrow=Nvar, ncol=Nchain) muhat <- apply(xbar,1,mean) var.w <- apply(s2, 1, var)/Nchain var.b <- (2 * b^2)/(Nchain - 1) cov.wb <- (Niter/Nchain) * diag(var(t(s2), t(xbar^2)) - 2 * muhat * var(t(s2), t(xbar))) ## ## Posterior interval combines all uncertainties in a t interval with ## center muhat, scale sqrt(V), and df.V degrees of freedom. ## V <- (Niter - 1) * w / Niter + (1 + 1/Nchain) * b/ Niter var.V <- ((Niter - 1)^2 * var.w + (1 + 1/Nchain)^2 * var.b + 2 * (Niter - 1) * (1 + 1/Nchain) * cov.wb)/Niter^2 df.V <- (2 * V^2)/var.V ## ## Potential scale reduction factor (that would be achieved by ## continuing simulations forever) is estimated by ## R = sqrt(V/W) * df.adj ## where df.adj is a degrees of freedom adjustment for the width ## of the t-interval. ## ## To calculate upper confidence interval we divide R2 = R^2 into two ## parts, fixed and random. The upper limit of the random part is ## calculated assuming that B/W has an F distribution. ## df.adj <- (df.V + 3)/(df.V + 1) B.df <- Nchain - 1 W.df <- (2 * w^2)/var.w R2.fixed <- (Niter - 1)/Niter R2.random <- (1 + 1/Nchain) * (1/Niter) * (b/w) R2.estimate <- R2.fixed + R2.random R2.upper <- R2.fixed + qf((1 + confidence)/2, B.df, W.df) * R2.random psrf <- cbind(sqrt(df.adj * R2.estimate), sqrt(df.adj * R2.upper)) dimnames(psrf) <- list(xnames, c("Point est.", "Upper C.I.")) out <- list(psrf = psrf, mpsrf=mpsrf) class(out) <- "gelman.diag" out } "gelman.transform" <- function(x) ## Gelman and Rubin diagnostic assumes a normal distribution. To ## improve the normal approximation, variables on [0, Inf) are log ## transformed, and variables on [0,1] are logit-transformed. { if (!is.R()) { # in S-PLUS this function generates a superfluous warning, # so turn off all warnings during the function. oldWarn <- getOption("warn") options(warn=-1) on.exit(options (warn=oldWarn)) } if (nvar(x) == 1) { z <- data.frame(lapply(x, unclass)) if (min(z) > 0) { y <- if(max(z) < 1) log(z/(1-z)) else log(z) for (j in 1:nchain(x)) x[[j]] <- y[,j] } } else for (i in 1:nvar(x)) { z <- data.frame(lapply(x[, i], unclass)) if (min(z) > 0) { y <- if (max(z) < 1) log(z/(1 - z)) else log(z) for (j in 1:nchain(x)) x[[j]][, i] <- y[, j] } } return(x) } "gelman.mv.diag" <- function (x, confidence = 0.95, transform = FALSE) { s2 <- sapply(x, var, simplify=TRUE) W <- matrix(apply(s2, 1, mean), nvar(x), nvar(x)) xbar <- sapply(x, apply, 2, mean, simplify=TRUE) B <- niter(x) * var(t(xbar)) emax <- eigen(qr.solve(W,B), symmetric=FALSE, only.values=TRUE)$values[1] mpsrf <- sqrt( (1 - 1/niter(x)) + (1 + 1/nvar(x)) * emax ) return(mpsrf) } "print.gelman.diag" <- function (x, digits = 3, ...) { cat("Potential scale reduction factors:\n\n") print.default(x$psrf, digits = digits, ...) if(!is.null(x$mpsrf)) { cat("\nMultivariate psrf\n\n") cat(format(x$mpsrf,digits = digits)) } cat("\n") } "gelman.plot" <- function (x, bin.width = 10, max.bins = 50, confidence = 0.95, transform = FALSE, autoburnin = TRUE, auto.layout = TRUE, ask, col = 1:2, lty = 1:2, xlab = "last iteration in chain", ylab = "shrink factor", type = "l", ...) { if (missing(ask)) { ask <- if (is.R()) { dev.interactive() } else { interactive() } } x <- as.mcmc.list(x) oldpar <- NULL on.exit(par(oldpar)) if (auto.layout) oldpar <- par(mfrow = set.mfrow(Nchains = nchain(x), Nparms = nvar(x))) y <- gelman.preplot(x, bin.width = bin.width, max.bins = max.bins, confidence = confidence, transform = transform, autoburnin = autoburnin) all.na <- apply(is.na(y$shrink[, , 1, drop = FALSE]), 2, all) if (!any(all.na)) for (j in 1:nvar(x)) { matplot(y$last.iter, y$shrink[, j, ], col = col, lty = lty, xlab = xlab, ylab = ylab, type = type, ...) abline(h = 1) ymax <- max(c(1, y$shrink[, j, ]), na.rm = TRUE) leg <- dimnames(y$shrink)[[3]] xmax <- max(y$last.iter) legend(xmax, ymax, legend = leg, lty = lty, bty = "n", col = col, xjust = 1, yjust = 1) title(main = varnames(x)[j]) if (j==1) oldpar <- c(oldpar, par(ask = ask)) } return(invisible(y)) } "gelman.preplot" <- function (x, bin.width = bin.width, max.bins = max.bins, confidence = confidence, transform = transform, autoburnin = autoburnin) { x <- as.mcmc.list(x) nbin <- min(floor((niter(x) - 50)/thin(x)), max.bins) if (nbin < 1) { stop("Insufficient iterations to produce Gelman-Rubin plot") } binw <- floor((niter(x) - 50)/nbin) last.iter <- c(seq(from = start(x) + 50 * thin(x), by = binw * thin(x), length = nbin), end(x)) shrink <- array(dim = c(nbin + 1, nvar(x), 2)) dimnames(shrink) <- list(last.iter, varnames(x), c("median", paste(50 * (confidence + 1), "%", sep = "")) ) for (i in 1:(nbin + 1)) { shrink[i, , ] <- gelman.diag(window(x, end = last.iter[i]), confidence = confidence, transform = transform, autoburnin = autoburnin, multivariate = FALSE)$psrf } all.na <- apply(is.na(shrink[, , 1, drop = FALSE]), 2, all) if (any(all.na)) { cat("\n******* Error: *******\n") cat("Cannot compute Gelman & Rubin's diagnostic for any chain \n") cat("segments for variables", varnames(x)[all.na], "\n") cat("This indicates convergence failure\n") } return(list(shrink = shrink, last.iter = last.iter)) } if (!is.R()){ qr.solve <- function (a, b, tol = 1e-07) { if (!is.qr(a)) a <- qr(a, tol = tol) nc <- ncol(a$qr) if (a$rank != nc) stop("singular matrix 'a' in solve") if (missing(b)) { if (nc != nrow(a$qr)) stop("only square matrices can be inverted") b <- diag(1, nc) } return(qr.coef(a, b)) } } coda/R/geweke.R0000644000176200001440000000571213343454654012773 0ustar liggesusers"geweke.diag" <- function (x, frac1 = 0.1, frac2 = 0.5) { if (frac1 < 0 || frac1 > 1) { stop("frac1 invalid") } if (frac2 < 0 || frac2 > 1) { stop("frac2 invalid") } if (frac1 + frac2 > 1) { stop("start and end sequences are overlapping") } if (is.mcmc.list(x)) { return(lapply(x, geweke.diag, frac1, frac2)) } x <- as.mcmc(x) xstart <- c(start(x), floor(end(x) - frac2 * (end(x) - start(x)))) xend <- c(ceiling(start(x) + frac1 * (end(x) - start(x))), end(x)) y.variance <- y.mean <- vector("list", 2) for (i in 1:2) { y <- window(x, start = xstart[i], end = xend[i]) y.mean[[i]] <- apply(as.matrix(y), 2, mean) y.variance[[i]] <- spectrum0.ar(y)$spec/niter(y) } z <- (y.mean[[1]] - y.mean[[2]])/sqrt(y.variance[[1]] + y.variance[[2]]) out <- list(z = z, frac = c(frac1, frac2)) class(out) <- "geweke.diag" return(out) } "geweke.plot" <- function (x, frac1 = 0.1, frac2 = 0.5, nbins = 20, pvalue = 0.05, auto.layout = TRUE, ask, ...) { if (missing(ask)) { ask <- if (is.R()) { dev.interactive() } else { interactive() } } x <- as.mcmc.list(x) oldpar <- NULL on.exit(par(oldpar)) if (auto.layout) oldpar <- par(mfrow = set.mfrow(Nchains = nchain(x), Nparms = nvar(x))) ystart <- seq(from = start(x), to = (start(x) + end(x))/2, length = nbins) if (is.R()) gcd <- array(dim = c(length(ystart), nvar(x), nchain(x)), dimnames = list(ystart, varnames(x), chanames(x))) else gcd <- array(dim = c(length(ystart), nvar(x), nchain(x)), dimnames = list(ystart, varnames(x), chanames(x))) for (n in 1:length(ystart)) { geweke.out <- geweke.diag(window(x, start = ystart[n]), frac1 = frac1, frac2 = frac2) for (k in 1:nchain(x)) gcd[n, , k] <- geweke.out[[k]]$z } climit <- qnorm(1 - pvalue/2) for (k in 1:nchain(x)) for (j in 1:nvar(x)) { ylimit <- max(c(climit, abs(gcd[, j, k]))) plot(ystart, gcd[, j, k], type = "p", xlab = "First iteration in segment", ylab = "Z-score", pch = 4, ylim = c(-ylimit, ylimit), ...) abline(h = c(climit, -climit), lty = 2) if (nchain(x) > 1) { title(main = paste(varnames(x, allow.null = FALSE)[j], " (", chanames(x, allow.null = FALSE)[k], ")", sep = "")) } else { title(main = paste(varnames(x, allow.null = FALSE)[j], sep = "")) } if (k==1 && j==1) oldpar <- c(oldpar, par(ask = ask)) } invisible(list(start.iter = ystart, z = gcd)) } "print.geweke.diag" <- function (x, digits = min(4, .Options$digits), ...) ## Print method for output from geweke.diag { cat("\nFraction in 1st window =", x$frac[1]) cat("\nFraction in 2nd window =", x$frac[2], "\n\n") print.default(x$z, digits = digits, ...) cat("\n") invisible(x) } coda/R/jags.R0000644000176200001440000000160613343454654012446 0ustar liggesusers"read.jags" <- function (file = "jags.out", start, end, thin, quiet=FALSE) { if (!is.R()) { stop("This function is not yet available in S-PLUS") } read.coda(file, start, end, thin, quiet) } bugs2jags <- function(infile, outfile) { if (!is.R()) { stop("This function is not yet available in S-PLUS") } ## Convert S-style data for WinBUGS into the R dump format ## used by JAGS. bugs.dat <- dget(infile) for (bugs.variable.name in names(bugs.dat)) { if(!is.null(dim(bugs.dat[[bugs.variable.name]]))) { ## Manually reverse order of dimensions of arrays dim(bugs.dat[[bugs.variable.name]]) <- rev(dim(bugs.dat[[bugs.variable.name]])) ## Then transpose bugs.dat[[bugs.variable.name]] <- aperm(bugs.dat[[bugs.variable.name]]) } assign(bugs.variable.name, bugs.dat[[bugs.variable.name]]) } dump(names(bugs.dat), file=outfile) } coda/R/rejectionRate.R0000644000176200001440000000042413343454654014315 0ustar liggesusersrejectionRate.mcmc <- function (x) { x <- as.matrix(x) apply(x[-nrow(x),,drop=FALSE] == x[-1,, drop=FALSE],2,mean) } rejectionRate.mcmc.list <- function (x) { apply(sapply(x,rejectionRate.mcmc),1,mean) } rejectionRate <- function(x) { UseMethod("rejectionRate") } coda/R/batchSE.R0000644000176200001440000000334713343454654013037 0ustar liggesusers "batchSE" <- function(x,batchSize=100) { UseMethod("batchSE") } "batchSE.mcmc" <- function(x,batchSize=100) { niter <- niter(x) nbatch <- niter%/%batchSize ## Truncate the odd lot observations ## Do this off the front instead of the back?? niter <- nbatch*batchSize ibatch <- rep(1:nbatch,each=batchSize)[1:niter] batchMeans <- t(sapply(split(data.frame(x[1:niter,]),ibatch), function(batch) apply(batch,2,mean))) grandMean <- apply(batchMeans,2,mean) mi2 <- sweep(batchMeans,2,grandMean,"-")^2 stds<-sqrt(apply(mi2,2,sum)*batchSize/(nbatch-1)) names(stds) <- dimnames(x)[[2]] stds/sqrt(niter(x)) } "batchSE.mcmc.list" <- function(x,batchSize=100) { nchain <- nchain(x) niter <- niter(x) nbatch <- niter%/%batchSize ## truncate odd lot observations niter <- nbatch*batchSize ibatch <- rep(1:nbatch,each=batchSize)[1:niter] batchMeans <- NULL for (i in 1:nchain) { batchMeans <- rbind(batchMeans, t(sapply(split(data.frame(x[[i]][1:niter,]),ibatch), function(batch) apply(batch,2,mean)))) } #print(batchMeans) grandMean <- apply(batchMeans,2,mean) #cat("Grand Mean = ",grandMean,"\n") mi2 <- sweep(batchMeans,2,grandMean,"-")^2 stds<-sqrt(apply(mi2,2,sum)*batchSize/(nchain*nbatch-1)) names(stds) <- dimnames(x[[1]])[[2]] stds/sqrt(niter(x)*nchain(x)) } ## Needed for this function, but generally useful anyway. as.data.frame.mcmc <- function(x, row.names = NULL, optional=FALSE, ...) { if (is.matrix(x)) as.data.frame.matrix(x,row.names,optional, ...) else { if (is.null(row.names)) row.names <- time(x) data.frame("var1"=as.numeric(x), row.names=row.names) } } coda/R/codamenu.R0000644000176200001440000007754713343454654013336 0ustar liggesusers"codamenu" <- function () { coda.options(default=TRUE) file.menu <- c("Read BUGS output files", "Use an mcmc object", "Quit") pick <- menu(file.menu, title = "CODA startup menu") if (pick == 0 || pick == 3) return(invisible()) else if (pick == 1) { coda.dat <- read.coda.interactive() if (is.null(coda.dat)) { return(invisible()) } } else if (pick == 2) { msg <- "\nEnter name of saved object (or type \"exit\" to quit)" repeat { cat(msg, "\n") outname <- read.and.check(what = character()) if (outname == "exit" || outname == "\"exit\"") { return(invisible()) } else if (!exists(outname)) msg <- "Can't find this object" else { coda.dat <- eval(parse(text = outname)) if (is.mcmc(coda.dat)) { coda.dat <- mcmc.list(coda.dat) } if (!is.mcmc.list(coda.dat)) { msg <- "Not an mcmc or mcmc.list object" } else { break } } } } else stop("Invalid option") if (is.null(chanames(coda.dat))) { chanames(coda.dat) <- chanames(coda.dat, allow.null = FALSE) } if (is.matrix(coda.dat[[1]]) && is.null(varnames(coda.dat))) { varnames(coda.dat) <- varnames(coda.dat, allow.null = FALSE) } ## Check for variables that are linear functions of the ## iteration number is.linear <- rep(FALSE, nvar(coda.dat)) for (i in 1:nchain(coda.dat)) { for (j in 1:nvar(coda.dat)) { lm.out <- lm(as.matrix(coda.dat[[i]])[,j] ~ time(coda.dat)) if (identical(all.equal(sd(residuals(lm.out)), 0), TRUE)) { is.linear[j] <- TRUE } } } if (any(is.linear)) { cat("Dropping the following variables, which are linear\n") cat("functions of the iteration number\n") print(varnames(coda.dat)[is.linear]) inset <- varnames(coda.dat)[!is.linear] coda.dat <- coda.dat[, inset, drop=FALSE] } ## Sample size test cat("Checking effective sample size ...") ess <- lapply(gelman.transform(coda.dat), effectiveSize) warn.small <- FALSE for (i in 1:length(ess)) { if (any(ess[[i]] < 200)) warn.small <- TRUE } if (warn.small) { cat("\n") cat("*******************************************\n") cat("WARNING !!! \n") cat("Some variables have an effective sample \n") cat("size of less than 200 in at least one \n") cat("chain. \n") cat("This is too small, and may cause errors \n") cat("in the diagnostic tests \n") cat("HINT: \n") cat("Look at plots first to identify variables\n") cat("with slow mixing. (Choose menu Output \n") cat("Analysis then Plots) \n") cat("Re-run your chain with a larger sample \n") cat("size and thinning interval. If possible, \n") cat("reparameterize your model to improve mixing\n") cat("*******************************************\n") } else { cat("OK\n") } current.menu <- "codamenu.main" old.opt <- options(warn=-1, show.error.messages=FALSE) on.exit(options(old.opt)) ## Create working data, a subset of coda.dat work.dat <- coda.dat repeat { next.menu <- try(do.call(current.menu, list(work.dat, coda.dat))) if (!is.null(class(next.menu)) && class(next.menu) == "try-error") { if (current.menu == "codamenu.main") { cat("A crash has occurred in the main menu\nBailing out\n") return(invisible()); } else { cat("\n\n") cat("**********************\n") cat("An error has occurred\n") cat("Returning to main menu\n") cat("**********************\n") current.menu <- "codamenu.main" } } else { if (is.list(next.menu) && !is.null(next.menu[["work.dat"]])) { work.dat <- next.menu$work.dat next.menu <- next.menu[[1]] } if (next.menu == "quit") { if(read.yesno("Are you sure you want to quit", FALSE)) break } else current.menu <- next.menu } } invisible() } "codamenu.anal" <- function (work.dat, ...) { next.menu <- "codamenu.anal" choices <- c("Plots", "Statistics", "List/Change Options", "Return to Main Menu") next.menu.list <- c("plots", "summary", "codamenu.options", "codamenu.main") cat("\n") pick <- menu(choices, title = "CODA Output Analysis menu") if (pick == 0) next.menu <- "quit" else if (next.menu.list[pick] == "summary") { if (coda.options("combine.stats")) { print(summary(work.dat, quantiles = coda.options("quantiles"), digits = coda.options("digits"))) } else for (i in 1:nchain(work.dat)) { cat(chanames(work.dat, allow.null = FALSE)[i], "\n") print(summary(work.dat[[i]], quantiles = coda.options("quantiles"), digits = coda.options("digits"))) } } else if (next.menu.list[pick] == "plots") { auto.layout <- !coda.options("user.layout") ask <- TRUE repeat { if (coda.options("combine.plots")) plot(work.dat, trace = coda.options("trace"), density = coda.options("densplot"), smooth = coda.options("lowess"), auto.layout = auto.layout, bwf = coda.options("bandwidth"), combine.chains = !coda.options("combine.plots"), ask = ask) else for (i in 1:nchain(work.dat)) { plot(work.dat[[i]], trace = coda.options("trace"), density = coda.options("densplot"), smooth = coda.options("lowess"), auto.layout = auto.layout, bwf = coda.options("bandwidth"), combine.chains = coda.options("combine.plots"), ask = ask) } codamenu.ps() if (names(dev.cur()) == "postscript") ask <- FALSE else break } } else next.menu <- next.menu.list[pick] return(next.menu) } "codamenu.diags" <- function (work.dat, ...) { next.menu <- "diags" while (next.menu == "diags") { choices <- c("Geweke", "Gelman and Rubin", "Raftery and Lewis", "Heidelberger and Welch", "Autocorrelations", "Cross-Correlations", "List/Change Options", "Return to Main Menu") next.menu.list <- c("codamenu.diags.geweke", "codamenu.diags.gelman", "codamenu.diags.raftery", "codamenu.diags.heidel", "codamenu.diags.autocorr", "codamenu.diags.crosscorr", "codamenu.options", "codamenu.main") pick <- menu(choices, title = "CODA Diagnostics Menu") if (pick == 0) return("quit") else next.menu <- next.menu.list[pick] } return(next.menu) } "codamenu.diags.autocorr" <- function (work.dat, ...) { next.menu <- "codamenu.diags" codamenu.output.header("AUTOCORRELATIONS WITHIN EACH CHAIN:", work.dat) print(autocorr(work.dat), digits = coda.options("digits")) choices <- c("Plot autocorrelations", "Return to Diagnostics Menu") pick <- menu(choices, title = "Autocorrelation Plots Menu") if (pick == 0) next.menu <- "quit" else if (pick == 1) { ask <- TRUE repeat { autocorr.plot(work.dat, auto.layout = !coda.options("user.layout"), ask = ask) codamenu.ps() if (names(dev.cur()) == "postscript") ask <- FALSE else break } } return(next.menu) } "codamenu.diags.crosscorr" <- function (work.dat, ...) { next.menu <- "codamenu.diags.crosscorr" crosscorr.out <- if (coda.options("combine.corr")) { crosscorr(work.dat) } else lapply(work.dat, crosscorr) if (coda.options("combine.corr") & nchain(work.dat) > 1) cat("Pooling over chains:", chanames(work.dat, allow.null = FALSE), sep = "\n", collapse = "\n") print(crosscorr.out, digits = coda.options("digits")) cat("\n") choices <- c("Change options", "Plot Cross Correlations", "Return to Diagnostics Menu") pick <- menu(choices, title = "Cross correlation plots menu") if (pick == 0) next.menu <- "quit" else switch(pick, change.tfoption("Combine chains", "combine.corr"), { repeat { if (coda.options("combine.corr")) crosscorr.plot(work.dat) else { opar <- par(ask = TRUE) lapply(work.dat, crosscorr.plot) par(opar) } codamenu.ps() if (names(dev.cur()) != "postscript") break } }, next.menu <- "codamenu.diags") return(next.menu) } "codamenu.diags.heidel" <- function (work.dat, ...) { this.menu <- "codamenu.diags.heidel" next.menu <- "codamenu.diags" title <- "HEIDELBERGER AND WELCH STATIONARITY AND INTERVAL HALFWIDTH TESTS" codamenu.output.header(title, work.dat) cat("Precision of halfwidth test =", coda.options("halfwidth"), "\n\n") heidel.out <- heidel.diag(work.dat, eps = coda.options("halfwidth")) print(heidel.out, digits = coda.options("digits")) choices <- c("Change precision", "Return to diagnostics menu") pick <- menu(choices) if (pick == 0) next.menu <- "quit" else if (pick == 1) next.menu <- codamenu.options.heidel(this.menu) return(next.menu) } "codamenu.diags.raftery" <- function (work.dat, ...) { next.menu <- this.menu <- "codamenu.diags.raftery" codamenu.output.header("RAFTERY AND LEWIS CONVERGENCE DIAGNOSTIC", work.dat) print(raftery.diag(work.dat, q = coda.options("q"), r = coda.options("r"), s = coda.options("s")), digits = coda.options("digits")) choices <- c("Change parameters", "Return to diagnostics menu") pick <- menu(choices) next.menu <- if (pick == 0) "quit" else if (pick == 1) { codamenu.options.raftery(this.menu) } else "codamenu.diags" return(next.menu) } "codamenu.main" <- function (work.dat, ...) { choices <- c("Output Analysis", "Diagnostics", "List/Change Options", "Quit") next.menu.list <- c("codamenu.anal", "codamenu.diags", "codamenu.options", "quit") pick <- menu(choices, title = "CODA Main Menu") if (pick == 0) next.menu <- "quit" else next.menu <- next.menu.list[pick] return(next.menu) } "codamenu.diags.gelman" <- function (work.dat, ...) { next.menu <- this.menu <- "codamenu.diags.gelman" if (nchain(work.dat) == 1) { cat("\nError: you need more than one chain.\n\n") return(next.menu = "codamenu.diags") } else if (niter(work.dat) <= 50) { cat("\nError: you need > 50 iterations in the working data\n") return(next.menu = "codamenu.diags") } z <- window(work.dat, start = niter(work.dat)/2) for (i in 2:nchain(z)) { for (j in 1:(i - 1)) { if (any(apply(as.matrix(z[[i]] - z[[j]]), 2, var)) < 1e-08) { cat("\nError: 2nd halves of", chanames(z, allow.null = FALSE)[c(j, i)], "are identical for at least one variable\n") return(next.menu = "codamenu.diags") } } } codamenu.output.header("GELMAN AND RUBIN DIAGNOSTIC", work.dat) print(gelman.diag(work.dat, transform = TRUE), digits = coda.options("digits")) choices <- c("Shrink Factor Plots", "Change bin size for shrink plot", "Return to Diagnostics Menu") action.list <- c("ShrinkPlot", "ChangeBin", "Return") while (next.menu == "codamenu.diags.gelman") { pick <- menu(choices, title = "Gelman & Rubin menu") if (pick == 0) next.menu <- "quit" else switch(action.list[pick], ShrinkPlot = { ask <- TRUE repeat { gelman.plot(work.dat, max.bins = coda.options("gr.max"), bin.width = coda.options("gr.bin"), auto.layout = !coda.options("user.layout"), ask = ask) codamenu.ps() if (names(dev.cur()) == "postscript") ask <- FALSE else break } }, ChangeBin = { codamenu.options.gelman(NULL, work.dat) }, Return = { next.menu <- "codamenu.diags" }) } return(next.menu) } "codamenu.diags.geweke" <- function (work.dat, ...) { next.menu <- "codamenu.diags.geweke" codamenu.output.header("GEWEKE CONVERGENCE DIAGNOSTIC (Z-score)", work.dat) geweke.out <- geweke.diag(work.dat, frac1 = coda.options("frac1"), frac2 = coda.options("frac2")) print(geweke.out, digits = coda.options("digits")) choices <- c("Change window size", "Plot Z-scores", "Change number of bins for plot", "Return to Diagnostics Menu") action.list <- c("ChangeWindow", "Plot", "ChangeBin", "Return") while (next.menu == "codamenu.diags.geweke") { pick <- menu(choices, title = "Geweke plots menu") if (pick == 0) return("quit") switch(action.list[pick], ChangeWindow = { codamenu.options.geweke.win(NULL) geweke.out <- geweke.diag(work.dat, frac1 = coda.options("frac1"), frac2 = coda.options("frac2")) print(geweke.out, digits = coda.options("digits")) }, Plot = { ask <- TRUE repeat { if(start(work.dat) >= end(work.dat)) { cat("Chain too short: end iteration must be at least twice\n") cat("the start iteration\n") break } geweke.plot(work.dat, frac1 = coda.options("frac1"), frac2 = coda.options("frac2"), nbins = coda.options("geweke.nbin"), auto.layout = !coda.options("user.layout"), ask = ask) codamenu.ps() if (names(dev.cur()) == "postscript") ask <- FALSE else break } }, ChangeBin = { codamenu.options.geweke.bin(NULL) }, Return = { next.menu <- "codamenu.diags" }) } return(next.menu) } "codamenu.options" <- function (work.dat, ...) { next.menu <- "codamenu.options" choices <- c("List current options", "Data Options", "Plot Options", "Summary Statistics Options", "Diagnostics Options", "Output Analysis", "Diagnostics", "Main Menu") action.list <- c("ListOptions", "codamenu.options.data", "codamenu.options.plot", "codamenu.options.stats", "codamenu.options.diag", "codamenu.anal", "codamenu.diags", "codamenu.main") pick <- menu(choices, title = "CODA main options menu") if (pick == 0) return("quit") if (action.list[pick] == "ListOptions") { display.working.data(work.dat) display.coda.options(stats = TRUE, plots = TRUE, diags = TRUE) next.menu <- "codamenu.options" } else next.menu <- action.list[pick] return(next.menu) } "codamenu.options.data" <- function (work.dat, coda.dat) { next.menu <- "codamenu.options.data" work.vars <- varnames(work.dat) work.chains <- chanames(work.dat) work.start <- start(work.dat) work.end <- end(work.dat) work.thin <- thin(work.dat) choices <- c("List current data options", "Select variables for analysis", "Select chains for analysis", "Select iterations for analysis", "Select thinning interval", "Return to main options menu") action.list <- c("ListDataOptions", "SelectVars", "SelectChains", "SelectIters", "SelectThinInterval", "MainOptionsMenu") pick <- menu(choices, title = "CODA data options menu") if (pick == 0) return("quit") switch(action.list[pick], ListDataOptions = { display.working.data(work.dat) }, SelectVars = { work.vars <- multi.menu(varnames(coda.dat, allow.null = FALSE), "Select variables for analysis", c("VARIABLE NUMBER", "VARIABLE NAME"), allow.zero = FALSE) }, SelectChains = { work.chains <- multi.menu(chanames(coda.dat, allow.null = FALSE), "Select chains for analysis:", c("CHAIN NUMBER", "CHAIN NAME"), allow.zero = FALSE) }, SelectIters = { cat("\nIterations available = ", start(coda.dat), ":", end(coda.dat), "\n", sep = "") work.start <- read.and.check("Enter iteration you wish to start at", lower = start(coda.dat), upper = end(coda.dat), default = start(work.dat)) work.end <- read.and.check("Enter iteration you wish to end at", lower = work.start, upper = end(coda.dat), default = end(work.dat)) }, SelectThinInterval = { cat("\nThinning interval of full data = ", thin(coda.dat), "\n", sep = "") work.thin <- read.and.check("Enter thinning interval:", lower = thin(coda.dat), default = thin(work.dat)) }, MainOptionsMenu = { next.menu <- "codamenu.options" }) if (action.list[pick] != "ListDataOptions" && action.list[pick] != "MainOptionsMenu") { cat("Recreating working data...\n") wd <- window(coda.dat[, work.vars, drop = FALSE], start = work.start, end = work.end, thin = work.thin) work.dat <- wd[work.chains, drop=FALSE] } return(list(next.menu, "work.dat"=work.dat)) } "codamenu.options.diag" <- function (work.dat, ...) { next.menu <- this.menu <- "codamenu.options.diag" choices <- c("Display current diagnostic options", "Window sizes for Geweke's diagnostic", "Bin size for plotting Geweke's diagnostic", "Bin size for plotting Gelman & Rubin's diagnostic", "Parameters for Raftery & Lewis' diagnostic", "Halfwidth precision for Heidelberger & Welch's diagnostic", "Combine chains to calculate correlation matrix", "Return to main options menu") pick <- menu(choices, title = "CODA diagnostics options menu") if (pick == 0) return("quit") switch(pick, display.coda.options(diags = TRUE), next.menu <- codamenu.options.geweke.win(this.menu), next.menu <- codamenu.options.geweke.bin(this.menu), next.menu <- codamenu.options.gelman(this.menu, work.dat), next.menu <- codamenu.options.raftery(this.menu), next.menu <- codamenu.options.heidel(this.menu), { change.tfoption("Do you want to combine all chains to calculate correlation matrix", "combine.corr") }, next.menu <- "codamenu.options") return(next.menu) } "codamenu.options.gelman" <- function (last.menu, work.dat) { choices <- c("Default: bin width = 10; maximum number of bins = 50", "User-specified bin width", "User-specified total number of bins") pick <- menu(choices, title = "Options for defining bin size to plot Gelman-Rubin-Brooks diagnostic") if (pick == 0) return("quit") switch(pick, { coda.options(gr.max = 50) coda.options(gr.bin = 10) }, { coda.options(gr.max = Inf) default <- if (coda.options("gr.bin") == 0) 10 else coda.options("gr.bin") msg <- "Enter required bin width:" coda.options(gr.bin = read.and.check(msg, lower = 1, upper = niter(work.dat) - 50, default = default)) }, { coda.options(gr.bin = 0) default <- if (is.infinite(coda.options("gr.max"))) 50 else coda.options("gr.max") msg <- "Enter total number of bins required:" coda.options(gr.max = read.and.check(msg, lower = 1, upper = niter(work.dat) - 50, default = default)) }) return(last.menu) } "codamenu.options.geweke.bin" <- function (last.menu) { msg <- "Enter number of bins for Geweke-Brooks plot" ans <- read.and.check(msg, what=numeric(), lower=1, default=coda.options("geweke.nbin")) coda.options(geweke.nbin = ans) return(last.menu) } "codamenu.options.geweke.win" <- function (last.menu) { msg1 <- "Enter fraction of chain to include in 1st window:" msg2 <- "Enter fraction of chain to include in 2nd window:" ans1 <- ans2 <- 1 while (ans1 + ans2 >= 1) { ans1 <- read.and.check(msg1, lower = 0, upper = 1, default = coda.options("frac1")) ans2 <- read.and.check(msg2, lower = 0, upper = 1, default = coda.options("frac2")) ## Check that sum of fractions doesn't exceed 1.0 if (ans1 + ans2 >= 1) cat("Error: Sum of fractions in 1st and 2nd windows must be < 1.0\n") } coda.options(frac1 = ans1, frac2 = ans2) return(last.menu) } "codamenu.options.heidel" <- function (last.menu) { coda.options(halfwidth = read.and.check("Enter precision for halfwidth test", lower = 0, default = coda.options("halfwidth"))) return(last.menu) } "codamenu.options.plot" <- function (...) { next.menu <- "codamenu.options.plot" choices <- c("Show current plotting options", "Plot trace of samples", "Plot kernel density estimate", "Add smooth line through trace plot", "Combine chains", "Single plot per page", "Specify page layout for plots", "Select bandwidth function for kernel smoothing", "Return to main options menu") pick <- menu(choices, title = "CODA plotting options menu") if (pick == 0) return("quit") switch(pick, display.coda.options(plots = TRUE), change.tfoption(choices[2], "trace"), change.tfoption(choices[3], "densplot"), change.tfoption(choices[4], "lowess"), change.tfoption(choices[5], "combine.plots"), { ans <- read.yesno(choices[6], default=TRUE) if(ans) { coda.options(user.layout = TRUE) par(mfrow = c(1,1)) } }, { change.tfoption("Do you want to specify your own page layout for the plots", "user.layout") if (coda.options("user.layout")) { mrows <- read.and.check("Enter number of rows per page", lower = 1, upper = 7) mcols <- read.and.check("Enter number of columns per page", lower = 1, upper = 8) par(mfrow = c(mrows, mcols)) } }, { next.menu <- "codamenu.options.plot.kernel" }, NULL) if (pick == length(choices)) next.menu <- "codamenu.options" return(next.menu) } "codamenu.options.plot.kernel" <- function (...) { if (!coda.options("densplot")) { cat("\nNo density plots requested - this option is irrelevant\n") } else { kernel.menu <- c("Smooth (0.25 * sample range)", "Coarse (Silverman 1986 eqn. 3.28 & 3.30)", "User-defined function", "Return to Plotting Options Menu") pick1 <- menu(kernel.menu, title = "Select kernel bandwidth function") if (pick1 == 0) return("quit") switch(pick1, { bwf <- function(x) { (max(x) - min(x))/4 } coda.options(bandwidth = bwf) }, { bwf <- function(x) { 1.06 * min(sd(x), IQR(x)/1.34) * length(x)^-0.2 } coda.options(bandwidth = bwf) }, { func.OK <- FALSE while (!func.OK) { cat("Enter bandwidth as an expression in terms of x,\n") cat("the vector of sampled values, e.g. \n") cat("(max(x) - min(x)) / 4\n") ans <- scan(what = character()) if (length(ans) > 0) { bwf <- "function(x){" for (i in 1:length(ans)) { bwf <- paste(bwf, ans[i], sep = "") } bwf <- paste(bwf, "}", sep = "") bwf <- try(eval(parse(text = bwf)), silent=TRUE) if (inherits(bwf, "try-error")) { cat("Invalid expression\n") } else { ## Carry out simple test to check whether the ## function entered makes sense ## bw <- try(bwf(1:10), silent=FALSE) if (inherits(bw, "try-error")) { cat("Error calling function with input 1:10\n") } else { func.OK <- is.numeric(bw) && (length(bw) == 1) if(!func.OK) { cat("This is not a suitable function: it must return a\n") cat("single numeric value given a numeric vector x.\n") } } } } } coda.options(bandwidth = bwf) }, NULL) } return("codamenu.options.plot") } "codamenu.options.raftery" <- function (last.menu) { coda.options(q = read.and.check("Enter quantile to be estimated:", lower = 0, upper = 1, default = coda.options("q"))) coda.options(r = read.and.check("Enter required precision:", upper = coda.options("q"), default = coda.options("r"))) coda.options(s = read.and.check("Enter required probability:", lower = 0, upper = 1, default = coda.options("s"))) return(last.menu) } "codamenu.options.stats" <- function (...) { next.menu <- "codamenu.options.stats" choices <- c("Display current statistics options", "Combine chains for summary statistics", "Quantiles for summary statistics", "Number of significant digits for printing", "Return to main options menu") pick <- menu(choices, title = "CODA options for summary statistics") if (pick == 0) return("quit") switch(pick, display.coda.options(stats = TRUE), { mssg <- "Do you want to combine all chains when calculating summary statistics" change.tfoption(mssg, "combine.stats") }, { mssg <- paste("Enter quantiles required, separated by commas\n(Default =", paste(coda.options("quantiles"), collapse = ", ")) repeat { cat("\n", mssg, "\n") if (is.R()) { ans <- as.numeric(scan(what = character(), sep = ",", nlines = 1, quiet = TRUE)) } else { ans <- as.numeric(scan(what = character(), sep = ",", nlines = 1)) } if (length(ans) == 0) ans <- coda.options("quantiles") if (any(is.na(ans))) mssg <- "You must enter numeric values" else if (any(ans >= 1) || any(ans <= 0)) mssg <- "You must enter values between 0 and 1" else break } if (length(ans) > 0) coda.options(quantiles = sort(ans)) }, { mssg <- "Enter number of significant digits to be printed" ans <- read.and.check(mssg, what = integer(), lower = 0, default = coda.options("digits")) coda.options(digits = ans) }, { next.menu <- "codamenu.options" }) return(next.menu) } "display.working.data" <- function (data) { cat("WORKING DATA\n") cat("============\n") cat("Variables selected : ", paste(varnames(data, allow.null = FALSE), collapse=", ") ,"\n", sep="") cat("Chains selected : ", paste(chanames(data, allow.null = FALSE), collapse=", ") , "\n", sep="") cat("Iterations - start : ", start(data), "\n", sep="") cat(" end : ", end(data), "\n", sep="") cat("Thinning interval : ", thin(data), "\n", sep="") cat("\n") } "display.coda.options" <- function (stats = FALSE, plots = FALSE, diags = FALSE) { cat("\nCurrent option settings:") cat("\n=======================\n\n") if (stats) { cat("SUMMARY STATISTICS OPTIONS\n") cat("==========================\n\n") cat("Combine chains : ", coda.options("combine.stats"), "\n", sep="") cat("Quantiles : ", paste(coda.options("quantiles") * 100, "%", sep="", collapse = ", "), "\n", sep="") cat("Significant digits : ", coda.options("digits"), "\n", sep="") cat("\n") } if (plots) { cat("PLOTTING OPTIONS\n") cat("================\n\n") cat("Trace : ", coda.options("trace"), "\n", sep="") cat("Density : ", coda.options("densplot"), "\n", sep="") cat("Smooth lines : ", coda.options("lowess"), "\n", sep="") cat("Combine chains : ", coda.options("combine.plots"), "\n", sep="") cat("User-defined layout : ", coda.options("user.layout"), "\n", sep="") if(coda.options("user.layout")) { cat(" : ", paste(par("mfrow"), collapse=" X "), "\n", sep="") } cat("Bandwidth function :\n") print(coda.options("bandwidth")) cat("\n") } if (diags) { cat("DIAGNOSTICS OPTIONS\n") cat("===================\n\n") cat("Geweke\n") cat("------\n") cat("Window 1 fraction : ", coda.options("frac1"), "\n", sep="") cat("Window 2 fraction : ", coda.options("frac2"), "\n", sep="") cat("Number of bins : ", coda.options("geweke.nbin"), "\n", sep="") cat("\n") cat("Gelman & Rubin\n") cat("--------------\n") cat("Bin width : ", coda.options("gr.bin"), "\n", sep="") cat("Max number of bins : ", coda.options("gr.max"), "\n", sep="") cat("\n") cat("Raftery & Lewis\n") cat("---------------\n") cat("Quantile (q) : ", coda.options("q"), "\n", sep="") cat("Precision (+/- r) : ", coda.options("r"), "\n", sep="") cat("Probability (s) : ", coda.options("s"), "\n", sep="") cat("\n") cat("Cross-correlations\n") cat("------------------\n") cat("Combine chains : ", coda.options("combine.corr"), "\n", sep="") cat("\n") } invisible() } "read.coda.interactive" <- function () { repeat { cat("Enter CODA index file name\n") cat("(or a blank line to exit)\n") if (is.R()) { index.file <- scan(what = character(), sep = "\n", strip.white = TRUE, nlines=1, quiet=TRUE) } else { index.file <- scan(what = character(), sep = "\n", strip.white = TRUE) } if (length(index.file) == 0) return(invisible()) cat("Enter CODA output file names, separated by return key\n") cat("(leave a blank line when you have finished)\n") if (is.R()) { output.files <- scan(what = character(), sep = "\n", strip.white = TRUE, quiet = TRUE) } else { output.files <- scan(what = character(), sep = "\n", strip.white = TRUE) } all.files <- c(index.file, output.files) if (any(!file.exists(all.files))) { cat("The following files were not found:\n") cat(paste(all.files[!file.exists(all.files)], collapse = "\n"), "\n\n") } else break } nfiles <- length(output.files) chains <- vector("list", nfiles) names(chains) <- output.files for (i in 1:nfiles) chains[[i]] <- read.coda(output.files[i], index.file) return(mcmc.list(chains)) } "codamenu.ps" <- function () { if (names(dev.cur()) == "postscript") { dev.off() } else { cat("\nSave plots as a postscript file (y/N) ?\n") ans <- readline() if (length(ans) == 0) ans <- "n" if (ans == "Y" | ans == "y") { repeat { mssg <- "Enter name you want to call this postscript file" ps.name <- read.and.check(mssg, what = character(), default = "Rplots.ps") if (file.exists(ps.name)) { pick <- menu(title = "File exists", choices = c("overwrite", "choose another file name")) if (pick == 1) break } else { break } } postscript(file = ps.name) } } return(dev.cur()) } "codamenu.output.header" <- function (title, data) { ## ## A short header: common to most codamenu output ## cat("\n", title, sep = "") cat("\n", paste(rep("=", nchar(title)), collapse = ""), "\n\n", sep = "") cat("Iterations used = ", start(data), ":", end(data), "\n", sep = "") cat("Thinning interval =", thin(data), "\n") cat("Sample size per chain =", niter(data), "\n\n") invisible() } coda/R/cumuplot.R0000644000176200001440000000324413343454654013372 0ustar liggesuserscumuplot <- function(x, probs=c(0.025,0.5,0.975), ylab="", lty=c(2,1), lwd=c(1,2), type="l", ask, auto.layout=TRUE, col=1, ...) { if (missing(ask)) { ask <- if (is.R()) { dev.interactive() } else { interactive() } } cquantile <- function(z, probs) { ## Calculates cumulative quantile of a vector cquant <- matrix(0, nrow=length(z), length(probs)) for(i in seq(along=z)) # for loop proved faster than apply here if (is.R()) { cquant[i,] <- quantile(z[1:i], probs=probs, names=FALSE) }else{ cquant[i,] <- quantile(z[1:i], probs=probs) } cquant <- as.data.frame(cquant) names(cquant) <- paste(formatC(100*probs,format="fg",width=1,digits=7), "%", sep="") # just like quantile.default return(cquant) } oldpar <- NULL on.exit(par(oldpar)) if (auto.layout) { oldpar <- par(mfrow = set.mfrow(Nchains = nchain(x), Nparms = nvar(x))) } if (!is.mcmc.list(x)) x <- mcmc.list(as.mcmc(x)) Iterations <- time(x) for (i in 1:nchain(x)) { for (j in 1:nvar(x)) { Y <- cquantile(as.matrix(x[[i]])[,j], probs=probs) if (!is.R()) Y <- as.matrix(Y) matplot(Iterations, Y, ylab=ylab, lty=lty, lwd=lwd, type=type, col=col, ...) title(paste(varnames(x)[j], ifelse(is.null(chanames(x)), "", ":"), chanames(x)[i], sep = "")) if (i == 1 & j == 1) oldpar <- c(oldpar, par(ask=ask)) } } } coda/R/mcextractor.R0000644000176200001440000000275513343454654014063 0ustar liggesusers"chanames" <- function (x, allow.null = TRUE) { if (is.mcmc.list(x)) { if (is.null(names(x))) if (allow.null) NULL else paste("chain", 1:length(x), sep = "") else names(x) } else NULL } "chanames<-" <- function (x, value) { if (is.mcmc.list(x)) names(x) <- value else stop("Not an mcmc.list object") x } "varnames" <- function (x, allow.null = TRUE) { if (!is.mcmc(x) && !is.mcmc.list(x)) return(NULL) y <- if (is.mcmc(x)) dimnames(x)[[2]] else if (is.mcmc.list(x)) dimnames(x[[1]])[[2]] if (is.null(y) && !allow.null) y <- paste("var", 1:nvar(x), sep = "") return(y) } "varnames<-" <- function (x, value) { if (is.mcmc(x)) { if (length(dim(x)) < 2) { dim(x) <- c(length(x), 1) } colnames(x) <- value } else if (is.mcmc.list(x)) { for (i in 1:nchain(x)) varnames(x[[i]]) <- value } else stop("Not an mcmc or mcmc.list object") x } "nchain" <- function (x) { if (is.mcmc(x)) 1 else if (is.mcmc.list(x)) length(x) else NULL } "nvar" <- function (x) { if (is.mcmc(x)) { if (is.matrix(x)) ncol(x) else 1 } else if (is.mcmc.list(x)) { if (is.matrix(x[[1]])) ncol(x[[1]]) else 1 } else NULL } "niter" <- function (x) { if (is.mcmc(x)) { if (is.matrix(x)) nrow(x) else length(x) } else if (is.mcmc.list(x)) { if (is.matrix(x[[1]])) nrow(x[[1]]) else length(x[[1]]) } else NULL } coda/R/mcmclist.R0000644000176200001440000001464213343454654013341 0ustar liggesusers"[.mcmc.list" <- function (x, i, j, drop = TRUE) { ## In S-PLUS the code is altered so that the user can ## pick out particular parameters by calling ## mcmc.obj[,c("param1", "param2")] ## Trying to squeeze too much functionality in here ## x[p:q] will subset the list ## x[p,], x[,q], x[p,q] will be recursively applied to ## the elements of the list, even if they are vectors if (nargs() < 3 + !missing(drop)) { ## Subset the list if (is.R()) { y <- NextMethod("[") } else { y <- as.matrix(x)[i,j] } } else { ## Subset the elements of the list y <- vector("list", length(x)) names(y) <- names(x) for (k in 1:length(y)) { y[[k]] <- if (missing(i) && missing(j)) { x[[k]] } else if (is.matrix(x[[k]])) { if (missing(i)) { x[[k]][, j, drop = drop] } else if (missing(j)) { x[[k]][i, , drop = drop] } else { x[[k]][i, j, drop = drop] } } else { ### Coerce x[[k]] to matrix before subsetting z <- as.matrix.mcmc(x[[k]]) if (missing(i)) { mcmc(z[, j, drop = TRUE], start(x), end(x), thin(x)) } else if (missing(j)) { z[i, , drop = TRUE] } else { z[i, j, drop = TRUE] } } } } if (is.list(y) && all(sapply(y, is.mcmc, simplify = TRUE))) { y <- mcmc.list(y) } return(y) } "mcmc.list" <- function (...) { x <- list(...) if (length(x) == 1 && is.list(x[[1]])) x <- x[[1]] if (!all(unlist(lapply(x, is.mcmc)))) stop("Arguments must be mcmc objects") nargs <- length(x) if (nargs >= 2) { xmcpar <- lapply(x, mcpar) if (!all(unlist(lapply(xmcpar, "==", xmcpar[[1]])))) stop("Different start, end or thin values in each chain") xnvar <- lapply(x, nvar) if (!all(unlist(lapply(xnvar, "==", xnvar[[1]])))) stop("Different number of variables in each chain") xvarnames <- lapply(x, varnames, allow.null = FALSE) if (!all(unlist(lapply(xvarnames, "==", xvarnames[[1]])))) stop("Different variable names in each chain") } if (is.R()) class(x) <- "mcmc.list" else oldClass(x) <- "mcmc.list" return(x) } "start.mcmc.list" <- function (x, ...) { start(x[[1]]) } "end.mcmc.list" <- function (x, ...) { end(x[[1]]) } "thin.mcmc.list" <- function (x, ...) { thin(x[[1]]) } "is.mcmc.list" <- function (x) inherits(x, "mcmc.list") "plot.mcmc.list" <- function (x, trace = TRUE, density = TRUE, smooth = TRUE, bwf, auto.layout = TRUE, ask = par("ask"), ...) { ## RGA fixed to use default ask value. oldpar <- NULL on.exit(par(oldpar)) if (auto.layout) { mfrow <- set.mfrow(Nchains = nchain(x), Nparms = nvar(x), nplots = trace + density) oldpar <- par(mfrow = mfrow) } for (i in 1:nvar(x)) { if (trace) ## RGA fixed to propagate ... argument. traceplot(x[, i, drop = FALSE], smooth = smooth, ...) if (density) { if (missing(bwf)) ## RGA fixed to propagate ... argument. densplot(x[, i, drop = FALSE], ...) else densplot(x[, i, drop = FALSE], bwf = bwf, ...) } if (i==1) oldpar <- c(oldpar, par(ask = ask)) } } "summary.mcmc.list" <- function (object, quantiles = c(0.025, 0.25, 0.5, 0.75, 0.975), ...) { x <- mcmc.list(object) statnames <- c("Mean", "SD", "Naive SE", "Time-series SE") varstats <- matrix(nrow = nvar(x), ncol = length(statnames), dimnames = list(varnames(x), statnames)) xtsvar <- matrix(nrow = nchain(x), ncol = nvar(x)) if (is.matrix(x[[1]])) { for (i in 1:nchain(x)) for(j in 1:nvar(x)) xtsvar[i, j] <- safespec0(x[[i]][,j]) xlong <- do.call("rbind", x) } else { for (i in 1:nchain(x)) xtsvar[i, ] <- safespec0(x[[i]]) xlong <- as.matrix(x) } xmean <- apply(xlong, 2, mean) xvar <- apply(xlong, 2, var) xtsvar <- apply(xtsvar, 2, mean) varquant <- t(apply(xlong, 2, quantile, quantiles)) varstats[, 1] <- xmean varstats[, 2] <- sqrt(xvar) ##RGA fixed so now give correct std error for pooled (across chains). varstats[, 3] <- sqrt(xvar/(niter(x)*nchain(x))) varstats[, 4] <- sqrt(xtsvar/(niter(x)*nchain(x))) varquant <- drop(varquant) varstats <- drop(varstats) out <- list(statistics = varstats, quantiles = varquant, start = start(x), end = end(x), thin = thin(x), nchain = nchain(x)) class(out) <- "summary.mcmc" return(out) } "as.matrix.mcmc.list" <- function (x, iters = FALSE, chains = FALSE, ...) { x <- mcmc.list(x) y <- matrix(nrow = niter(x) * nchain(x), ncol = nvar(x) + chains + iters) var.cols <- chains + iters + 1:nvar(x) for (i in 1:nchain(x)) { use.rows <- niter(x) * (i - 1) + 1:niter(x) if (chains) y[use.rows, 1] <- i if (iters) y[use.rows, chains + 1] <- as.vector(time(x)) y[use.rows, var.cols] <- x[[i]] } rownames <- character(ncol(y)) if (chains) rownames[1] <- "CHAIN" if (iters) rownames[1 + chains] <- "ITER" rownames[var.cols] <- varnames(x, allow.null = FALSE) dimnames(y) <- list(NULL, rownames) return(y) } "as.mcmc.mcmc.list" <- function (x, ...) { if (nchain(x) == 1) return(x[[1]]) else stop("Can't coerce mcmc.list to mcmc object:\n more than 1 chain") } "time.mcmc.list" <- function (x, ...) time(x[[1]]) "window.mcmc.list" <- function (x, ...) { structure(lapply(x, window.mcmc, ...), class = "mcmc.list") } "head.mcmc.list" <- function (x, ...) { structure(lapply(x, head.mcmc, ...), class = "mcmc.list") } "tail.mcmc.list" <- function (x, ...) { structure(lapply(x, tail.mcmc, ...), class = "mcmc.list") } "as.mcmc.list" <- function (x, ...) UseMethod("as.mcmc.list") "as.mcmc.list.default" <- function (x, ...) if (is.mcmc.list(x)) x else mcmc.list(x) "as.array.mcmc.list" <- function(x, drop=TRUE, ...) { y <- array(dim=c(niter(x), nvar(x), nchain(x)), dimnames = list(iter=time(x), var=varnames(x), chain=chanames(x))) for(i in 1:nchain(x)) y[,,i] <- x[[i]] if(drop) return(drop(y)) else return(y) } coda/R/util.R0000644000176200001440000001577113343454654012507 0ustar liggesusers"read.yesno" <- function (string, default=TRUE) { wrd <- ifelse(default, " (Y/n)?\n:", " (y/N)?\n:") cat("\n", string, wrd, sep = "") ans <- readline() val <- if (default) pmatch(ans, c("no","NO"), nomatch=0) == 0 else pmatch(ans, c("yes","YES"), nomatch=0) != 0 return(val) } "change.tfoption" <- function (string, option) { current.value <- coda.options(option) if (!is.logical(current.value)) stop("Invalid option: must take logical values") new.value <- read.yesno(string, current.value) if (new.value != current.value) { arg <- list(new.value) names(arg) <- option coda.options(arg) } invisible() } "coda.options" <- function (...) { ## Set and display coda options single <- FALSE copt <- if (exists("options", envir=coda.env, inherits=FALSE)) { get("options", envir=coda.env, inherits=FALSE) } else { .Coda.Options.Default } if (nargs() == 0) { return(copt) } else { args <- list(...) if (length(args) == 1) { if (is.list(args[[1]])) args <- args[[1]] else if (is.null(names(args))) single <- TRUE } } if (is.null(names(args))) { ## Display options args <- unlist(args) value <- vector("list", length(args)) names(value) <- args for (v in args) if (any(v == names(copt))) value[v] <- copt[v] if (single) return(value[[1]]) else return(value) } else { ## Set options oldvalue <- vector("list", length(args)) names(oldvalue) <- names(args) if (any(names(args) == "default") && args$default == TRUE) copt <- .Coda.Options.Default for (v in names(args)) if (any(v == names(copt))) { oldvalue[v] <- copt[v] if (is.null(args[[v]])) copt[v] <- list(NULL) else if (mode(copt[[v]]) == mode(args[[v]])) copt[v] <- args[v] } assign("options", copt, envir=coda.env) invisible(oldvalue) } } "multi.menu" <- function (choices, title, header, allow.zero = TRUE) { ## Select more than one value from a menu ## if (!missing(title)) cat(title, "\n\n") mat <- matrix(c(1:length(choices), choices), ncol = 2) if (!missing(header)) { if (length(header) == 2) mat <- rbind(header, mat) else stop("header is wrong length") } cat(paste(format(mat[, 1]), format(mat[, 2])), sep = "\n") repeat { cat("\nEnter relevant number(s), separated by commas", "Ranges such as 3:7 may be specified)", sep = "\n") if (allow.zero) cat("(Enter 0 for none)\n") ans <- scan(what = character(), sep = ",", strip.white = TRUE, nlines = 1, quiet = TRUE) if (length(ans) > 0) { out <- numeric(0) for (i in 1:length(ans)) { nc <- nchar(ans[i]) wrd <- substring(ans[i], 1:nc, 1:nc) colons <- wrd == ":" err <- any(is.na(as.numeric(wrd[!colons]))) | sum(colons) > 1 | colons[1] | colons[nc] if (err) { cat("Error: you have specified a non-numeric value!\n") break } else { out <- c(out, eval(parse(text = ans[i]))) if (min(out) < ifelse(allow.zero, 0, 1) | max(out) > length(choices) | (any(out == 0) & length(out) > 1)) { err <- TRUE cat("Error: you have specified variable number(s) out of range!\n") break } } } if (!err) break } } return(out) } "read.and.check" <- function (message = "", what = numeric(), lower, upper, answer.in, default) { ## Read data from the command line and check that it satisfies ## certain conditions. The function will loop until it gets ## and answer satisfying the conditions. This entails extensive ## checking of the conditions to make sure they are consistent ## so we don't end up in an infinite loop. have.lower <- !missing(lower) have.upper <- !missing(upper) have.ans.in <- !missing(answer.in) have.default <- !missing(default) if (have.lower | have.upper) { if (!is.numeric(what)) stop("Can't have upper or lower limits with non numeric input") if (have.lower && !is.numeric(lower)) stop("lower limit not numeric") if (have.upper && !is.numeric(upper)) stop("upper limit not numeric") if ((have.upper & have.lower) && upper < lower) stop("lower limit greater than upper limit") } if (have.ans.in) { if (mode(answer.in) != mode(what)) stop("inconsistent values of what and answer.in") if (have.lower) answer.in <- answer.in[answer.in >= lower] if (have.upper) answer.in <- answer.in[answer.in <= upper] if (length(answer.in) == 0) stop("No possible response matches conditions") } if (have.default) { if (mode(default) != mode(what)) stop("inconsistent values of what and default") if (have.lower && default < lower) stop("default value below lower limit") if (have.upper && default > upper) stop("default value above upper limit") if (have.ans.in && !any(answer.in == default)) stop("default value does not satisfy conditions") } err <- TRUE while (err) { if (nchar(message) > 0) { cat("\n", message, "\n", sep = "") if (have.default) cat("(Default = ", default, ")\n", sep = "") } repeat { cat("1:") ans <- readline() if (length(ans) == 1 && nchar(ans) > 0) break else if (have.default) { ans <- default break } } if (is.numeric(what)) { err1 <- TRUE ans <- as.numeric(ans) message <- "You must enter a number" if (is.na(ans)) NULL else if ((have.lower & have.upper) && (ans < lower | ans > upper)) message <- paste(message, "between", lower, "and", upper) else if (have.lower && ans < lower) message <- paste(message, ">=", lower) else if (have.upper && ans > upper) message <- paste(message, "<=", upper) else err1 <- FALSE } else err1 <- FALSE if (have.ans.in) { if (!is.na(ans) && !any(ans == answer.in)) { message <- paste("You must enter one of the following:", paste(answer.in, collapse = ",")) err2 <- TRUE } else err2 <- FALSE } else err2 <- FALSE err <- err1 | err2 } return(ans) } ".Coda.Options.Default" <- list(trace = TRUE, densplot = TRUE, lowess = FALSE, combine.plots = TRUE, bandwidth = function (x) { x <- x[!is.na(x)] 1.06 * min(sd(x), IQR(x)/1.34) * length(x)^-0.2 }, digits = 3, quantiles = c(0.025, 0.25, 0.5, 0.75, 0.975), frac1 = 0.1, frac2 = 0.5, q = 0.025, r = 0.005, s = 0.95, combine.stats = FALSE, combine.corr = FALSE, halfwidth = 0.1, user.layout = FALSE, gr.bin = 10, geweke.nbin = 20, gr.max = 50 ) coda.env <- new.env() coda/R/raftery.R0000644000176200001440000000764713343454654013211 0ustar liggesusers"raftery.diag" <- function (data, q = 0.025, r = 0.005, s = 0.95, converge.eps = 0.001) { if (is.mcmc.list(data)) return(lapply(data, raftery.diag, q, r, s, converge.eps)) data <- as.mcmc(data) resmatrix <- matrix(nrow = nvar(data), ncol = 4, dimnames = list(varnames(data, allow.null = TRUE), c("M", "N", "Nmin", "I"))) phi <- qnorm(0.5 * (1 + s)) nmin <- as.integer(ceiling((q * (1 - q) * phi^2)/r^2)) if (nmin > niter(data)) resmatrix <- c("Error", nmin) else for (i in 1:nvar(data)) { # First need to find the thinning parameter kthin # if (is.matrix(data)) { quant <- quantile(data[, i, drop = TRUE], probs = q) dichot <- mcmc(data[, i, drop = TRUE] <= quant, start = start(data), end = end(data), thin = thin(data)) } else { quant <- quantile(data, probs = q) dichot <- mcmc(data <= quant, start = start(data), end = end(data), thin = thin(data)) } kthin <- 0 bic <- 1 while (bic >= 0) { kthin <- kthin + thin(data) testres <- as.vector(window.mcmc(dichot, thin = kthin)) testres <- factor(testres, levels=c(FALSE,TRUE)) newdim <- length(testres) testtran <- table(testres[1:(newdim - 2)], testres[2:(newdim - 1)], testres[3:newdim]) testtran <- array(as.double(testtran), dim = dim(testtran)) g2 <- 0 for (i1 in 1:2) { for (i2 in 1:2) { for (i3 in 1:2) { if (testtran[i1, i2, i3] != 0) { fitted <- (sum(testtran[i1, i2, 1:2]) * sum(testtran[1:2, i2, i3]))/(sum(testtran[1:2, i2, 1:2])) g2 <- g2 + testtran[i1, i2, i3] * log(testtran[i1, i2, i3]/fitted) * 2 } } } } bic <- g2 - log(newdim - 2) * 2 } # # then need to find length of burn-in and No of iterations for required precision # finaltran <- table(testres[1:(newdim - 1)], testres[2:newdim]) alpha <- finaltran[1, 2]/(finaltran[1, 1] + finaltran[1, 2]) beta <- finaltran[2, 1]/(finaltran[2, 1] + finaltran[2, 2]) tempburn <- log((converge.eps * (alpha + beta))/max(alpha, beta))/(log(abs(1 - alpha - beta))) nburn <- as.integer(ceiling(tempburn) * kthin) tempprec <- ((2 - alpha - beta) * alpha * beta * phi^2)/(((alpha + beta)^3) * r^2) nkeep <- as.integer(ceiling(tempprec) * kthin) iratio <- (nburn + nkeep)/nmin resmatrix[i, 1] <- nburn resmatrix[i, 2] <- nkeep + nburn resmatrix[i, 3] <- nmin resmatrix[i, 4] <- signif(iratio, digits = 3) } y <- list(params = c(r = r, s = s, q = q), resmatrix = resmatrix) class(y) <- "raftery.diag" return(y) } "print.raftery.diag" <- function (x, digits = 3, ...) { cat("\nQuantile (q) =", x$params["q"]) cat("\nAccuracy (r) = +/-", x$params["r"]) cat("\nProbability (s) =", x$params["s"], "\n") if (x$resmatrix[1] == "Error") cat("\nYou need a sample size of at least", x$resmatrix[2], "with these values of q, r and s\n") else { out <- x$resmatrix for (i in ncol(out)) out[, i] <- format(out[, i], digits = digits) out <- rbind(matrix(c("Burn-in ", "Total", "Lower bound ", "Dependence", "(M)", "(N)", "(Nmin)", "factor (I)"), byrow = TRUE, nrow = 2), out) if (!is.null(rownames(x$resmatrix))) out <- cbind(c("", "", rownames(x$resmatrix)), out) dimnames(out) <- list(rep("", nrow(out)), rep("", ncol(out))) print.default(out, quote = FALSE, ...) cat("\n") } invisible(x) } coda/R/heidel.R0000644000176200001440000001226313343454654012755 0ustar liggesusers"heidel.diag" <- function (x, eps = 0.1, pvalue=0.05) { if (is.mcmc.list(x)) return(lapply(x, heidel.diag, eps)) x <- as.mcmc(as.matrix(x)) HW.mat0 <- matrix(0, ncol = 6, nrow = nvar(x)) dimnames(HW.mat0) <- list(varnames(x), c("stest", "start", "pvalue", "htest", "mean", "halfwidth")) HW.mat <- HW.mat0 for (j in 1:nvar(x)) { start.vec <- seq(from=start(x), to = end(x)/2, by=niter(x)/10) Y <- x[, j, drop = TRUE] n1 <- length(Y) ## Schruben's test for convergence, applied sequentially ## S0 <- spectrum0.ar(window(Y, start=end(Y)/2))$spec converged <- FALSE for (i in seq(along = start.vec)) { Y <- window(Y, start = start.vec[i]) n <- niter(Y) ybar <- mean(Y) B <- cumsum(Y) - ybar * (1:n) Bsq <- (B * B)/(n * S0) I <- sum(Bsq)/n if(converged <- !is.na(I) && pcramer(I) < 1 - pvalue) break } ## Recalculate S0 using section of chain that passed convergence test S0ci <- spectrum0.ar(Y)$spec halfwidth <- 1.96 * sqrt(S0ci/n) passed.hw <- !is.na(halfwidth) & (abs(halfwidth/ybar) <= eps) if (!converged || is.na(I) || is.na(halfwidth)) { nstart <- NA passed.hw <- NA halfwidth <- NA ybar <- NA } else { nstart <- start(Y) } HW.mat[j, ] <- c(converged, nstart, 1 - pcramer(I), passed.hw, ybar, halfwidth) } class(HW.mat) <- "heidel.diag" return(HW.mat) } "print.heidel.diag" <- function (x, digits = 3, ...) { HW.title <- matrix(c("Stationarity", "test", "start", "iteration", "p-value", "", "Halfwidth", "test", "Mean", "", "Halfwidth", ""), nrow = 2) y <- matrix("", nrow = nrow(x), ncol = 6) for (j in 1:ncol(y)) { y[, j] <- format(x[, j], digits = digits) } y[, c(1, 4)] <- ifelse(x[, c(1, 4)], "passed", "failed") y <- rbind(HW.title, y) vnames <- if (is.null(rownames(x))) paste("[,", 1:nrow(x), "]", sep = "") else rownames(x) dimnames(y) <- list(c("", "", vnames), rep("", 6)) print.default(y[, 1:3], quote = FALSE, ...) print.default(y[, 4:6], quote = FALSE, ...) invisible(x) } "spectrum0.ar" <- function(x) { x <- as.matrix(x) v0 <- order <- numeric(ncol(x)) names(v0) <- names(order) <- colnames(x) z <- 1:nrow(x) for (i in 1:ncol(x)) { lm.out <- lm(x[,i] ~ z) if (identical(all.equal(sd(residuals(lm.out)), 0), TRUE)) { v0[i] <- 0 order[i] <- 0 } else { ar.out <- ar(x[,i], aic=TRUE) v0[i] <- ar.out$var.pred/(1 - sum(ar.out$ar))^2 order[i] <- ar.out$order } } return(list(spec=v0, order=order)) } effectiveSize <- function(x) { if (is.mcmc.list(x)) { ##RGA changed to sum across all chains ess <- do.call("rbind",lapply(x,effectiveSize)) ans <- apply(ess,2,sum) } else { x <- as.mcmc(x) x <- as.matrix(x) spec <- spectrum0.ar(x)$spec ans <- ifelse(spec==0, 0, nrow(x) * apply(x, 2, var)/spec) } return(ans) } "spectrum0" <- function(x, max.freq=0.5, order=1, max.length=200) { x <- as.matrix(x) if (!is.null(max.length) && nrow(x) > max.length) { batch.size <- ceiling(nrow(x)/max.length) if (is.R()) { x <- aggregate(ts(x, frequency=batch.size), nfreq = 1, FUN=mean) } else { x <- aggregate(ts(x, frequency=batch.size), nf = 1, fun=mean) } } else { batch.size <- 1 } out <- do.spectrum0(x, max.freq=max.freq, order=order) out$spec <- out$spec * batch.size return(out) } "do.spectrum0" <- function(x, max.freq=0.5, order=1) { ## Estimate spectral density of time series x at frequency 0. ## spectrum0(x)/length(x) estimates the variance of mean(x) ## ## NB We do NOT use the same definition of spectral density ## as in spec.pgram. ## fmla <- switch(order+1, spec ~ one, spec ~ f1, spec ~ f1 + f2) if(is.null(fmla)) stop("invalid order") N <- nrow(x) Nfreq <- floor(N/2) freq <- seq(from = 1/N, by = 1/N, length = Nfreq) f1 <- sqrt(3) * (4 * freq - 1) f2 <- sqrt(5) * (24 * freq^2 - 12 * freq + 1) v0 <- numeric(ncol(x)) for(i in 1:ncol(x)) { y <- x[,i] if (var(y) == 0) { v0[i] <- 0 } else { yfft <- fft(y) spec <- Re(yfft * Conj(yfft))/ N spec.data <- data.frame(one = rep(1, Nfreq), f1=f1, f2=f2, spec = spec[1 + (1:Nfreq)], inset = I(freq<=max.freq)) glm.out <- glm(fmla, family=Gamma(link="log"), data=spec.data) v0[i] <- predict(glm.out, type="response", newdata=data.frame(spec=0,one=1,f1=-sqrt(3),f2=sqrt(5))) } } return(list(spec=v0)) } "pcramer" <- function (q, eps=1.0e-5) { ## Distribution function of the Cramer-von Mises statistic ## log.eps <- log(eps) y <- matrix(0, nrow=4, ncol=length(q)) for(k in 0:3) { z <- gamma(k + 0.5) * sqrt(4*k + 1)/(gamma(k+1) * pi^(3/2) * sqrt(q)) u <- (4*k + 1)^2/(16*q) y[k+1,] <- ifelse(u > -log.eps, 0, z * exp(-u) * besselK(x = u, nu=1/4)) } return(apply(y,2,sum)) } coda/R/mcmc.R0000644000176200001440000002003413343454654012435 0ustar liggesusers"[.mcmc" <- function (x, i, j, drop = missing(i)) { ## In S-PLUS the code is altered so that the user can ## pick out particular parameters by calling mcmc.obj[,c("param1", "param2")] xstart <- start(x) xthin <- thin(x) if (is.R()) { y <- NextMethod("[") } else { y <- as.matrix(x)[i,j] } if (length(y) == 0 || is.null(y)) return(y) if (missing(i)) return(mcmc(y, start = xstart, thin = xthin)) else return(y) } "as.mcmc" <- function (x, ...) UseMethod("as.mcmc") "as.mcmc.default" <- function (x, ...) if (is.mcmc(x)) x else mcmc(x) "as.ts.mcmc" <- function (x, ...) { x <- as.mcmc(x) y <- ts(x, start = start(x), end = end(x), deltat = thin(x)) attr(y, "mcpar") <- NULL return(y) } "start.mcmc" <- function (x, ...) { mcpar(as.mcmc(x))[1] } "end.mcmc" <- function (x, ...) { mcpar(as.mcmc(x))[2] } "frequency.mcmc" <- function (x, ...) { 1/thin.mcmc(x) } "thin.mcmc" <- function (x, ...) { mcpar(as.mcmc(x))[3] } "is.mcmc" <- function (x) { if (inherits(x, "mcmc")) if (length(dim(x)) == 3) stop("Obsolete mcmc object\nUpdate with a command like\nx <- mcmcUpgrade(x)") else TRUE else FALSE } "mcmc" <- function (data = NA, start = 1, end = numeric(0), thin = 1) { if (is.matrix(data)) { niter <- nrow(data) nvar <- ncol(data) } else if (is.data.frame(data)) { if (!all(sapply(data, is.numeric))) { stop ("Data frame contains non-numeric values") } data <- as.matrix(data) niter <- nrow(data) nvar <- ncol(data) } else { niter <- length(data) nvar <- 1 } thin <- round(thin) if (length(start) > 1) stop("Invalid start") if (length(end) > 1) stop("Invalid end") if (length(thin) != 1) stop("Invalid thin") if (missing(end)) end <- start + (niter - 1) * thin else if (missing(start)) start <- end - (niter - 1) * thin nobs <- floor((end - start)/thin + 1.0) ### patch if (niter < nobs) stop("Start, end and thin incompatible with data") else { end <- start + thin * (nobs - 1) if (nobs < niter) data <- data[1:nobs, , drop = FALSE] } attr(data, "mcpar") <- c(start, end, thin) attr(data, "class") <- "mcmc" data } "print.mcmc" <- function (x, ...) { x.orig <- x cat("Markov Chain Monte Carlo (MCMC) output:\nStart =", start(x), "\nEnd =", end(x), "\nThinning interval =", thin(x), "\n") attr(x, "mcpar") <- NULL attr(x, "class") <- NULL NextMethod("print", ...) invisible(x.orig) } "as.matrix.mcmc" <- function (x, iters = FALSE, ...) { y <- matrix(nrow = niter(x), ncol = nvar(x) + iters) var.cols <- iters + 1:nvar(x) if (iters) y[, 1] <- as.vector(time(x)) y[, var.cols] <- x rownames <- character(ncol(y)) if (iters) rownames[1] <- "ITER" rownames[var.cols] <- varnames(x, allow.null = FALSE) dimnames(y) <- list(NULL, rownames) return(y) } "time.mcmc" <- function (x, ...) { x <- as.mcmc(x) ts(seq(from = start(x), to = end(x), by = thin(x)), start = start(x), end = end(x), deltat = thin(x)) } "window.mcmc" <- function (x, start, end, thin, ...) { ts.eps <- getOption("ts.eps") xmcpar <- mcpar(x) xstart <- xmcpar[1] xend <- xmcpar[2] xthin <- xmcpar[3] if (missing(thin)) thin <- xthin else if (thin%%xthin != 0) { thin <- xthin warning("Thin value not changed") } xtime <- as.vector(time(x)) if (missing(start)) start <- xstart else if (length(start) != 1) stop("bad value for start") else if (start < xstart) { start <- xstart warning("start value not changed") } if (missing(end)) end <- xend else if (length(end) != 1) stop("bad value for end") else if (end > xend) { end <- xend warning("end value not changed") } if (start > end) stop("start cannot be after end") if (all(abs(xtime - start) > abs(start) * ts.eps)) { start <- xtime[(xtime > start) & ((start + xthin) > xtime)] } if (all(abs(end - xtime) > abs(end) * ts.eps)) { end <- xtime[(xtime < end) & ((end - xthin) < xtime)] } use <- 1:niter(x) use <- use[use >= trunc((start - xstart)/xthin + 1.5) & use <= trunc((end - xstart)/xthin + 1.5) & (use - trunc((start- xstart)/xthin + 1.5))%%(thin%/%xthin) == 0] y <- if (is.matrix(x)) x[use, , drop = FALSE] else x[use] return(mcmc(y, start=start, end=end, thin=thin)) } "mcpar" <- function (x) { attr(x, "mcpar") } "mcmcUpgrade" <- function (x) { if (inherits(x, "mcmc")) { if (length(dim(x)) == 3) { nchain <- dim(x)[3] xtspar <- attr(x, "tspar") xstart <- xtspar[1] xend <- xtspar[2] xthin <- xtspar[3] out <- vector("list", nchain) for (i in 1:nchain) { y <- unclass(x)[, , 1, drop = TRUE] attr(y, "title") <- NULL attr(y, "tspar") <- NULL out[[i]] <- mcmc(y, start = xstart, end = xend, thin = xthin) } if (nchain == 1) return(out[[1]]) else return(mcmc.list(out)) } else return(x) } else stop("Can't upgrade") } "thin" <- function (x, ...) UseMethod("thin") "set.mfrow" <- function (Nchains = 1, Nparms = 1, nplots = 1, sepplot = FALSE) { ## Set up dimensions of graphics window: ## If only density plots OR trace plots are requested, dimensions are: ## 1 x 1 if Nparms = 1 ## 1 X 2 if Nparms = 2 ## 2 X 2 if Nparms = 3 or 4 ## 3 X 2 if Nparms = 5 or 6 or 10 - 12 ## 3 X 3 if Nparms = 7 - 9 or >= 13 ## If both density plots AND trace plots are requested, dimensions are: ## 1 x 2 if Nparms = 1 ## 2 X 2 if Nparms = 2 ## 3 X 2 if Nparms = 3, 5, 6, 10, 11, or 12 ## 4 x 2 if Nparms otherwise ## If separate plots are requested for each chain, dimensions are: ## 1 x 2 if Nparms = 1 & Nchains = 2 ## 2 X 2 if Nparms = 2 & Nchains = 2 OR Nparms = 1 & Nchains = 3 or 4 ## 3 x 2 if Nparms = 3 or >= 5 & Nchains = 2 ## OR Nchains = 5 or 6 or 10 - 12 (and any Nparms) ## 2 x 3 if Nparms = 2 or 4 & Nchains = 3 ## 4 x 2 if Nparms = 4 & Nchains = 2 ## OR Nchains = 4 & Nparms > 1 ## 3 x 3 if Nparms = 3 or >= 5 & Nchains = 3 ## OR Nchains = 7 - 9 or >= 13 (and any Nparms) mfrow <- if (sepplot && Nchains > 1 && nplots == 1) { ## Separate plots per chain ## Only one plot per variable if (Nchains == 2) { switch(min(Nparms, 5), c(1,2), c(2,2), c(3,2), c(4,2), c(3,2)) } else if (Nchains == 3) { switch(min(Nparms, 5), c(2,2), c(2,3), c(3,3), c(2,3), c(3,3)) } else if (Nchains == 4) { if (Nparms == 1) c(2,2) else c(4,2) } else if (any(Nchains == c(5,6,10,11,12))) c(3,2) else if (any(Nchains == c(7,8,9)) || Nchains >=13) c(3,3) } else { if (nplots==1) { ## One plot per variable mfrow <- switch(min(Nparms,13), c(1,1), c(1,2), c(2,2), c(2,2), c(3,2), c(3,2), c(3,3), c(3,3), c(3,3), c(3,2), c(3,2), c(3,2), c(3,3)) } else { ## Two plot per variable ## mfrow <- switch(min(Nparms, 13), c(1,2), c(2,2), c(3,2), c(4,2), c(3,2), c(3,2), c(4,2), c(4,2), c(4,2), c(3,2), c(3,2), c(3,2), c(4,2)) } } return(mfrow) } head.mcmc <- function(x, n = 6L, ...) { window.mcmc(x, end=min(start.mcmc(x) + n * thin.mcmc(x), end.mcmc(x))) } tail.mcmc <- function(x, n = 6L, ...) { window.mcmc(x, start=max(end.mcmc(x) - n * thin.mcmc(x), start.mcmc(x))) } coda/R/thin.R0000644000176200001440000000000013343454654012447 0ustar liggesuserscoda/R/HPDinterval.R0000644000176200001440000000141513343454654013700 0ustar liggesusersHPDinterval <- function(obj, prob = 0.95, ...) UseMethod("HPDinterval") HPDinterval.mcmc <- function(obj, prob = 0.95, ...) { obj <- as.matrix(obj) vals <- apply(obj, 2, sort) if (!is.matrix(vals)) stop("obj must have nsamp > 1") nsamp <- nrow(vals) npar <- ncol(vals) gap <- max(1, min(nsamp - 1, round(nsamp * prob))) init <- 1:(nsamp - gap) inds <- apply(vals[init + gap, ,drop=FALSE] - vals[init, ,drop=FALSE], 2, which.min) ans <- cbind(vals[cbind(inds, 1:npar)], vals[cbind(inds + gap, 1:npar)]) dimnames(ans) <- list(colnames(obj), c("lower", "upper")) attr(ans, "Probability") <- gap/nsamp ans } HPDinterval.mcmc.list <- function(obj, prob = 0.95, ...) lapply(obj, HPDinterval, prob) coda/MD50000644000176200001440000000666013507650333011505 0ustar liggesusers5c9ce78c127d9d744c75d54e2063cbe0 *CHANGELOG 1741f6a3f3884b3ba7c4725f94c4bb1a *DESCRIPTION b0ab1efea562993f9f77ada2eeefd6d9 *NAMESPACE 45f88adec7bcfab586a4deebba1cc02d *R/HPDinterval.R 841853b3b96462cffe376cf9fad6abb9 *R/autocorrdiag.R 02152920c66f540422f88e51c88f0428 *R/batchSE.R 4e1a55cb0aed5bcaa0f2f9d474e2fdea *R/codamenu.R df4c85619867ba81878499f5059e875d *R/cumuplot.R 6eb43e603e56d3e1036b851a79fe7e60 *R/gelman.R 6ff93635a342cc91ae1e417da7c49485 *R/geweke.R 6fb74d6977e5e3b5190eda35829cdc23 *R/heidel.R ae77a3ec34f086bd7ec8ea787baeeb1e *R/jags.R 0473eacf2812c4d9641e1c7fd09056b4 *R/mcextractor.R 97fef151be1d2924942ca84de70c87f4 *R/mcmc.R f60ceb305b2ab088484ab63d938333d1 *R/mcmclist.R 146b8b73cb0439dabe303c4549002937 *R/output.R 389758882050a375ac4b5298a42ae35f *R/raftery.R 4caafbeb9941605b240d3ae9f6c8d5ff *R/rejectionRate.R d41d8cd98f00b204e9800998ecf8427e *R/thin.R 553b1effc0816a68e0ad4dfd7847757f *R/trellisplots.R 1e363c43c22c2a0e9658866463a0542d *R/util.R 4d7d828d6d2b4fee5357d3a4dd108458 *README b7a931790fd73a52fa8c791513540ed8 *data/line.rda 52066ed7a20504a282a091060a794d57 *inst/AUTHORS 28e8ead6b87a0c883522b26f0e163d68 *inst/CITATION 868ded8f4d10a67c7b31854bce6f3d63 *man/Cramer.Rd 7bfe602ce737efac910300e5be5a8552 *man/HPDinterval.Rd f5361dc01c864e905a9c3eb84e060c67 *man/as.ts.mcmc.Rd e3af15812b54d807e43283c5a6ca3839 *man/autocorr.Rd 166b640290894becc49eaa8434e148ee *man/autocorr.diag.Rd 592996075418b4bc21fc2c8c0016f07b *man/autocorr.plot.Rd 33d3d5b9225566ddfa188ea1bc2d4e8c *man/batchSE.Rd 04f62bd5509ba44f8e3d5bd008d37b8d *man/bugs2jags.Rd 0023199e085a06a4f108837df7256615 *man/coda.options.Rd 04dd4994917068f5d36fbcff921deb7f *man/codamenu.Rd d3b21ba8f4c82fd92adfb1d4380d4cc8 *man/crosscorr.Rd 80c2893a13683e442443b36764810498 *man/crosscorr.plot.Rd 18609dc8a896f624c979de557280cbf0 *man/cumuplot.Rd 586e55b5b9734e6577b1ad18126f1aed *man/densplot.Rd 2b5bbbb8d683384c9287a9c8e1f7a01f *man/effectiveSize.Rd c78c35ac982bcd74befe51f98ba641e4 *man/gelman.diag.Rd 7ba296f967f09f88417e8910cd008963 *man/gelman.plot.Rd aa5ee817bb15d58b4fd40089432ba99b *man/geweke.diag.Rd efd11972209251ece16ec61d8326bdce *man/geweke.plot.Rd 0c3865e05310e0a2ea9af0e4912ed036 *man/heidel.diag.Rd 5fc3363fee1907a6c2ba1567cf40eea2 *man/linepost.Rd 4c57d4e645396dd72ce68e474e7e3dcf *man/mcmc.Rd e32d079a18aa183c78933b01da34a4b2 *man/mcmc.convert.Rd e32462705734dbab825107b00fc3d8b0 *man/mcmc.list.Rd 8e47ffb91930e7f05171861b666c71b5 *man/mcmc.subset.Rd b643882eba3addb4056061302f066dc3 *man/mcmcUpgrade.Rd 20ab76f06dc525cc257595c45806b9df *man/mcpar.Rd abd1a1971d45c3e9879653251c9151bb *man/multi.menu.Rd 0cdc30ee6925803966d3ab0af99bd66e *man/nchain.Rd 695aed5c821bd040641f208a77d16e91 *man/plot.mcmc.Rd 4bcbf725908738ebf08b0fba4076b621 *man/raftery.diag.Rd a1ad06e437edaf6302d48a5a727e35db *man/read.and.check.Rd 16d3c6ae70ad0ed890dc73d182c698c0 *man/read.coda.Rd 70b940b3dac77266ea945207f7ddfbc2 *man/read.coda.interactive.Rd 32efc0825ddcecdf1ad52a7acb738905 *man/read.openbugs.Rd 33c10a06a721c1cc5d0d4439c5d9fb28 *man/rejectionRate.Rd ebcd8ee89d1f3af805963f1e1333a2be *man/spectrum0.Rd 417619066fa9367a3e6a5c6c33a6fa25 *man/spectrum0.ar.Rd 1e1eca44b09a15921da4416e9e891047 *man/summary.mcmc.Rd 54f2dfd12079753baa57a248db815ce8 *man/thin.Rd 21dfd4f22d65bdea5153a83b4dd16840 *man/time.mcmc.Rd 70b102ac597896ee4dd2db87daca8fa5 *man/traceplot.Rd 697c427c1b220f52444f66e05a895579 *man/trellisplots.Rd 4b44de8c8b54df57e83be296d9c75ed7 *man/varnames.Rd 18042191cfa6ac3659b1be6a7460bfdb *man/window.mcmc.Rd coda/README0000644000176200001440000000305413343454654012055 0ustar liggesusersCODA is a set of tools for analyzing the output of Markov Chain Monte Carlo (MCMC) simulations and diagnosing lack of convergence. The S original can be downloaded from http://www.mrc-bsu.cam.ac.uk and is Copyright (C) MRC Biostatistics Unit 1995. The CODA S manual contained these acknowledgements "The support of the Economic and Social Research Council (UK) is gratefully acknowledged. The work was funded in part by ESRC (UK) award number H519 25 5023. We are also grateful to Brad Carlin for many helpful comments and ideas concerning the CODA software and manual, and to Steve Brooks for suggesting the graphical implementations of the Geweke and Gelman & Rubin convergence diagnostics." See "CHANGELOG" for information on the changes in the R version. Martyn Plummer 20/5/1998 ###################################################################### Copying CODA for R `CODA' is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. `CODA' is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. A copy of the GNU General Public License is available on the World Wide Web at http://www.gnu.org/copyleft/gpl.html. You can also obtain it by writing to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. coda/DESCRIPTION0000644000176200001440000000231213507650333012671 0ustar liggesusersPackage: coda Version: 0.19-3 Date: 2019-07-05 Title: Output Analysis and Diagnostics for MCMC Authors@R: c(person("Martyn", "Plummer", role=c("aut","cre","trl"), email="martyn.plummer@gmail.com"), person("Nicky", "Best", role="aut"), person("Kate", "Cowles", role="aut"), person("Karen", "Vines", role="aut"), person("Deepayan", "Sarkar", role="aut"), person("Douglas", "Bates", role="aut"), person("Russell", "Almond", role="aut"), person("Arni", "Magnusson", role="aut")) Depends: R (>= 2.14.0) Imports: lattice Description: Provides functions for summarizing and plotting the output from Markov Chain Monte Carlo (MCMC) simulations, as well as diagnostic tests of convergence to the equilibrium distribution of the Markov chain. License: GPL (>= 2) NeedsCompilation: no Packaged: 2019-07-05 12:32:44 UTC; martyn Author: Martyn Plummer [aut, cre, trl], Nicky Best [aut], Kate Cowles [aut], Karen Vines [aut], Deepayan Sarkar [aut], Douglas Bates [aut], Russell Almond [aut], Arni Magnusson [aut] Maintainer: Martyn Plummer Repository: CRAN Date/Publication: 2019-07-05 13:30:03 UTC coda/man/0000755000176200001440000000000013507641341011737 5ustar liggesuserscoda/man/densplot.Rd0000644000176200001440000000427213343454654014072 0ustar liggesusers\name{densplot} \alias{densplot} \title{Probability density function estimate from MCMC output} \usage{densplot(x, show.obs = TRUE, bwf, ylim, xlab, ylab = "", type="l", main, right=TRUE, \ldots)} \arguments{ \item{x}{An \code{mcmc} or \code{mcmc.list} object} \item{show.obs}{Show observations along the x-axis} \item{bwf}{Function for calculating the bandwidth. If omitted, the bandwidth is calculate by 1.06 times the minimum of the standard deviation and the interquartile range divided by 1.34 times the sample size to the negative one fifth power} \item{ylim}{Limits on y axis. See \code{plot.window}} \item{xlab}{X-axis label. By default this will show the sample size and the bandwidth used for smoothing. See \code{plot}} \item{ylab}{Y-axis label. By default, this is blank. See \code{plot}} \item{type}{Plot type. See \code{plot}} \item{main}{An overall title for the plot. See \code{title}} \item{right}{Logical flag for discrete-valued distributions passed to the \code{hist} function. See Details}. \item{\dots}{Further graphical parameters} } \description{ Displays a plot of the density estimate for each variable in \code{x}, calculated by the \code{density} function. For discrete-valued variables, a histogram is produced. } \details{ For discrete-valued distributions, a histogram is produced and values are aggregated using the pretty() function. By default, tick marks appear to the right of the corresponding bar in the histogram and give the inclusive upper limit of the hist (\code{right=TRUE}). This can be modified by specifying \code{right=FALSE}. In this case tick marks appear on the left and specify the inclusive lower limit of the bar. For continous distributions, if a variable is bounded below at 0, or bounded in the interval [0,1], then the data are reflected at the boundary before being passed to the density() function. This allows correct estimation of a non-zero density at the boundary. } \note{ You can call this function directly, but it is more usually called by the \code{plot.mcmc} function. } \seealso{ \code{\link{density}}, \code{\link{hist}}, \code{\link{plot.mcmc}}. } \keyword{hplot} coda/man/traceplot.Rd0000644000176200001440000000156513343454654014241 0ustar liggesusers\name{traceplot} \alias{traceplot} \title{Trace plot of MCMC output} \usage{traceplot(x, smooth = FALSE, col = 1:6, type = "l", xlab = "Iterations", ylab = "", \dots)} \arguments{ \item{x}{An \code{mcmc} or \code{mcmc.list} object} \item{smooth}{draw smooth line through trace plot} \item{col}{graphical parameter (see \code{par})} \item{type}{graphical parameter (see \code{plot})} \item{xlab}{graphical parameter (see \code{plot})} \item{ylab}{graphical parameter (see \code{plot})} \item{\dots}{further graphical parameters} } \description{ Displays a plot of iterations \emph{vs.} sampled values for each variable in the chain, with a separate plot per variable. } \note{ You can call this function directly, but it is more usually called by the \code{plot.mcmc} function. } \seealso{ \code{\link{densplot}}, \code{\link{plot.mcmc}}. } \keyword{hplot} coda/man/geweke.diag.Rd0000644000176200001440000000305613343454654014413 0ustar liggesusers\name{geweke.diag} \alias{geweke.diag} %\alias{print.geweke.diag} \title{Geweke's convergence diagnostic} \usage{geweke.diag(x, frac1=0.1, frac2=0.5)} \arguments{ \item{x}{an mcmc object} \item{frac1}{fraction to use from beginning of chain} \item{frac2}{fraction to use from end of chain} } \value{ Z-scores for a test of equality of means between the first and last parts of the chain. A separate statistic is calculated for each variable in each chain. } \description{ Geweke (1992) proposed a convergence diagnostic for Markov chains based on a test for equality of the means of the first and last part of a Markov chain (by default the first 10\% and the last 50\%). If the samples are drawn from the stationary distribution of the chain, the two means are equal and Geweke's statistic has an asymptotically standard normal distribution. The test statistic is a standard Z-score: the difference between the two sample means divided by its estimated standard error. The standard error is estimated from the spectral density at zero and so takes into account any autocorrelation. The Z-score is calculated under the assumption that the two parts of the chain are asymptotically independent, which requires that the sum of \code{frac1} and \code{frac2} be strictly less than 1. } \seealso{ \code{\link{geweke.plot}}. } \references{ Geweke, J. Evaluating the accuracy of sampling-based approaches to calculating posterior moments. In \emph{Bayesian Statistics 4} (ed JM Bernado, JO Berger, AP Dawid and AFM Smith). Clarendon Press, Oxford, UK.} \keyword{htest} coda/man/geweke.plot.Rd0000644000176200001440000000344513343454654014467 0ustar liggesusers\name{geweke.plot} \alias{geweke.plot} \title{Geweke-Brooks plot} \usage{ geweke.plot(x, frac1 = 0.1, frac2 = 0.5, nbins = 20, pvalue = 0.05, auto.layout = TRUE, ask, \dots) } \arguments{ \item{x}{an mcmc object} \item{frac1}{fraction to use from beginning of chain.} \item{frac2}{fraction to use from end of chain.} \item{nbins}{Number of segments.} \item{pvalue}{p-value used to plot confidence limits for the null hypothesis.} \item{auto.layout}{If \code{TRUE} then, set up own layout for plots, otherwise use existing one.} \item{ask}{If \code{TRUE} then prompt user before displaying each page of plots. Default is \code{dev.interactive()} in R and \code{interactive()} in S-PLUS.} \item{\dots}{Graphical parameters.} } \description{ If \code{geweke.diag} indicates that the first and last part of a sample from a Markov chain are not drawn from the same distribution, it may be useful to discard the first few iterations to see if the rest of the chain has "converged". This plot shows what happens to Geweke's Z-score when successively larger numbers of iterations are discarded from the beginning of the chain. To preserve the asymptotic conditions required for Geweke's diagnostic, the plot never discards more than half the chain. The first half of the Markov chain is divided into \code{nbins - 1} segments, then Geweke's Z-score is repeatedly calculated. The first Z-score is calculated with all iterations in the chain, the second after discarding the first segment, the third after discarding the first two segments, and so on. The last Z-score is calculated using only the samples in the second half of the chain. } \note{ The graphical implementation of Geweke's diagnostic was suggested by Steve Brooks. } \seealso{ \code{\link{geweke.diag}}. } \keyword{hplot} coda/man/mcmc.convert.Rd0000644000176200001440000000301413343454654014631 0ustar liggesusers\name{mcmc.convert} \alias{as.matrix.mcmc} \alias{as.matrix.mcmc.list} \alias{as.array.mcmc.list} \alias{as.mcmc.mcmc.list} \title{Conversions of MCMC objects} \usage{ \method{as.matrix}{mcmc}(x, iters = FALSE, ...) \method{as.matrix}{mcmc.list}(x, iters = FALSE, chains = FALSE, ...) \method{as.array}{mcmc.list}(x, drop, ...) } \arguments{ \item{x}{An \code{mcmc} or \code{mcmc.list} object} \item{iters}{logical flag: add column for iteration number?} \item{chains}{logical flag: add column for chain number? (if mcmc.list)} \item{drop}{logical flag: if \code{TRUE} the result is coerced to the lowest possible dimension} \item{...}{optional arguments to the various methods} } \description{ These are methods for the generic functions \code{as.matrix()}, \code{as.array()} and \code{as.mcmc()}. \code{as.matrix()} strips the MCMC attributes from an \code{mcmc} object and returns a matrix. If \code{iters = TRUE} then a column is added with the iteration number. For \code{mcmc.list} objects, the rows of multiple chains are concatenated and, if \code{chains = TRUE} a column is added with the chain number. \code{mcmc.list} objects can be coerced to 3-dimensional arrays with the \code{as.array()} function. An \code{mcmc.list} object with a single chain can be coerced to an \code{mcmc} object with \code{as.mcmc()}. If the argument has multiple chains, this causes an error. } \seealso{ \code{\link{as.matrix}}, \code{\link{as.array}}, \code{\link{as.mcmc}}, } \keyword{array} coda/man/mcpar.Rd0000644000176200001440000000074013343454654013340 0ustar liggesusers\name{mcpar} \alias{mcpar} \title{Mcpar attribute of MCMC objects} \usage{ mcpar(x) } \arguments{ \item{x}{An \code{mcmcm} or \code{mcmc.list} object} } \description{ The `mcpar' attribute of an MCMC object gives the start iteration the end iteration and the thinning interval of the chain. It resembles the `tsp' attribute of time series (\code{ts}) objects. } \seealso{ \code{\link{ts}}, \code{\link{mcmc}}, \code{\link{mcmc.list}}, } \keyword{ts} coda/man/read.coda.Rd0000644000176200001440000000322713343454654014061 0ustar liggesusers\name{read.coda} \alias{read.coda} \alias{read.jags} \title{Read output files in CODA format} \usage{ read.coda(output.file, index.file, start, end, thin, quiet=FALSE) read.jags(file = "jags.out", start, end, thin, quiet=FALSE) } \arguments{ \item{output.file}{The name of the file containing the monitored output} \item{index.file}{The name of the file containing the index, showing which rows of the output file correspond to which variables} \item{file}{For JAGS output, the name of the output file. The extension ".out" may be omitted. There must be a corresponding ".ind" file with the same file stem.} \item{start}{First iteration of chain} \item{end}{Last iteration of chain} \item{thin}{Thinning interval for chain} \item{quiet}{Logical flag. If true, a progress summary will be printed} } \description{ \code{read.coda} reads Markov Chain Monte Carlo output in the CODA format produced by OpenBUGS and JAGS. By default, all of the data in the file is read, but the arguments \code{start}, \code{end} and \code{thin} may be used to read a subset of the data. If the arguments given to \code{start}, \code{end} or \code{thin} are incompatible with the data, they are ignored. } \value{ An object of class \code{mcmc} containing a representation of the data in the file. } \references{ Spiegelhalter DJ, Thomas A, Best NG and Gilks WR (1995). \emph{BUGS: Bayesian inference Using Gibbs Sampling, Version 0.50.} MRC Biostatistics Unit, Cambridge. } \author{Karen Vines, Martyn Plummer} \seealso{ \code{\link{mcmc}}, \code{\link{read.coda.interactive}}, \code{\link{read.openbugs}}. } \keyword{file} coda/man/cumuplot.Rd0000644000176200001440000000150413343454654014105 0ustar liggesusers\name{cumuplot} \alias{cumuplot} \title{Cumulative quantile plot} \usage{ cumuplot(x, probs=c(0.025,0.5,0.975), ylab="", lty=c(2,1), lwd=c(1,2), type="l", ask, auto.layout=TRUE, col=1, \dots) } \arguments{ \item{x}{an \code{mcmc} object} \item{probs}{vector of desired quantiles} \item{ylab, lty, lwd, type, col}{graphical parameters} \item{auto.layout}{If \code{TRUE}, then set up own layout for plots, otherwise use existing one.} \item{ask}{If \code{TRUE} then prompt user before displaying each page of plots. Default is \code{dev.interactive()} in R and \code{interactive()} in S-PLUS.} \item{\dots}{further graphical parameters} } \description{ Plots the evolution of the sample quantiles as a function of the number of iterations. } \author{Arni Magnusson} \keyword{hplot} coda/man/HPDinterval.Rd0000644000176200001440000000303013343454654014411 0ustar liggesusers\name{HPDinterval} \alias{HPDinterval} \alias{HPDinterval.mcmc} \alias{HPDinterval.mcmc.list} \title{Highest Posterior Density intervals} \description{ Create Highest Posterior Density (HPD) intervals for the parameters in an MCMC sample. } \usage{ HPDinterval(obj, prob = 0.95, \dots) \method{HPDinterval}{mcmc}(obj, prob = 0.95, \dots) \method{HPDinterval}{mcmc.list}(obj, prob = 0.95, \dots) } \arguments{ \item{obj}{The object containing the MCMC sample - usually of class \code{"mcmc"} or \code{"mcmc.list"}}. \item{prob}{A numeric scalar in the interval (0,1) giving the target probability content of the intervals. The nominal probability content of the intervals is the multiple of \code{1/nrow(obj)} nearest to \code{prob}.} \item{\dots}{Optional additional arguments for methods. None are used at present.} } \details{ For each parameter the interval is constructed from the empirical cdf of the sample as the shortest interval for which the difference in the ecdf values of the endpoints is the nominal probability. Assuming that the distribution is not severely multimodal, this is the HPD interval. } \value{ For an \code{"mcmc"} object, a matrix with columns \code{"lower"} and \code{"upper"} and rows corresponding to the parameters. The attribute \code{"Probability"} is the nominal probability content of the intervals. A list of such matrices is returned for an \code{"mcmc.list"} object. } \author{Douglas Bates} \examples{ data(line) HPDinterval(line) } \keyword{univar} \keyword{htest} coda/man/bugs2jags.Rd0000644000176200001440000000227613343454654014133 0ustar liggesusers\name{bugs2jags} \alias{bugs2jags} \title{Convert WinBUGS data file to JAGS data file} \usage{ bugs2jags(infile, outfile) } \arguments{ \item{infile}{name of the input file} \item{outfile}{name of the output file} } \description{ \code{bugs2jags} converts a WinBUGS data in the format called "S-Plus" (i.e. the format created by the \code{dput} function) and writes it in \code{dump} format used by JAGS. NB WinBUGS stores its arrays in row order. This is different from R and JAGS which both store arrays in column order. This difference is taken into account by \code{bugs2jags} which will automatically reorder the data in arrays, without changing the dimension. Not yet available in S-PLUS. } \note{ If the input file is saved from WinBUGS, it must be saved in plain text format. The default format for files saved from WinBUGS is a binary compound document format (with extension odc) that cannot be read by bugs2jags. } \references{ Spiegelhalter DJ, Thomas A, Best NG and Lunn D (2003). \emph{WinBUGS version 1.4 user manual} MRC Biostatistics Unit, Cambridge, UK. } \author{Martyn Plummer} \seealso{ \code{\link{dput}}, \code{\link{dump}}. } \keyword{file} coda/man/crosscorr.plot.Rd0000644000176200001440000000145113343454654015232 0ustar liggesusers\name{crosscorr.plot} \alias{crosscorr.plot} \title{Plot image of correlation matrix} \usage{crosscorr.plot (x, col = topo.colors(10), \dots)} \arguments{ \item{x}{an \code{mcmc} or \code{mcmc.list} object} \item{col}{color palette to use} \item{\dots}{graphical parameters} } \description{ \code{crosscorr.plot} provides an image of the correlation matrix for \code{x}. If \code{x} is an \code{mcmc.list} object, then all chains are combined. The range [-1,1] is divided into a number of equal-length categories given by the length of \code{col} and assigned the corresponding color. By default, topographic colours are used as this makes it easier to distinguish positive and negative correlations. } \seealso{ \code{\link{crosscorr}}, \code{\link{image}}, \code{\link{topo.colors}}. } \keyword{hplot} coda/man/coda.options.Rd0000644000176200001440000000645513507641341014640 0ustar liggesusers\name{coda.options} \alias{coda.options} \alias{display.coda.options} \alias{.Coda.Options} \alias{.Coda.Options.Default} \title{Options settings for the codamenu driver} \usage{ coda.options(\dots) display.coda.options(stats = FALSE, plots = FALSE, diags = FALSE) } \arguments{ \item{stats}{logical flag: show summary statistic options?} \item{plots}{logical flag: show plotting options?} \item{diags}{logical flag: show plotting options?} \item{\dots}{list of options} } \description{ \code{coda.options} is a utility function that queries and sets options for the \code{codamenu()} function. These settings affect the behaviour of the functions in the coda library only when they are called via the \code{codamenu()} interface. The \code{coda.options()} function behaves just like the \code{options()} function in the base library, with the additional feature that \code{coda.options(default=TRUE)} will reset all options to the default values. Options can be pretty-printed using the \code{display.coda.options()} function, which groups the options into sections. Available options are \describe{ \item{bandwidth}{Bandwidth function used when smoothing samples to produce density estimates. Defaults to Silverman's ``Rule of thumb''.} \item{combine.corr}{Logical option that determines whether to combine multiple chains when calculating cross-correlations.} \item{combine.plots}{Logical option that determines whether to combine multiple chains when plotting.} \item{combine.plots}{Logical option that determines whether to combine multiple chains when calculating summary statistics.} \item{data.saved}{For internal use only.} \item{densplot}{Logical option that determines whether to plot a density plot when plot methods are called for mcmc objects.} \item{digits}{Number of significant digits to use when printing.} \item{frac1}{For Geweke diagnostic, fraction to use from start of chain. Defaults to 0.1} \item{frac2}{For Geweke diagnostic, fraction to use from end of chain. Default to 0.5.} \item{gr.bin}{For Geweke-Brooks plot, number of iterations to use per bin.} \item{gr.max}{For Geweke-Brooks plot, maximum number of bins to use. This option overrides \code{gr.bin}.} \item{halfwidth}{For Heidelberger and Welch diagnostic, the target value for the ratio of half width to sample mean.} \item{lowess}{Logical option that controls whether to plot a smooth line through a trace plot when plotting MCMC output.} \item{q}{For Raftery and Lewis diagnostic, the target quantile to be estimated} \item{r}{For Raftery and Lewis diagnostic, the required precision.} \item{s}{For Raftery and Lewis diagnostic, the probability of obtaining an estimate in the interval (q-r, q+r).} \item{quantiles}{Vector of quantiles to print when calculating summary statistics for MCMC output.} \item{trace}{Logical option that determines whether to plot a trace of the sampled output when plotting MCMC output.} \item{user.layout}{Logical option that determines whether current value of par("mfrow") should be used for plots (TRUE) or whether the optimal layout should be calculated (FALSE).} } } \seealso{ \code{\link{options}} } \keyword{utilities} coda/man/autocorr.plot.Rd0000644000176200001440000000127113343454654015051 0ustar liggesusers\name{autocorr.plot} \alias{autocorr.plot} \title{Plot autocorrelations for Markov Chains} \usage{autocorr.plot(x, lag.max, auto.layout = TRUE, ask, \dots)} \arguments{ \item{x}{A Markov Chain} \item{lag.max}{Maximum value at which to calculate acf} \item{auto.layout}{If \code{TRUE} then, set up own layout for plots, otherwise use existing one.} \item{ask}{If \code{TRUE} then prompt user before displaying each page of plots. Default is \code{dev.interactive()} in R and \code{interactive()} in S-PLUS.} \item{\dots}{graphical parameters} } \description{ Plots the autocorrelation function for each variable in each chain in x. } \seealso{ \code{\link{autocorr}}. } \keyword{hplot} coda/man/spectrum0.ar.Rd0000644000176200001440000000200713343454654014557 0ustar liggesusers\name{spectrum0.ar} \alias{spectrum0.ar} \title{Estimate spectral density at zero} \description{ The spectral density at frequency zero is estimated by fitting an autoregressive model. \code{spectrum0(x)/length(x)} estimates the variance of \code{mean(x)}. } \usage{ spectrum0.ar(x) } \arguments{ \item{x}{A time series.} } \details{ The \code{ar()} function to fit an autoregressive model to the time series x. For multivariate time series, separate models are fitted for each column. The value of the spectral density at zero is then given by a well-known formula. } \value{ A list with the following values \item{spec}{The predicted value of the spectral density at frequency zero.} \item{order}{The order of the fitted model} } \note{ The definition of the spectral density used here differs from that used by \code{spec.pgram}. We consider the frequency range to be between 0 and 0.5, not between 0 and \code{frequency(x)/2}. } \seealso{ \code{\link{spectrum}}, \code{\link{spectrum0}}, \code{\link{glm}}. } \keyword{ts} coda/man/autocorr.Rd0000644000176200001440000000225213343454654014074 0ustar liggesusers\name{autocorr} \alias{autocorr} \title{Autocorrelation function for Markov chains} \usage{autocorr(x, lags = c(0, 1, 5, 10, 50), relative=TRUE)} \arguments{ \item{x}{an mcmc object} \item{lags}{a vector of lags at which to calculate the autocorrelation} \item{relative}{a logical flag. TRUE if lags are relative to the thinning interval of the chain, or FALSE if they are absolute difference in iteration numbers} } \description{ \code{autocorr} calculates the autocorrelation function for the Markov chain \code{mcmc.obj} at the lags given by \code{lags}. The lag values are taken to be relative to the thinning interval if \code{relative=TRUE}. High autocorrelations within chains indicate slow mixing and, usually, slow convergence. It may be useful to thin out a chain with high autocorrelations before calculating summary statistics: a thinned chain may contain most of the information, but take up less space in memory. Re-running the MCMC sampler with a different parameterization may help to reduce autocorrelation. } \value{ A vector or array containing the autocorrelations. } \author{Martyn Plummer} \seealso{ \code{\link{acf}}, \code{\link{autocorr.plot}}. } \keyword{ts} coda/man/effectiveSize.Rd0000644000176200001440000000162013343454654015027 0ustar liggesusers\name{effectiveSize} \alias{effectiveSize} \title{Effective sample size for estimating the mean} \description{ Sample size adjusted for autocorrelation. } \usage{ effectiveSize(x) } \arguments{ \item{x}{An mcmc or mcmc.list object.} } \details{ For a time series \code{x} of length \code{N}, the standard error of the mean is the square root of \code{var(x)/n} where \code{n} is the effective sample size. \code{n = N} only when there is no autocorrelation. Estimation of the effective sample size requires estimating the spectral density at frequency zero. This is done by the function \code{spectrum0.ar} For a \code{mcmc.list} object, the effective sizes are summed across chains. To get the size for each chain individually use \code{lapply(x,effectiveSize)}. } \value{ A vector giving the effective sample size for each column of \code{x}. } \seealso{ \code{\link{spectrum0.ar}}. } \keyword{ts} coda/man/heidel.diag.Rd0000644000176200001440000000544113343454654014376 0ustar liggesusers\name{heidel.diag} \alias{heidel.diag} %\alias{print.heidel.diag} \title{Heidelberger and Welch's convergence diagnostic} \usage{heidel.diag(x, eps=0.1, pvalue=0.05)} \arguments{ \item{x}{An \code{mcmc} object} \item{eps}{Target value for ratio of halfwidth to sample mean} \item{pvalue}{significance level to use} } \description{ \code{heidel.diag} is a run length control diagnostic based on a criterion of relative accuracy for the estimate of the mean. The default setting corresponds to a relative accuracy of two significant digits. \code{heidel.diag} also implements a convergence diagnostic, and removes up to half the chain in order to ensure that the means are estimated from a chain that has converged. } \details{ The convergence test uses the Cramer-von-Mises statistic to test the null hypothesis that the sampled values come from a stationary distribution. The test is successively applied, firstly to the whole chain, then after discarding the first 10\%, 20\%, \ldots of the chain until either the null hypothesis is accepted, or 50\% of the chain has been discarded. The latter outcome constitutes `failure' of the stationarity test and indicates that a longer MCMC run is needed. If the stationarity test is passed, the number of iterations to keep and the number to discard are reported. The half-width test calculates a 95\% confidence interval for the mean, using the portion of the chain which passed the stationarity test. Half the width of this interval is compared with the estimate of the mean. If the ratio between the half-width and the mean is lower than \code{eps}, the halfwidth test is passed. Otherwise the length of the sample is deemed not long enough to estimate the mean with sufficient accuracy. } \section{Theory}{ The \code{heidel.diag} diagnostic is based on the work of Heidelberger and Welch (1983), who combined their earlier work on simulation run length control (Heidelberger and Welch, 1981) with the work of Schruben (1982) on detecting initial transients using Brownian bridge theory. } \note{ If the half-width test fails then the run should be extended. In order to avoid problems caused by sequential testing, the test should not be repeated too frequently. Heidelberger and Welch (1981) suggest increasing the run length by a factor I > 1.5, each time, so that estimate has the same, reasonably large, proportion of new data. } \references{ Heidelberger P and Welch PD. A spectral method for confidence interval generation and run length control in simulations. Comm. ACM. \bold{24}, 233-245 (1981) Heidelberger P and Welch PD. Simulation run length control in the presence of an initial transient. \emph{Opns Res.}, \bold{31}, 1109-44 (1983) Schruben LW. Detecting initialization bias in simulation experiments. \emph{Opns. Res.}, \bold{30}, 569-590 (1982). } \keyword{htest} coda/man/gelman.diag.Rd0000644000176200001440000001235213343454654014406 0ustar liggesusers\name{gelman.diag} \alias{gelman.diag} %\alias{gelman.mv.diag} %\alias{gelman.transform} %\alias{print.gelman.diag} \title{Gelman and Rubin's convergence diagnostic} \usage{gelman.diag(x, confidence = 0.95, transform=FALSE, autoburnin=TRUE, multivariate=TRUE)} \arguments{ \item{x}{An \code{mcmc.list} object with more than one chain, and with starting values that are overdispersed with respect to the posterior distribution.} \item{confidence}{the coverage probability of the confidence interval for the potential scale reduction factor} \item{transform}{a logical flag indicating whether variables in \code{x} should be transformed to improve the normality of the distribution. If set to TRUE, a log transform or logit transform, as appropriate, will be applied.} \item{autoburnin}{a logical flag indicating whether only the second half of the series should be used in the computation. If set to TRUE (default) and \code{start(x)} is less than \code{end(x)/2} then start of series will be adjusted so that only second half of series is used.} \item{multivariate}{a logical flag indicating whether the multivariate potential scale reduction factor should be calculated for multivariate chains} } \description{ The `potential scale reduction factor' is calculated for each variable in \code{x}, together with upper and lower confidence limits. Approximate convergence is diagnosed when the upper limit is close to 1. For multivariate chains, a multivariate value is calculated that bounds above the potential scale reduction factor for any linear combination of the (possibly transformed) variables. The confidence limits are based on the assumption that the stationary distribution of the variable under examination is normal. Hence the `transform' parameter may be used to improve the normal approximation. } \value{ An object of class \code{gelman.diag}. This is a list with the following elements: \item{psrf}{A list containing the point estimates of the potential scale reduction factor (labelled \code{Point est.}) and their upper confidence limits (labelled \code{Upper C.I.}).} \item{mpsrf}{The point estimate of the multivariate potential scale reduction factor. This is NULL if there is only one variable in \code{x}.} The \code{gelman.diag} class has its own \code{print} method. } \section{Theory}{ Gelman and Rubin (1992) propose a general approach to monitoring convergence of MCMC output in which \eqn{m > 1} parallel chains are run with starting values that are overdispersed relative to the posterior distribution. Convergence is diagnosed when the chains have `forgotten' their initial values, and the output from all chains is indistinguishable. The \code{gelman.diag} diagnostic is applied to a single variable from the chain. It is based a comparison of within-chain and between-chain variances, and is similar to a classical analysis of variance. There are two ways to estimate the variance of the stationary distribution: the mean of the empirical variance within each chain, \eqn{W}, and the empirical variance from all chains combined, which can be expressed as \deqn{ \widehat{\sigma}^2 = \frac{(n-1) W }{n} + \frac{B}{n} }{ sigma.hat^2 = (n-1)W/n + B/n } where \eqn{n} is the number of iterations and \eqn{B/n} is the empirical between-chain variance. If the chains have converged, then both estimates are unbiased. Otherwise the first method will \emph{underestimate} the variance, since the individual chains have not had time to range all over the stationary distribution, and the second method will \emph{overestimate} the variance, since the starting points were chosen to be overdispersed. The convergence diagnostic is based on the assumption that the target distribution is normal. A Bayesian credible interval can be constructed using a t-distribution with mean \deqn{\widehat{\mu}=\mbox{Sample mean of all chains combined}}{mu.hat = Sample mean of all chains combined} and variance \deqn{\widehat{V}=\widehat{\sigma}^2 + \frac{B}{mn}}{V.hat=sigma.hat2 + B/(mn)} and degrees of freedom estimated by the method of moments \deqn{d = \frac{2*\widehat{V}^2}{\mbox{Var}(\widehat{V})}}{d = 2*V.hat^2/Var(V.hat)} Use of the t-distribution accounts for the fact that the mean and variance of the posterior distribution are estimated. The convergence diagnostic itself is \deqn{R=\sqrt{\frac{(d+3) \widehat{V}}{(d+1)W}}}{R=sqrt((d+3) V.hat /((d+1)W)} Values substantially above 1 indicate lack of convergence. If the chains have not converged, Bayesian credible intervals based on the t-distribution are too wide, and have the potential to shrink by this factor if the MCMC run is continued. } \note{ The multivariate a version of Gelman and Rubin's diagnostic was proposed by Brooks and Gelman (1998). Unlike the univariate proportional scale reduction factor, the multivariate version does not include an adjustment for the estimated number of degrees of freedom. } \references{ Gelman, A and Rubin, DB (1992) Inference from iterative simulation using multiple sequences, \emph{Statistical Science}, \bold{7}, 457-511. Brooks, SP. and Gelman, A. (1998) General methods for monitoring convergence of iterative simulations. \emph{Journal of Computational and Graphical Statistics}, \bold{7}, 434-455. } \seealso{ \code{\link{gelman.plot}}. } \keyword{htest} coda/man/window.mcmc.Rd0000644000176200001440000000221613343454654014463 0ustar liggesusers\name{window.mcmc} \alias{window.mcmc} \alias{window.mcmc.list} \title{Time windows for mcmc objects} \usage{ \method{window}{mcmc}(x, start, end, thin, \dots) } \arguments{ \item{x}{an mcmc object} \item{start}{the first iteration of interest} \item{end}{the last iteration of interest} \item{thin}{the required interval between successive samples} \item{\dots}{futher arguments for future methods} } \description{ \code{window.mcmc} is a method for \code{mcmc} objects which is normally called by the generic function \code{window} In addition to the generic parameters, \code{start} and \code{end} the additional parameter \code{thin} may be used to thin out the Markov chain. Setting thin=k selects every kth iteration starting with the first. Note that the value of \code{thin} is \emph{absolute} not relative. The value supplied given to the parameter \code{thin} must be a multiple of \code{thin(x)}. Values of \code{start}, \code{end} and \code{thin} which are inconsistent with \code{x} are ignored, but a warning message is issued. } \seealso{ \code{\link{window}}, \code{\link{thin}}. } \keyword{ts} coda/man/crosscorr.Rd0000644000176200001440000000110013343454654014244 0ustar liggesusers\name{crosscorr} \alias{crosscorr} \title{Cross correlations for MCMC output} \usage{crosscorr(x)} \arguments{ \item{x}{an \code{mcmc} or \code{mcmc.list} object.} } \description{ \code{crosscorr} calculates cross-correlations between variables in Markov Chain Monte Carlo output. If \code{x} is an mcmc.list then all chains in \code{x} are combined before calculating the correlation. } \value{ A matrix or 3-d array containing the correlations. } \seealso{ \code{\link{crosscorr.plot}}, \code{\link{autocorr}}. } \keyword{multivariate} \keyword{array} coda/man/read.coda.interactive.Rd0000644000176200001440000000173213343454654016374 0ustar liggesusers\name{read.coda.interactive} \alias{read.coda.interactive} \title{Read CODA output files interactively} \usage{ read.coda.interactive() } \description{ \code{read.coda.interactive} reads Markov Chain Monte Carlo output in the format produced by the classic BUGS program. No arguments are required. Instead, the user is prompted for the required information. } \value{ An object of class \code{mcmc.list} containing a representation of the data in one or more BUGS output files. } \references{ Spiegelhalter DJ, Thomas A, Best NG and Gilks WR (1995). \emph{BUGS: Bayesian inference Using Gibbs Sampling, Version 0.50.} MRC Biostatistics Unit, Cambridge. } \note{ This function is normally called by the \code{codamenu} function, but can also be used on a stand-alone basis. } \author{Nicky Best, Martyn Plummer} \seealso{ \code{\link{mcmc}}, \code{\link{mcmc.list}}, \code{\link{read.coda}}, \code{\link{codamenu}}. } \keyword{file} coda/man/read.openbugs.Rd0000644000176200001440000000224013343454654014767 0ustar liggesusers\name{read.openbugs} \alias{read.openbugs} \title{Read CODA output files produced by OpenBUGS} \usage{ read.openbugs(stem="", start, end, thin, quiet=FALSE) } \arguments{ \item{stem}{Character string giving the stem for the output files. OpenBUGS produces files with names "CODAindex.txt", "CODAchain1.txt", "CODAchain2.txt", \ldots} \item{start}{First iteration of chain} \item{end}{Last iteration of chain} \item{thin}{Thinning interval for chain} \item{quiet}{Logical flag. If true, a progress summary will be printed} } \description{ \code{read.openbugs} reads Markov Chain Monte Carlo output in the CODA format produced by OpenBUGS. This is a convenience wrapper around the function \code{read.coda} which allows you to read all the data output by OpenBUGS by specifying only the file stem. } \value{ An object of class \code{mcmc.list} containing output from all chains. } \references{ Spiegelhalter DJ, Thomas A, Best NG and Lunn D (2004). \emph{WinBUGS User Manual, Version 2.0, June 2004}, MRC Biostatistics Unit, Cambridge. } \author{Martyn Plummer} \seealso{ \code{\link{read.coda}}. } \keyword{file} coda/man/mcmcUpgrade.Rd0000644000176200001440000000112513343454654014463 0ustar liggesusers\name{mcmcUpgrade} \alias{mcmcUpgrade} \title{Upgrade mcmc objects in obsolete format} \usage{ mcmcUpgrade(x) } \arguments{ \item{x}{an obsolete \code{mcmc} object.} } \description{ In previous releases of CODA, an \code{mcmc} object could be a single or multiple chains. A new class \code{mcmc.list} has now been introduced to deal with multiple chains and \code{mcmc} objects can only have data from a single chain. Objects stored in the old format are now obsolete and must be upgraded. } \author{Martyn Plummer} \seealso{ \code{\link{mcmc}}. } \keyword{ts} coda/man/summary.mcmc.Rd0000644000176200001440000000171113343454654014650 0ustar liggesusers\name{summary.mcmc} \alias{summary.mcmc} \alias{summary.mcmc.list} %\alias{print.summary.mcmc} %\alias{print.summary.mcmc.list} \title{Summary statistics for Markov Chain Monte Carlo chains} \usage{ \method{summary}{mcmc}(object, quantiles = c(0.025, 0.25, 0.5, 0.75, 0.975), \dots) } \arguments{ \item{object}{an object of class \code{mcmc} or \code{mcmc.list}} \item{quantiles}{a vector of quantiles to evaluate for each variable} \item{\dots}{a list of further arguments} } \description{ \code{summary.mcmc} produces two sets of summary statistics for each variable: Mean, standard deviation, naive standard error of the mean (ignoring autocorrelation of the chain) and time-series standard error based on an estimate of the spectral density at 0. Quantiles of the sample distribution using the \code{quantiles} argument. } \author{Martyn Plummer} \seealso{ \code{\link{mcmc}}, \code{\link{mcmc.list}}. } \keyword{univar} coda/man/trellisplots.Rd0000644000176200001440000001742313343454654015004 0ustar liggesusers\name{trellisplots} \title{Trellis plots for mcmc objects} \alias{densityplot.mcmc} \alias{levelplot.mcmc} \alias{qqmath.mcmc} \alias{xyplot.mcmc} \alias{densityplot.mcmc.list} \alias{levelplot.mcmc.list} \alias{qqmath.mcmc.list} \alias{xyplot.mcmc.list} \alias{acfplot} \alias{acfplot.mcmc} \alias{acfplot.mcmc.list} \usage{ \method{densityplot}{mcmc}(x, data, outer, aspect = "xy", default.scales = list(relation = "free"), start = 1, thin = 1, main = attr(x, "title"), xlab = "", plot.points = "rug", \dots, subset) \method{densityplot}{mcmc.list}(x, data, outer = FALSE, groups = !outer, aspect = "xy", default.scales = list(relation = "free"), start = 1, thin = 1, main = attr(x, "title"), xlab = "", plot.points = "rug", \dots, subset) \method{levelplot}{mcmc}(x, data, main = attr(x, "title"), start = 1, thin = 1, \dots, xlab = "", ylab = "", cuts = 10, at, col.regions = topo.colors(100), subset) \method{qqmath}{mcmc}(x, data, outer, aspect = "xy", default.scales = list(y = list(relation = "free")), prepanel = prepanel.qqmathline, start = 1, thin = 1, main = attr(x, "title"), ylab = "", \dots, subset) \method{qqmath}{mcmc.list}(x, data, outer = FALSE, groups = !outer, aspect = "xy", default.scales = list(y = list(relation = "free")), prepanel = prepanel.qqmathline, start = 1, thin = 1, main = attr(x, "title"), ylab = "", \dots, subset) \method{xyplot}{mcmc}(x, data, outer, layout = c(1, nvar(x)), default.scales = list(y = list(relation = "free")), type = 'l', start = 1, thin = 1, xlab = "Iteration number", ylab = "", main = attr(x, "title"), \dots, subset) \method{xyplot}{mcmc.list}(x, data, outer = FALSE, groups = !outer, aspect = "xy", layout = c(1, nvar(x)), default.scales = list(y = list(relation = "free")), type = 'l', start = 1, thin = 1, xlab = "Iteration number", ylab = "", main = attr(x, "title"), \dots, subset) acfplot(x, data, \dots) \method{acfplot}{mcmc}(x, data, outer, prepanel, panel, type = 'h', aspect = "xy", start = 1, thin = 1, lag.max = NULL, ylab = "Autocorrelation", xlab = "Lag", main = attr(x, "title"), \dots, subset) \method{acfplot}{mcmc.list}(x, data, outer = FALSE, groups = !outer, prepanel, panel, type = if (groups) 'b' else 'h', aspect = "xy", start = 1, thin = 1, lag.max = NULL, ylab = "Autocorrelation", xlab = "Lag", main = attr(x, "title"), \dots, subset) } \description{ These methods use the Trellis framework as implemented in the \code{lattice} package to produce space-conserving diagnostic plots from \code{"mcmc"} and \code{"mcmc.list"} objects. The \code{xyplot} methods produce trace plots. The \code{densityplot} methods and \code{qqmath} methods produce empirical density and probability plots. The \code{levelplot} method depicts the correlation of the series. The \code{acfplot} methods plot the auto-correlation in the series. Not yet available in S-PLUS. } \arguments{ \item{x}{ an \code{"mcmc"} or \code{"mcmc.list"} object. } \item{data}{ ignored, present for consistency with generic. } \item{outer}{ for the \code{"mcmc.list"} methods, a logical flag to control whether multiple runs of a series are displayed in the same panel (they are if \code{FALSE}, not if \code{TRUE}). If specified in the \code{"mcmc"} methods, this argument is ignored with a warning. } \item{groups}{ for the \code{"mcmc.list"} methods, a logical flag to control whether the underlying \code{lattice} call will be supplied a \code{groups} arguments indicating which run a data point originated from. The panel function is responsible for handling such an argument, and will usually differentiate runs within a panel by using different graphical parameters. When \code{outer=FALSE}, the default of \code{groups} is \code{TRUE} if the corresponding default panel function is able to make use of such information. When \code{outer=FALSE}, \code{groups=TRUE} will be ignored with a warning. } \item{aspect}{ controls the physical aspect ratio of the panel. See \code{\link[lattice:xyplot]{xyplot}} for details. The default for these methods is chosen carefully - check what the default plot looks like before changing this parameter.} \item{default.scales}{ this parameter provides a reasonable default value of the \code{scales} parameter for the method. It is unlikely that a user will wish to change this parameter. Pass a value for \code{scales} (see \code{\link[lattice:xyplot]{xyplot}}) instead, which will override values specified here. } \item{type}{ a character vector that determines if lines, points, etc. are drawn on the panel. The default values for the methods are carefully chosen. See \code{\link[lattice:panel.xyplot]{panel.xyplot}} for possible values. } \item{thin}{ an optional thinning interval that is applied before the plot is drawn.} \item{start}{ an optional value for the starting point within the series. Values before the starting point are considered part of the "burn-in" of the series and dropped.} \item{plot.points}{ character argument giving the style in which points are added to the plot. See \code{\link[lattice:panel.densityplot]{panel.densityplot}} for details. } \item{layout}{a method-specific default for the \code{layout} argument to the lattice functions.} \item{xlab,ylab,main}{Used to provide default axis annotations and plot labels.} \item{cuts, at}{ defines number and location of values where colors change } \item{col.regions}{ color palette used } \item{lag.max}{ maximum lag for which autocorrelation is computed. By default, the value chosen by \code{\link{acf}} is used } \item{prepanel,panel}{ suitable prepanel and panel functions for \code{acfplot}. The prepanel function omits the lag-0 auto-correlation (which is always 1) from the range calculations. } \item{\dots}{other arguments, passed to the lattice function. Documentation of the corresponding generics in the \code{lattice} package should be consulted for possible arguments. } \item{subset}{indices of the subset of the series to plot. The default is constructed from the \code{start} and \code{thin} arguments.} } \value{ An object of class \code{"trellis"}. The relevant \code{\link[lattice:update.trellis]{update}} method can be used to update components of the object and the \code{\link[lattice:print.trellis]{print}} method (usually called by default) will plot it on an appropriate plotting device. } \seealso{ \code{\link[lattice:Lattice]{Lattice}} for a brief introduction to lattice displays and links to further documentation. } \author{ Deepayan Sarkar \email{Deepayan.Sarkar@R-project.org}} \examples{ data(line) \dontrun{ xyplot(line) xyplot(line[[1]], start = 10) densityplot(line, start = 10) qqmath(line, start = 10) levelplot(line[[2]]) acfplot(line, outer = TRUE) } } \keyword{hplot} coda/man/varnames.Rd0000644000176200001440000000144613343454654014056 0ustar liggesusers\name{varnames} \alias{varnames} \alias{varnames<-} \alias{chanames} \alias{chanames<-} \title{Named dimensions of MCMC objects} \usage{ varnames(x, allow.null=TRUE) chanames(x, allow.null=TRUE) varnames(x) <- value chanames(x) <- value } \arguments{ \item{x}{an \code{mcmc} or \code{mcmc.list} object} \item{allow.null}{Logical argument that determines whether the function may return NULL} \item{value}{A character vector, or NULL} } \value{ A character vector , or NULL. } \description{ \code{varnames()} returns the variable names and \code{chanames} returns the chain names, or NULL if these are not set. If \code{allow.null = FALSE} then \code{NULL} values will be replaced with canonical names. } \seealso{ \code{\link{mcmc}}, \code{\link{mcmc.list}}. } \keyword{manip} coda/man/gelman.plot.Rd0000644000176200001440000000462413343454654014463 0ustar liggesusers\name{gelman.plot} \alias{gelman.plot} %\alias{gelman.preplot} \title{Gelman-Rubin-Brooks plot} \usage{ gelman.plot(x, bin.width = 10, max.bins = 50, confidence = 0.95, transform = FALSE, autoburnin=TRUE, auto.layout = TRUE, ask, col, lty, xlab, ylab, type, \dots) } \arguments{ \item{x}{an mcmc object} \item{bin.width}{Number of observations per segment, excluding the first segment which always has at least 50 iterations.} \item{max.bins}{Maximum number of bins, excluding the last one.} \item{confidence}{Coverage probability of confidence interval.} \item{transform}{Automatic variable transformation (see \code{gelman.diag})} \item{autoburnin}{Remove first half of sequence (see \code{gelman.diag})} \item{auto.layout}{If \code{TRUE} then, set up own layout for plots, otherwise use existing one.} \item{ask}{Prompt user before displaying each page of plots. Default is \code{dev.interactive()} in R and \code{interactive()} in S-PLUS.} \item{col}{graphical parameter (see \code{par})} \item{lty}{graphical parameter (see \code{par})} \item{xlab}{graphical parameter (see \code{par})} \item{ylab}{graphical parameter (see \code{par})} \item{type}{graphical parameter (see \code{par})} \item{\dots}{further graphical parameters.} } \description{ This plot shows the evolution of Gelman and Rubin's shrink factor as the number of iterations increases. } \details{ The Markov chain is divided into bins according to the arguments \code{bin.width} and \code{max.bins}. Then the Gelman-Rubin shrink factor is repeatedly calculated. The first shrink factor is calculated with observations 1:50, the second with observations \eqn{1:(50+bin.width)}, the third contains samples \eqn{1:(50+2*bin.width)} and so on. If the chain has less than \eqn{50 + bin.width} iterations then \code{gelman.diag} will exit with an error. } \references{ Brooks, S P. and Gelman, A. (1998) General Methods for Monitoring Convergence of Iterative Simulations. \emph{Journal of Computational and Graphical Statistics}, \bold{7}, 434-455. } \section{Theory}{ A potential problem with \code{gelman.diag} is that it may mis-diagnose convergence if the shrink factor happens to be close to 1 by chance. By calculating the shrink factor at several points in time, \code{gelman.plot} shows if the shrink factor has really converged, or whether it is still fluctuating. } \seealso{ \code{\link{gelman.diag}}. } \keyword{hplot} coda/man/batchSE.Rd0000644000176200001440000000250213343454654013545 0ustar liggesusers\name{batchSE} \alias{batchSE} \title{Batch Standard Error} \description{ Effective standard deviation of population to produce the correct standard errors. } \usage{ batchSE(x, batchSize=100) } \arguments{ \item{x}{An \code{mcmc} or \code{mcmc.list} object.} \item{batchSize}{Number of observations to include in each batch.} } \details{ Because of the autocorrelation, the usual method of taking \code{var(x)/n} overstates the precision of the estimate. This method works around the problem by looking at the means of batches of the parameter. If the batch size is large enough, the batch means should be approximately uncorrelated and the normal formula for computing the standard error should work. The batch standard error procedure is usually thought to be not as accurate as the time series methods used in \code{summary} and \code{effectiveSize}. It is included here for completeness. } \value{ A vector giving the standard error for each column of \code{x}. } \references{ Roberts, GO (1996) Markov chain concepts related to sampling algorithms, in Gilks, WR, Richardson, S and Spiegelhalter, DJ, \emph{Markov Chain Monte Carlo in Practice}, Chapman and Hall, 45-58. } \seealso{ \code{\link{spectrum0.ar}}, \code{\link{effectiveSize}}, \code{\link{summary.mcmc}} } \author{Russell Almond} \keyword{ts} coda/man/read.and.check.Rd0000644000176200001440000000301213343454654014761 0ustar liggesusers\name{read.and.check} \alias{read.and.check} \title{Read data interactively and check that it satisfies conditions} \usage{ read.and.check(message = "", what = numeric(), lower, upper, answer.in, default) } \arguments{ \item{message}{message displayed before prompting for user input.} \item{what}{the type of \code{what} gives the type of data to be read.} \item{lower}{lower limit of input, for numeric input only.} \item{upper}{upper limit of input, for numeric input only.} \item{answer.in}{the input must correspond to one of the elements of the vector \code{answer.in}, if supplied.} \item{default}{value assumed if user enters a blank line.} } \description{ Input is read interactively and checked against conditions specified by the arguments \code{what}, \code{lower}, \code{upper} and \code{answer.in}. If the input does not satisfy all the conditions, an appropriate error message is produced and the user is prompted to provide input. This process is repeated until a valid input value is entered. } \value{ The value of the valid input. When the \code{default} argument is specified, a blank line is accepted as valid input and in this case \code{read.and.check} returns the value of \code{default}. } \note{ Since the function does not return a value until it receives valid input, it extensively checks the conditions for consistency before prompting the user for input. Inconsistent conditions will cause an error. } \author{Martyn Plummer} \keyword{utilities} coda/man/as.ts.mcmc.Rd0000644000176200001440000000066313343454654014210 0ustar liggesusers\name{as.ts.mcmc} \alias{as.ts.mcmc} \title{Coerce mcmc object to time series} \usage{\method{as.ts}{mcmc}(x,\dots)} \arguments{ \item{x}{an mcmc object} \item{\dots}{unused arguments for compatibility with generic \code{as.ts}} } \description{ the \code{as.ts} method for \code{mcmc} objects coerces an mcmc object to a time series.} \author{Martyn Plummer} \seealso{ \code{\link{as.ts}} } \keyword{ts} \keyword{utilities} coda/man/raftery.diag.Rd0000644000176200001440000000757313343454654014630 0ustar liggesusers\name{raftery.diag} \alias{raftery.diag} %\alias{print.raftery.diag} \title{Raftery and Lewis's diagnostic} \usage{ raftery.diag(data, q=0.025, r=0.005, s=0.95, converge.eps=0.001) } \arguments{ \item{data}{an \code{mcmc} object} \item{q}{the quantile to be estimated.} \item{r}{the desired margin of error of the estimate.} \item{s}{the probability of obtaining an estimate in the interval (q-r,q+r).} \item{converge.eps}{Precision required for estimate of time to convergence.} } \description{ \code{raftery.diag} is a run length control diagnostic based on a criterion of accuracy of estimation of the quantile \code{q}. It is intended for use on a short pilot run of a Markov chain. The number of iterations required to estimate the quantile \eqn{q} to within an accuracy of +/- \eqn{r} with probability \eqn{p} is calculated. Separate calculations are performed for each variable within each chain. If the number of iterations in \code{data} is too small, an error message is printed indicating the minimum length of pilot run. The minimum length is the required sample size for a chain with no correlation between consecutive samples. Positive autocorrelation will increase the required sample size above this minimum value. An estimate \code{I} (the `dependence factor') of the extent to which autocorrelation inflates the required sample size is also provided. Values of \code{I} larger than 5 indicate strong autocorrelation which may be due to a poor choice of starting value, high posterior correlations or `stickiness' of the MCMC algorithm. The number of `burn in' iterations to be discarded at the beginning of the chain is also calculated. } \value{ A list with class \code{raftery.diag}. A print method is available for objects of this class. the contents of the list are \item{tspar}{The time series parameters of \code{data}} \item{params}{A vector containing the parameters \code{r}, \code{s} and \code{q}} \item{Niters}{The number of iterations in \code{data}} \item{resmatrix}{A 3-d array containing the results: \eqn{M} the length of "burn in", \eqn{N} the required sample size, \eqn{Nmin} the minimum sample size based on zero autocorrelation and \eqn{I = (M+N)/Nmin} the "dependence factor"} } \section{Theory}{ The estimated sample size for variable U is based on the process \eqn{Z_t = d(U_t <= u)} where \eqn{d} is the indicator function and u is the qth quantile of U. The process \eqn{Z_t} is derived from the Markov chain \code{data} by marginalization and truncation, but is not itself a Markov chain. However, \eqn{Z_t} may behave as a Markov chain if it is sufficiently thinned out. \code{raftery.diag} calculates the smallest value of thinning interval \eqn{k} which makes the thinned chain \eqn{Z^k_t} behave as a Markov chain. The required sample size is calculated from this thinned sequence. Since some data is `thrown away' the sample size estimates are conservative. The criterion for the number of `burn in' iterations \eqn{m} to be discarded, is that the conditional distribution of \eqn{Z^k_m} given \eqn{Z_0} should be within \code{converge.eps} of the equilibrium distribution of the chain \eqn{Z^k_t}. } \note{ \code{raftery.diag} is based on the FORTRAN program `gibbsit' written by Steven Lewis, and available from the Statlib archive. } \references{ Raftery, A.E. and Lewis, S.M. (1992). One long run with diagnostics: Implementation strategies for Markov chain Monte Carlo. \emph{Statistical Science}, \bold{7}, 493-497. Raftery, A.E. and Lewis, S.M. (1995). The number of iterations, convergence diagnostics and generic Metropolis algorithms. \emph{In} Practical Markov Chain Monte Carlo (W.R. Gilks, D.J. Spiegelhalter and S. Richardson, eds.). London, U.K.: Chapman and Hall. } \keyword{htest} coda/man/mcmc.list.Rd0000644000176200001440000000306513343454654014132 0ustar liggesusers\name{mcmc.list} \alias{mcmc.list} \alias{as.mcmc.list} \alias{as.mcmc.list.default} \alias{is.mcmc.list} \alias{plot.mcmc.list} \title{Replicated Markov Chain Monte Carlo Objects} \usage{ mcmc.list(\dots) as.mcmc.list(x, \dots) is.mcmc.list(x) } \arguments{ \item{\dots}{a list of mcmc objects} \item{x}{an object that may be coerced to mcmc.list} } \description{ The function `mcmc.list' is used to represent parallel runs of the same chain, with different starting values and random seeds. The list must be balanced: each chain in the list must have the same iterations and the same variables. Diagnostic functions which act on \code{mcmc} objects may also be applied to \code{mcmc.list} objects. In general, the chains will be combined, if this makes sense, otherwise the diagnostic function will be applied separately to each chain in the list. Since all the chains in the list have the same iterations, a single time dimension can be ascribed to the list. Hence there are time series methods \code{time}, \code{window}, \code{start}, \code{end}, \code{frequency} and \code{thin} for \code{mcmc.list} objects. An \code{mcmc.list} can be indexed as if it were a single mcmc object using the \code{[} operator (see examples below). The \code{[[} operator selects a single \code{mcmc} object from the list. } \author{Martyn Plummer} \seealso{ \code{\link{mcmc}}. } \examples{ data(line) x1 <- line[[1]] #Select first chain x2 <- line[,1, drop=FALSE] #Select first var from all chains varnames(x2) == varnames(line)[1] #TRUE } \keyword{ts} coda/man/spectrum0.Rd0000644000176200001440000000461313343454654014163 0ustar liggesusers\name{spectrum0} \alias{spectrum0} \title{Estimate spectral density at zero} \description{ The spectral density at frequency zero is estimated by fitting a glm to the low-frequency end of the periodogram. \code{spectrum0(x)/length(x)} estimates the variance of \code{mean(x)}. } \usage{ spectrum0(x, max.freq = 0.5, order = 1, max.length = 200) } \arguments{ \item{x}{A time series.} \item{max.freq}{The glm is fitted on the frequency range (0, max.freq]} \item{order}{Order of the polynomial to fit to the periodogram.} \item{max.length}{The data \code{x} is aggregated if necessary by taking batch means so that the length of the series is less than \code{max.length}. If this is set to \code{NULL} no aggregation occurs.} } \details{ The raw periodogram is calculated for the series \code{x} and a generalized linear model with family \code{Gamma} and log link is fitted to the periodogram. The linear predictor is a polynomial in terms of the frequency. The degree of the polynomial is determined by the parameter \code{order}. } \value{ A list with the following values \item{spec}{The predicted value of the spectral density at frequency zero.} } \references{ Heidelberger, P and Welch, P.D. A spectral method for confidence interval generation and run length control in simulations. Communications of the ACM, Vol 24, pp233-245, 1981. } \section{Theory}{ Heidelberger and Welch (1991) observed that the usual non-parametric estimator of the spectral density, obtained by smoothing the periodogram, is not appropriate for frequency zero. They proposed an alternative parametric method which consisted of fitting a linear model to the log periodogram of the batched time series. Some technical problems with model fitting in their original proposal can be overcome by using a generalized linear model. Batching of the data, originally proposed in order to save space, has the side effect of flattening the spectral density and making a polynomial fit more reasonable. Fitting a polynomial of degree zero is equivalent to using the `batched means' method. } \note{ The definition of the spectral density used here differs from that used by \code{spec.pgram}. We consider the frequency range to be between 0 and 0.5, not between 0 and \code{frequency(x)/2}. The model fitting may fail on chains with very high autocorrelation. } \seealso{ \code{\link{spectrum}}, \code{\link{spectrum0.ar}}, \code{\link{glm}}. } \keyword{ts} coda/man/plot.mcmc.Rd0000644000176200001440000000163013343454654014131 0ustar liggesusers\name{plot.mcmc} \alias{plot.mcmc} \title{Summary plots of mcmc objects} \usage{ \method{plot}{mcmc}(x, trace = TRUE, density = TRUE, smooth = FALSE, bwf, auto.layout = TRUE, ask = dev.interactive(), \dots) } \arguments{ \item{x}{an object of class \code{mcmc} or \code{mcmc.list}} \item{trace}{Plot trace of each variable} \item{density}{Plot density estimate of each variable} \item{smooth}{Draw a smooth line through trace plots} \item{bwf}{Bandwidth function for density plots} \item{auto.layout}{Automatically generate output format} \item{ask}{Prompt user before each page of plots} \item{\dots}{Further arguments} } \description{ \code{plot.mcmc} summarizes an mcmc or mcmc.list object with a trace of the sampled output and a density estimate for each variable in the chain. } \author{Martyn Plummer} \seealso{ \code{\link{densplot}}, \code{\link{traceplot}}. } \keyword{hplot} coda/man/rejectionRate.Rd0000644000176200001440000000171413343454654015036 0ustar liggesusers\name{rejectionRate} \alias{rejectionRate} \alias{rejectionRate.mcmc} \alias{rejectionRate.mcmc.list} \title{Rejection Rate for Metropolis--Hastings chains} \usage{rejectionRate(x) } \arguments{ \item{x}{An \code{mcmc} or \code{mcmc.list} object.} } \description{ \code{rejectionRate} calculates the fraction of time that a Metropolis--Hastings type chain rejected a proposed move. The rejection rate is calculates separately for each variable in the \code{mcmc.obj} argument, irregardless of whether the variables were drawn separately or in a block. In the latter case, the values returned should be the same. } \details{ For the purposes of this function, a "rejection" has occurred if the value of the time series is the same at two successive time points. This test is done naively using \code{==} and may produce problems due to rounding error. } \value{ A vector containing the rejection rates, one for each variable. } \author{Russell Almond} \keyword{ts} coda/man/thin.Rd0000644000176200001440000000074713343454654013207 0ustar liggesusers\name{thin} \alias{thin} \title{Thinning interval} \usage{ thin(x, \dots) } \arguments{ \item{x}{a regular time series} \item{\dots}{a list of arguments} } \description{ \code{thin} returns the interval between successive values of a time series. \code{thin(x)} is equivalent to \code{1/frequency(x)}. This is a generic function. Methods have been implemented for \code{mcmc} objects. } \author{Martyn Plummer} \seealso{ \code{\link{time}}. } \keyword{ts} coda/man/mcmc.subset.Rd0000644000176200001440000000167213343454654014466 0ustar liggesusers\name{mcmc.subset} \alias{[.mcmc} \alias{[.mcmc.list} \title{Extract or replace parts of MCMC objects} \usage{ \method{[}{mcmc}(x,i,j, drop=missing(i)) \method{[}{mcmc.list}(x,i,j, drop=TRUE) } \arguments{ \item{x}{An \code{mcmc} object} \item{i}{Row to extract} \item{j}{Column to extract} \item{drop}{if \code{TRUE}, the redundant dimensions are dropped} } \description{ These are methods for subsetting \code{mcmc} objects. You can select iterations using the first dimension and variables using the second dimension. Selecting iterations will return a vector or matrix, not an \code{mcmc} object. If you want to do row-subsetting of an \code{mcmc} object and preserve its dimensions, use the \code{window} function. Subsetting applied to an \code{mcmc.list} object will simultaneously affect all the parallel chains in the object. } \seealso{ \code{\link{[}}, \code{\link{window.mcmc}} } \keyword{ts} coda/man/codamenu.Rd0000644000176200001440000000055013343454654014030 0ustar liggesusers\name{codamenu} \alias{codamenu} \title{Main menu driver for the coda package} \usage{ codamenu() } \description{ \code{codamenu} presents a simple menu-based interface to the functions in the coda package. It is designed for users who know nothing about the R/S language.} \author{Kate Cowles, Nicky Best, Karen Vines, Martyn Plummer} \keyword{utilities} coda/man/multi.menu.Rd0000644000176200001440000000170613343454654014336 0ustar liggesusers\name{multi.menu} \alias{multi.menu} \title{Choose multiple options from a menu} \usage{ multi.menu(choices, title, header, allow.zero = TRUE) } \arguments{ \item{choices}{Character vector of labels for choices} \item{title}{Title printed before menu} \item{header}{Character vector of length 2 giving column titles} \item{allow.zero}{Permit 0 as an acceptable response} } \description{ \code{multi.menu} presents the user with a menu of choices labelled from 1 to the number of choices. The user may choose one or more options by entering a comma separated list. A range of values may also be specified using the ":" operator. Mixed expressions such as "1,3:5, 6" are permitted. If \code{allow.zero} is set to TRUE, one can select `0' to exit without choosing an item. } \value{ Numeric vector giving the numbers of the options selected, or 0 if no selection is made. } \author{Martyn Plummer} \seealso{ \code{\link{menu}}. } \keyword{utilities} coda/man/nchain.Rd0000644000176200001440000000110113343454654013466 0ustar liggesusers\name{nchain} \alias{niter} \alias{nvar} \alias{nchain} \title{Dimensions of MCMC objects} \usage{ niter(x) nvar(x) nchain(x) } \arguments{ \item{x}{An \code{mcmc} or \code{mcmc.list} object} } \value{ A numeric vector of length 1: } \description{ These functions give the dimensions of an MCMC object \describe{ \item{niter(x)}{returns the number of iterations.} \item{nvar(x)}{returns the number of variables.} \item{nchain(x)}{returns the number of parallel chains.} } } \seealso{ \code{\link{mcmc}}, \code{\link{mcmc.list}}, } \keyword{ts} coda/man/linepost.Rd0000644000176200001440000000066113343454654014075 0ustar liggesusers\name{line} \docType{data} \alias{line} \title{Simple linear regression example} \description{ Sample MCMC output from a simple linear regression model given in the BUGS manual. } \usage{data(line)} \format{An \code{mcmc} object} \source{ Spiegelhalter, D.J., Thomas, A., Best, N.G. and Gilks, W.R. (1995) BUGS: Bayesian inference using Gibbs Sampling, Version 0.5, MRC Biostatistics Unit, Cambridge. } \keyword{datasets} coda/man/time.mcmc.Rd0000644000176200001440000000131513343454654014111 0ustar liggesusers\name{time.mcmc} \alias{time.mcmc} \alias{start.mcmc} \alias{end.mcmc} \alias{frequency.mcmc} \alias{thin.mcmc} \alias{time.mcmc.list} \alias{start.mcmc.list} \alias{end.mcmc.list} \alias{thin.mcmc.list} \title{Time attributes for mcmc objects} \usage{ \method{time}{mcmc}(x, \dots) \method{start}{mcmc}(x, \dots) \method{end}{mcmc}(x, \dots) \method{thin}{mcmc}(x, \dots) } \arguments{ \item{x}{an \code{mcmc} or \code{mcmc.list} object} \item{\dots}{extra arguments for future methods} } \description{ These are methods for mcmc objects for the generic time series functions. } \seealso{ \code{\link{time}}, \code{\link{start}}, \code{\link{frequency}}, \code{\link{thin}}. } \keyword{ts} coda/man/autocorr.diag.Rd0000644000176200001440000000233213343454654014776 0ustar liggesusers\name{autocorr.diag} \alias{autocorr.diag} \alias{autocorr.diag.mcmc} \alias{autocorr.diag.mcmc.list} \title{Autocorrelation function for Markov chains} \usage{autocorr.diag(mcmc.obj, \dots)} \arguments{ \item{mcmc.obj}{an object of class \code{mcmc} or \code{mcmc.list}} \item{\dots}{optional arguments to be passed to \code{autocorr}} } \description{ \code{autocorr.diag} calculates the autocorrelation function for the Markov chain \code{mcmc.obj} at the lags given by \code{lags}. The lag values are taken to be relative to the thinning interval if \code{relative=TRUE}. Unlike \code{autocorr}, if \code{mcmc.obj} has many parmeters it only computes the autocorrelations with itself and not the cross correlations. In cases where \code{autocorr} would return a matrix, this function returns the diagonal of the matrix. Hence it is more useful for chains with many parameters, but may not be as helpful at spotting parameters. If \code{mcmc.obj} is of class \code{mcmc.list} then the returned vector is the average autocorrelation across all chains. } \value{ A vector containing the autocorrelations. } \author{Russell Almond} \seealso{ \code{\link{autocorr}}, \code{\link{acf}}, \code{\link{autocorr.plot}}. } \keyword{ts} coda/man/Cramer.Rd0000644000176200001440000000125313343454654013447 0ustar liggesusers\name{Cramer} \alias{pcramer} \title{The Cramer-von Mises Distribution} \description{ Distribution function of the Cramer-von Mises distribution. } \usage{ pcramer(q, eps) } \arguments{ \item{q}{vector of quantiles.} \item{eps}{accuracy required} } \value{ \code{pcramer} gives the distribution function, } \references{ Anderson TW. and Darling DA. Asymptotic theory of certain `goodness of fit' criteria based on stochastic processes. \emph{Ann. Math. Statist.}, \bold{23}, 192-212 (1952). Csorgo S. and Faraway, JJ. The exact and asymptotic distributions of the Cramer-von Mises statistic. J. Roy. Stat. Soc. (B), \bold{58}, 221-234 (1996). } \keyword{distribution} coda/man/mcmc.Rd0000644000176200001440000000402713343454654013157 0ustar liggesusers\name{mcmc} \alias{mcmc} \alias{as.mcmc} \alias{as.mcmc.default} \alias{is.mcmc} \alias{print.mcmc} \title{Markov Chain Monte Carlo Objects} \usage{ mcmc(data= NA, start = 1, end = numeric(0), thin = 1) as.mcmc(x, \dots) is.mcmc(x) } \arguments{ \item{data}{a vector or matrix of MCMC output} \item{start}{the iteration number of the first observation} \item{end}{the iteration number of the last observation} \item{thin}{the thinning interval between consecutive observations} \item{x}{An object that may be coerced to an mcmc object} \item{\dots}{Further arguments to be passed to specific methods} } \description{ The function \code{mcmc} is used to create a Markov Chain Monte Carlo object. The input data are taken to be a vector, or a matrix with one column per variable. If the optional arguments \code{start}, \code{end}, and \code{thin} are omitted then the chain is assumed to start with iteration 1 and have thinning interval 1. If \code{data} represents a chain that starts at a later iteration, the first iteration in the chain should be given as the \code{start} argument. Likewise, if \code{data} represents a chain that has already been thinned, the thinning interval should be given as the \code{thin} argument. An mcmc object may be summarized by the \code{summary} function and visualized with the \code{plot} function. MCMC objects resemble time series (\code{ts}) objects and have methods for the generic functions \code{time}, \code{start}, \code{end}, \code{frequency} and \code{window}. } \author{Martyn Plummer} \note{ The format of the mcmc class has changed between coda version 0.3 and 0.4. Older mcmc objects will now cause \code{is.mcmc} to fail with an appropriate warning message. Obsolete mcmc objects can be upgraded with the \code{mcmcUpgrade} function. } \seealso{ \code{\link{mcmc.list}}, \code{\link{mcmcUpgrade}}, \code{\link{thin}}, \code{\link{window.mcmc}}, \code{\link{summary.mcmc}}, \code{\link{plot.mcmc}}. } \keyword{ts}