posterior/0000755000175000017500000000000014165346072012442 5ustar nileshnileshposterior/MD50000644000175000017500000002111614165346072012753 0ustar nileshnilesh474b2c43cb0b31d843a10e20588b05c7 *DESCRIPTION d78f73f281b653a273038ca5aafca6b1 *LICENSE 311068f9757930877008aae29d7a47e0 *NAMESPACE 335b8bb378bb64f9063fc9d8e0a7917b *NEWS.md e5df055aba3fa4aa1a37c7b1fbc55810 *R/as_draws.R 27a2d8f1bef99fb8ef2da07d05df7d74 *R/as_draws_array.R 6b01d5369d6b76872e24bd5a855859cd *R/as_draws_df.R 7c0a087ab13aa19fe4dcfc2695548401 *R/as_draws_list.R 1daff272c446b81c63c79e12182fe9c5 *R/as_draws_matrix.R edca10f5c118cd0014030c21a8940266 *R/as_draws_rvars.R e1fa7d04b0bb1bb604c29edab49eeaa8 *R/bind_draws.R 49e0db4dc2cc50625e906c0d643e73dd *R/convergence.R ed864e8faf473a5d627a321246dd4a62 *R/draws-index.R 0bd2a09fa42d0255fa0ac00a903ea1bc *R/example_draws.R 480e7d7ce751027bf4bf607de8ef2260 *R/extract_variable.R a694a92c4b6bd26c6ac2ab85edf1c4df *R/extract_variable_matrix.R 18950feb9f591cf8cad251a2d6af5259 *R/merge_chains.R 19cca5b47767fce243adc092677ef8b4 *R/misc.R f5eba96acff98d4169570d61202a4b24 *R/mutate_variables.R 267218b53d31819b1b571984f7b583f8 *R/order_draws.R e2fac8784a6456f64aab1f81dd22476b *R/posterior-package.R 92773b810780793a08a6591fd365e699 *R/print.R 54dad79021aeeeb63bcafe0b058e6a90 *R/remove_variables.R 493b331367760bfd79bfea63c8e8e75b *R/rename_variables.R b2eedd92e8592e6b09e5d05f37313eef *R/repair_draws.R 82456a9056831fbf86f9f9707162550a *R/resample_draws.R 059f09b8582a7f2053690ca2e0121f7d *R/reserved_variables.R 4e4db356a72c51b14039f02843a02c3b *R/rstar.R dcb59ac49cd58154fb00249ec9c314b5 *R/rvar-.R 78dfd173581e9fe7e2a8041cd1355ee8 *R/rvar-apply.R 279460670d341c899de972b2cf59c299 *R/rvar-bind.R 08770669f963ccec77c7a175b8701e5c *R/rvar-cast.R 062ef7c81ce3c4194fc67d25d285a4aa *R/rvar-dim.R 5bd5c9df400a456a84452be2d8c027ad *R/rvar-dist.R 0f60c3c30988cd3a486606fc4b3da62d *R/rvar-math.R 7cbd248f447c7a6b2f79ec54ff5280f2 *R/rvar-print.R 1c22a4beab86cffae224ac413666a3a7 *R/rvar-rfun.R 2ca78cd528414fbc33cacb266ea377dc *R/rvar-slice.R 6f959689f636d4d0baf10f5cdc6fb312 *R/rvar-summaries-over-draws.R dd4f90e3dd71eb569175725d14721ad0 *R/rvar-summaries-within-draws.R 84e04a8b127afd8bb5b9350c234c32c0 *R/split_chains.R 8cfd1fae8ec0f882aad119d2256ef51b *R/subset_draws.R fa4ee9505b8cab52734b165c4598f1ef *R/summarise_draws.R 0db59654b1d67cb05db34baf849503e9 *R/sysdata.rda b666a398a9ac9cbbbc1085780af42215 *R/thin_draws.R 90b84a945d9d27d8b994261e39178507 *R/weight_draws.R 1d843d0f2f8e6d091fdb3eb7ee341325 *R/zzz.R 4d5cd87cfee4b73efc8a808f51d4a437 *README.md 4f08c6d213498d0f938e362e10725ad5 *build/vignette.rds 75c8005bd2bce25aac58354cc9c39d00 *inst/CITATION a0780c250b14b759e75d0524762107f4 *inst/doc/posterior.R 62e644d3158a905ca00c7572bd3eb13a *inst/doc/posterior.Rmd 820142f5b8487e08a5ecb55df1f247e7 *inst/doc/posterior.html ad31bd2ab6433af45773e40669eede74 *inst/doc/rvar.R 65952cdf74087fde7b9ac960ff1c0205 *inst/doc/rvar.Rmd bece22c44460a4f1c629c8797d3c8234 *inst/doc/rvar.html 9c0cc74f165470774bba7e50be53adfd *man/as_rvar.Rd f199d927131cba5a33a9e2cb5678918a *man/autocorrelation.Rd e70e7fcf81a3379ecfd94fdc1136743c *man/autocovariance.Rd 6b0bc7b1ce015f14349ad6507ffb2f74 *man/bind_draws.Rd 06cf5d69459e67141737fb655bd7e4ad *man/chol.rvar.Rd 7c897251b560f79f069f46d4c8e0304f *man/diagnostics.Rd 22b3add03ddeff46e12acc679e11ea2f *man/draws-index.Rd 098f059f00ec23c45091c66deb635b5f *man/draws.Rd 39ed1a19a96ae0f7ef5335757168187b *man/draws_array.Rd 14762a780e37f3b7da9e86fba14bcd9b *man/draws_df.Rd 81facccdfbd71a6d6091bc8473ed1462 *man/draws_list.Rd be9de7fa928fc10411677eecc152ede6 *man/draws_matrix.Rd ed3c6560663b940d4d1aeaab4baa3aee *man/draws_of.Rd b623b04a58c2094ecaa062d055a25583 *man/draws_rvars.Rd 0463c283fb8c7788435d53108c5f9efa *man/draws_summary.Rd 312c6c0290104e56ed91c4a1b709949e *man/ess_basic.Rd a78a5d9225f71bc4c1d403001184bc79 *man/ess_bulk.Rd 5fff0045cce9169942dcc9789b3bedac *man/ess_mean.Rd 3447a7def62838d91b8f36ba0dc878a1 *man/ess_quantile.Rd 8e0fd8ba85216271df37139661f064d3 *man/ess_sd.Rd 85bea18eaa2521aee853096f5196b86b *man/ess_tail.Rd 5f8c867686d494af51ef5dbb3927f174 *man/example_draws.Rd 3bfd0c884b07574500184a39bc5650db *man/extract_variable.Rd cc458a688b314d95962a716cc8d4d929 *man/extract_variable_matrix.Rd 5fad10a5cc62c59ea429a5ce90191e2e *man/figures/stanlogo.png 37a967a63a6808a29be82288e17a2d75 *man/is_rvar.Rd d16eea3dfda7202ca4229cc9ac1c27bf *man/mcse_mean.Rd 765834ac9b27d6391c313dafc4ebf75f *man/mcse_quantile.Rd 299dccdf594cf3974854d76ae47388e9 *man/mcse_sd.Rd 633b0da5936ab90cff1858f87b971ea0 *man/merge_chains.Rd a9b03da9d726679b187fe169fe21ce14 *man/mutate_variables.Rd b8b41902400eb943440407ddd3e4d37e *man/order_draws.Rd c5e2b2dce8e4076a8f3ca1ec8b1e7fab *man/posterior-package.Rd 086ab022814c14e393cb859859d30924 *man/print.draws_array.Rd 151fb9b9b455269389e1d0315178358a *man/print.draws_df.Rd c6e07137988537d04d3abd0261b26ca2 *man/print.draws_list.Rd 5be311f1cfb138b04e9773e5ec0ae065 *man/print.draws_matrix.Rd cbc0ee456751a36c94c0374bc14bb692 *man/print.draws_rvars.Rd e649c009ef9cc2b3db129f1a1451922c *man/print.rvar.Rd 8b746ae7610a4676c78021cf857f8208 *man/quantile2.Rd d94b8e5cc67c4695666c9eb5689f7551 *man/r_scale.Rd 304bca1eca0c4857d2f05495607109f5 *man/rdo.Rd 937b270cbfb60def0540a3ef0fae0b92 *man/reexports.Rd 770b1d82a68b1a0722408a0f73cd7ead *man/rename_variables.Rd 40796610ad6eb9632ff413ae538fe657 *man/repair_draws.Rd 3cd886a6b831962f1b4a17fb24500af1 *man/resample_draws.Rd 9d561881764dd80bb1c7a7b4ce82f4f3 *man/reserved_variables.Rd 6a624c127bb2f2f1c3276c2bd5486d4d *man/rfun.Rd 121015eb315e4b3feb1c2416261c99f8 *man/rhat.Rd 7a851807608ff96b15ee20a36f44f165 *man/rhat_basic.Rd eb5bccbb572f7f3c951772e59828c705 *man/rstar.Rd e812b748248258cfbdb20ec96fe368fd *man/rvar-dist.Rd ec569856eca215ae94689e402f2ecac9 *man/rvar-matmult.Rd f620c88d4de16396b30fb93acda6e0f3 *man/rvar-summaries-over-draws.Rd b0cf2f0880a2bd337850c936f5cc2127 *man/rvar-summaries-within-draws.Rd 741973d9cad6b22335f9349c3befc529 *man/rvar.Rd cc9d7ab8f89f74f19aa681dcf082b011 *man/rvar_apply.Rd 0657023698d99f506462516cc5eb580a *man/rvar_is_finite.Rd c5648c50108b0a76246b873b3318e86d *man/rvar_rng.Rd 92792ce5677848ba24b7a44d4fd8f9fd *man/split_chains.Rd 5914cd6761469d1f9b3cd14a58ab4f19 *man/sub-.draws_array.Rd 1a4585e2727bd7fd1ae2c045d9813ad8 *man/sub-.draws_matrix.Rd 25664761f4bf17051354bb63ef6fd338 *man/subset_draws.Rd 1dae2e4af92f4e178d6c7f84abe6b159 *man/thin_draws.Rd b1be8306780c6d8393fee10b19df73d0 *man/u_scale.Rd dbb9637047e6ae677fd316b80f9f47d3 *man/weight_draws.Rd d77419cc6febf7c0b6c541ffd5b79461 *man/weights.draws.Rd b3766e231b1c81bc2bb20d88060b4e24 *man/z_scale.Rd 27a8eb39e3127a1842637948ff7da564 *tests/testthat.R 180b5f4f838e632fc19c1732cfced008 *tests/testthat/test-as_draws.R 6195f4ef752a5e844482f1813b025b0a *tests/testthat/test-bind_draws.R ee3fd492240f6ef75ea2f3fb97b2fbf1 *tests/testthat/test-convergence.R ca03a0526e598dde8ea370a50751e8a6 *tests/testthat/test-draws-index.R 71a687406f65579eb928325120c50e7a *tests/testthat/test-extract_variable.R 6ed1ab843e85c2f389d347dd1f2d11ce *tests/testthat/test-extract_variable_matrix.R 60fddca8118a5946cd812bbf1f131aaf *tests/testthat/test-merge_chains.R 4148c1f483fa4a99af0a2f41ec4ad1d0 *tests/testthat/test-mutate_variables.R 67e60ca36c04d8644d435dca721c6c66 *tests/testthat/test-print.R b6e584381d3f3eb5a339f0486b4d09fe *tests/testthat/test-remove_variables.R c53b79a7cf2c04c9a896169a6c3276ae *tests/testthat/test-rename_variables.R 71070a923f803994e3d2a830ee7f09a2 *tests/testthat/test-repair_draws.R 93c2902ed48e8b113ab0889977865a72 *tests/testthat/test-resample_draws.R 5f27cb5fc5a7342ae79c1ddb306d4602 *tests/testthat/test-rstar.R 15c36559470fc6c211e92f7f3c84e1b5 *tests/testthat/test-rvar-.R 751f95fd0d65772270f314ee2fb82751 *tests/testthat/test-rvar-apply.R dd2228352113058b593b232d36faebfd *tests/testthat/test-rvar-bind.R 039bcf5295597c5826a4ac725f70be0e *tests/testthat/test-rvar-cast.R 989d65997b354e5e98f7b35dc58f7ac0 *tests/testthat/test-rvar-dim.R d6b83a693f8240daba4f613b8f60af9b *tests/testthat/test-rvar-dist.R b0f3f83d3bc538512017af10b01b2077 *tests/testthat/test-rvar-math.R d3671c690315a5cc02e04f1ef76aefdc *tests/testthat/test-rvar-print.R 120e575ceb1598caad4e8d48e8630b42 *tests/testthat/test-rvar-rfun.R 37cceb0e958324ead47c763c6b284768 *tests/testthat/test-rvar-slice.R fdb07440421c3487c7a9d6ef2bd50f5f *tests/testthat/test-rvar-summaries-over-draws.R af586671a999b615a57970a133f81126 *tests/testthat/test-rvar-summaries-within-draws.R 0075863f5ba41c607701f0a296988e53 *tests/testthat/test-subset_draws.R cdd0ae19783f10b7edd7d7ead660fd61 *tests/testthat/test-summarise_draws.R 7ad787042c6563fd03eb5dffe55a4036 *tests/testthat/test-thin_draws.R a760764596d03cfd36f52f75d1e63422 *tests/testthat/test-variables.R bc3802a105b44895af2549c6119cf4ac *tests/testthat/test-weight_draws.R 62e644d3158a905ca00c7572bd3eb13a *vignettes/posterior.Rmd 65952cdf74087fde7b9ac960ff1c0205 *vignettes/rvar.Rmd posterior/NEWS.md0000644000175000017500000000256514165316754013554 0ustar nileshnilesh# posterior 1.2.0 ### Enhancements * support casting to/from `rvar` and `distributional::dist_sample` (#109) ### Bug Fixes * fix hidden variables in `bind_draws.draws_df` when binding more than two objects thanks to Jouni Helske (#204) * fix output of `pillar::glimpse()` when used on a data frame containing `rvar`s (#210) * drop `"draws"` and `"draws_df"` classes from `draws_df` objects if meta data columns are removed by a `dplyr` operation (#202) * fix output of `print.draws_df()` on objects with unrepaired draws (#217) * ensure `variance()` works properly with `summarise_draws()` (#219) # posterior 1.1.0 ### Enhancements * use `matrixStats` to speed up convergence functions (#190) and `rvar` summaries (#200) ### Bug Fixes * ensure that `as_draws_rvars()` works on lists of lists (#192) * fix some vector recycling issues with `rvar_rng` (#195) * ensure that `subset_draws()` respects input variable order, thanks to Karl Dunkle Werner and Alexey Stukalov (#188) ### Other Changes * No longer check for constant-per-chain input in effective sample size diagnostics as this is overly conservative especially for `ess_tail`. (#198) # posterior 1.0.1 * ensure that all unit tests pass on all CRAN environments * fix a problem that sometimes lead to `rvar`s being unnecessarily slow (#179) # posterior 1.0.0 * initial CRAN release # posterior 0.1.0 * beta release posterior/DESCRIPTION0000644000175000017500000000455214165346072014156 0ustar nileshnileshPackage: posterior Title: Tools for Working with Posterior Distributions Version: 1.2.0 Date: 2022-01-05 Authors@R: c(person("Paul-Christian", "Bürkner", email = "paul.buerkner@gmail.com", role = c("aut", "cre")), person("Jonah", "Gabry", email = "jsg2201@columbia.edu", role = c("aut")), person("Matthew", "Kay", email = "mjskay@northwestern.edu", role = c("aut")), person("Aki", "Vehtari", email = "Aki.Vehtari@aalto.fi", role = c("aut")), person("Måns", "Magnusson", role = c("ctb")), person("Rok", "Češnovar", role = c("ctb")), person("Ben", "Lambert", role = c("ctb")), person("Ozan", "Adıgüzel", role = c("ctb")), person("Jacob", "Socolar", role = c("ctb"))) Description: Provides useful tools for both users and developers of packages for fitting Bayesian models or working with output from Bayesian models. The primary goals of the package are to: (a) Efficiently convert between many different useful formats of draws (samples) from posterior or prior distributions. (b) Provide consistent methods for operations commonly performed on draws, for example, subsetting, binding, or mutating draws. (c) Provide various summaries of draws in convenient formats. (d) Provide lightweight implementations of state of the art posterior inference diagnostics. References: Vehtari et al. (2021) . Depends: R (>= 3.2.0) Imports: abind, checkmate, rlang (>= 0.4.7), stats, tibble (>= 3.0.0), vctrs, tensorA, pillar, distributional, parallel, matrixStats Suggests: testthat (>= 2.1.0), caret (>= 6.0.84), gbm (>= 2.1.8), randomForest (>= 4.6.14), e1071 (>= 1.7.3), dplyr, tidyr, knitr, rmarkdown License: BSD_3_clause + file LICENSE Encoding: UTF-8 URL: https://mc-stan.org/posterior/, https://discourse.mc-stan.org/ BugReports: https://github.com/stan-dev/posterior/issues RoxygenNote: 7.1.2 VignetteBuilder: knitr NeedsCompilation: no Packaged: 2022-01-05 15:59:41 UTC; paul.buerkner Author: Paul-Christian Bürkner [aut, cre], Jonah Gabry [aut], Matthew Kay [aut], Aki Vehtari [aut], Måns Magnusson [ctb], Rok Češnovar [ctb], Ben Lambert [ctb], Ozan Adıgüzel [ctb], Jacob Socolar [ctb] Maintainer: Paul-Christian Bürkner Repository: CRAN Date/Publication: 2022-01-05 16:50:02 UTC posterior/README.md0000644000175000017500000003506214165340003013713 0ustar nileshnilesh # posterior [![CRAN status](https://www.r-pkg.org/badges/version/posterior)](https://CRAN.R-project.org/package=posterior) [![R-CMD-check](https://github.com/stan-dev/posterior/workflows/R-CMD-check/badge.svg)](https://github.com/stan-dev/posterior/actions?workflow=R-CMD-check) [![Coverage Status](https://codecov.io/gh/stan-dev/posterior/branch/master/graph/badge.svg)](https://app.codecov.io/gh/stan-dev/posterior) The **posterior** R package is intended to provide useful tools for both users and developers of packages for fitting Bayesian models or working with output from Bayesian models. The primary goals of the package are to: - Efficiently convert between many different useful formats of draws (samples) from posterior or prior distributions. - Provide consistent methods for operations commonly performed on draws, for example, subsetting, binding, or mutating draws. - Provide various summaries of draws in convenient formats. - Provide lightweight implementations of state of the art posterior inference diagnostics. If you are new to **posterior** we recommend starting with these vignettes: - [*The posterior R package*](https://mc-stan.org/posterior/articles/posterior.html): an introduction to the package and its main functionality - [*rvar: The Random Variable Datatype*](https://mc-stan.org/posterior/articles/rvar.html): an overview of the new random variable datatype ### Installation You can install the latest official release version via ``` r install.packages("posterior") ``` or build the developmental version directly from GitHub via ``` r # install.packages("remotes") remotes::install_github("stan-dev/posterior") ``` ### Examples Here we offer a few examples of using the package. For a more detailed overview see the vignette [*The posterior R package*](https://mc-stan.org/posterior/articles/posterior.html). ``` r library("posterior") #> This is posterior version 1.2.0 #> #> Attaching package: 'posterior' #> The following objects are masked from 'package:stats': #> #> mad, sd, var ``` To demonstrate how to work with the **posterior** package, we will use example posterior draws obtained from the eight schools hierarchical meta-analysis model described in Gelman et al. (2013). Essentially, we have an estimate per school (`theta[1]` through `theta[8]`) as well as an overall mean (`mu`) and standard deviation across schools (`tau`). #### Draws formats ``` r eight_schools_array <- example_draws("eight_schools") print(eight_schools_array, max_variables = 3) #> # A draws_array: 100 iterations, 4 chains, and 10 variables #> , , variable = mu #> #> chain #> iteration 1 2 3 4 #> 1 2.0 3.0 1.79 6.5 #> 2 1.5 8.2 5.99 9.1 #> 3 5.8 -1.2 2.56 0.2 #> 4 6.8 10.9 2.79 3.7 #> 5 1.8 9.8 -0.03 5.5 #> #> , , variable = tau #> #> chain #> iteration 1 2 3 4 #> 1 2.8 2.80 8.7 3.8 #> 2 7.0 2.76 2.9 6.8 #> 3 9.7 0.57 8.4 5.3 #> 4 4.8 2.45 4.4 1.6 #> 5 2.8 2.80 11.0 3.0 #> #> , , variable = theta[1] #> #> chain #> iteration 1 2 3 4 #> 1 3.96 6.26 13.3 5.78 #> 2 0.12 9.32 6.3 2.09 #> 3 21.25 -0.97 10.6 15.72 #> 4 14.70 12.45 5.4 2.69 #> 5 5.96 9.75 8.2 -0.91 #> #> # ... with 95 more iterations, and 7 more variables ``` The draws for this example come as a `draws_array` object, that is, an array with dimensions iterations x chains x variables. We can easily transform it to another format, for instance, a data frame with additional meta information. ``` r eight_schools_df <- as_draws_df(eight_schools_array) print(eight_schools_df) #> # A draws_df: 100 iterations, 4 chains, and 10 variables #> mu tau theta[1] theta[2] theta[3] theta[4] theta[5] theta[6] #> 1 2.01 2.8 3.96 0.271 -0.74 2.1 0.923 1.7 #> 2 1.46 7.0 0.12 -0.069 0.95 7.3 -0.062 11.3 #> 3 5.81 9.7 21.25 14.931 1.83 1.4 0.531 7.2 #> 4 6.85 4.8 14.70 8.586 2.67 4.4 4.758 8.1 #> 5 1.81 2.8 5.96 1.156 3.11 2.0 0.769 4.7 #> 6 3.84 4.1 5.76 9.909 -1.00 5.3 5.889 -1.7 #> 7 5.47 4.0 4.03 4.151 10.15 6.6 3.741 -2.2 #> 8 1.20 1.5 -0.28 1.846 0.47 4.3 1.467 3.3 #> 9 0.15 3.9 1.81 0.661 0.86 4.5 -1.025 1.1 #> 10 7.17 1.8 6.08 8.102 7.68 5.6 7.106 8.5 #> # ... with 390 more draws, and 2 more variables #> # ... hidden reserved variables {'.chain', '.iteration', '.draw'} ``` Different formats are preferable in different situations and hence posterior supports multiple formats and easy conversion between them. For more details on the available formats see `help("draws")`. All of the formats are essentially base R object classes and can be used as such. For example, a `draws_matrix` object is just a `matrix` with a little more consistency and additional methods. #### Summarizing draws Computing summaries of posterior or prior draws and convergence diagnostics for posterior draws is one of the most common tasks when working with Bayesian models fit using Markov Chain Monte Carlo (MCMC) methods. The **posterior** package provides a flexible interface for this purpose via `summarise_draws()`: ``` r # summarise_draws or summarize_draws summarise_draws(eight_schools_df) #> # A tibble: 10 × 10 #> variable mean median sd mad q5 q95 rhat ess_bulk ess_tail #> #> 1 mu 4.18 4.16 3.40 3.57 -0.854 9.39 1.02 558. 322. #> 2 tau 4.16 3.07 3.58 2.89 0.309 11.0 1.01 246. 202. #> 3 theta[1] 6.75 5.97 6.30 4.87 -1.23 18.9 1.01 400. 254. #> 4 theta[2] 5.25 5.13 4.63 4.25 -1.97 12.5 1.02 564. 372. #> 5 theta[3] 3.04 3.99 6.80 4.94 -10.3 11.9 1.01 312. 205. #> 6 theta[4] 4.86 4.99 4.92 4.51 -3.57 12.2 1.02 695. 252. #> 7 theta[5] 3.22 3.72 5.08 4.38 -5.93 10.8 1.01 523. 306. #> 8 theta[6] 3.99 4.14 5.16 4.81 -4.32 11.5 1.02 548. 205. #> 9 theta[7] 6.50 5.90 5.26 4.54 -1.19 15.4 1.00 434. 308. #> 10 theta[8] 4.57 4.64 5.25 4.89 -3.79 12.2 1.02 355. 146. ``` Basically, we get a data frame with one row per variable and one column per summary statistic or convergence diagnostic. The summaries `rhat`, `ess_bulk`, and `ess_tail` are described in Vehtari et al. (2020). We can choose which summaries to compute by passing additional arguments, either functions or names of functions. For instance, if we only wanted the mean and its corresponding Monte Carlo Standard Error (MCSE) we would use: ``` r summarise_draws(eight_schools_df, "mean", "mcse_mean") #> # A tibble: 10 × 3 #> variable mean mcse_mean #> #> 1 mu 4.18 0.150 #> 2 tau 4.16 0.213 #> 3 theta[1] 6.75 0.319 #> 4 theta[2] 5.25 0.202 #> 5 theta[3] 3.04 0.447 #> 6 theta[4] 4.86 0.189 #> 7 theta[5] 3.22 0.232 #> 8 theta[6] 3.99 0.222 #> 9 theta[7] 6.50 0.250 #> 10 theta[8] 4.57 0.273 ``` For a function to work with `summarise_draws`, it needs to take a vector or matrix of numeric values and returns a single numeric value or a named vector of numeric values. #### Subsetting draws Another common task when working with posterior (or prior) draws, is subsetting according to various aspects of the draws (iterations, chains, or variables). **posterior** provides a convenient interface for this purpose via the `subset_draws()` method. For example, here is the code to extract the first five iterations of the first two chains of the variable `mu`: ``` r subset_draws(eight_schools_df, variable = "mu", chain = 1:2, iteration = 1:5) #> # A draws_df: 5 iterations, 2 chains, and 1 variables #> mu #> 1 2.0 #> 2 1.5 #> 3 5.8 #> 4 6.8 #> 5 1.8 #> 6 3.0 #> 7 8.2 #> 8 -1.2 #> 9 10.9 #> 10 9.8 #> # ... hidden reserved variables {'.chain', '.iteration', '.draw'} ``` The same call to `subset_draws()` can be used regardless of whether the object is a `draws_df`, `draws_array`, `draws_list`, etc. #### Mutating and renaming draws The magic of having obtained draws from the joint posterior (or prior) distribution of a set of variables is that these draws can also be used to obtain draws from any other variable that is a function of the original variables. That is, if are interested in the posterior distribution of, say, `phi = (mu + tau)^2` all we have to do is to perform the transformation for each of the individual draws to obtain draws from the posterior distribution of the transformed variable. This procedure is automated in the `mutate_variables` method: ``` r x <- mutate_variables(eight_schools_df, phi = (mu + tau)^2) x <- subset_draws(x, c("mu", "tau", "phi")) print(x) #> # A draws_df: 100 iterations, 4 chains, and 3 variables #> mu tau phi #> 1 2.01 2.8 22.8 #> 2 1.46 7.0 71.2 #> 3 5.81 9.7 240.0 #> 4 6.85 4.8 135.4 #> 5 1.81 2.8 21.7 #> 6 3.84 4.1 62.8 #> 7 5.47 4.0 88.8 #> 8 1.20 1.5 7.1 #> 9 0.15 3.9 16.6 #> 10 7.17 1.8 79.9 #> # ... with 390 more draws #> # ... hidden reserved variables {'.chain', '.iteration', '.draw'} ``` When we do the math ourselves, we see that indeed for each draw, `phi` is equal to `(mu + tau)^2` (up to rounding two 2 digits for the purpose of printing). We may also easily rename variables, or even entire vectors of variables via `rename_variables`, for example: ``` r x <- rename_variables(eight_schools_df, mean = mu, alpha = theta) variables(x) #> [1] "mean" "tau" "alpha[1]" "alpha[2]" "alpha[3]" "alpha[4]" "alpha[5]" #> [8] "alpha[6]" "alpha[7]" "alpha[8]" ``` As with all **posterior** methods, `mutate_variables` and `rename_variables` can be used with all draws formats. #### Binding draws together Suppose we have multiple draws objects that we want to bind together: ``` r x1 <- draws_matrix(alpha = rnorm(5), beta = 1) x2 <- draws_matrix(alpha = rnorm(5), beta = 2) x3 <- draws_matrix(theta = rexp(5)) ``` Then, we can use the `bind_draws` method to bind them along different dimensions. For example, we can bind `x1` and `x3` together along the `'variable'` dimension: ``` r x4 <- bind_draws(x1, x3, along = "variable") print(x4) #> # A draws_matrix: 5 iterations, 1 chains, and 3 variables #> variable #> draw alpha beta theta #> 1 0.39 1 2.27 #> 2 -0.80 1 0.86 #> 3 0.95 1 1.93 #> 4 0.38 1 0.67 #> 5 0.18 1 2.04 ``` Or, we can bind `x1` and `x2` together along the `'draw'` dimension: ``` r x5 <- bind_draws(x1, x2, along = "draw") print(x5) #> # A draws_matrix: 10 iterations, 1 chains, and 2 variables #> variable #> draw alpha beta #> 1 0.39 1 #> 2 -0.80 1 #> 3 0.95 1 #> 4 0.38 1 #> 5 0.18 1 #> 6 0.13 2 #> 7 0.10 2 #> 8 -0.61 2 #> 9 0.12 2 #> 10 1.48 2 ``` As with all **posterior** methods, `bind_draws` can be used with all draws formats. #### Converting from regular R objects to draws formats The `eight_schools` example already comes in a format natively supported by posterior but we could of course also import the draws from other sources, for example, from common base R objects: ``` r x <- matrix(rnorm(50), nrow = 10, ncol = 5) colnames(x) <- paste0("V", 1:5) x <- as_draws_matrix(x) print(x) #> # A draws_matrix: 10 iterations, 1 chains, and 5 variables #> variable #> draw V1 V2 V3 V4 V5 #> 1 -0.89 0.37 -0.25 -0.57 -2.85 #> 2 1.84 0.19 0.39 -0.52 1.26 #> 3 0.79 -0.74 -1.61 0.99 -0.11 #> 4 -2.25 0.28 -0.19 -0.33 0.92 #> 5 0.58 0.35 -0.92 0.56 0.82 #> 6 -1.38 -0.12 -0.40 -1.23 -0.60 #> 7 -0.18 1.18 -1.27 0.51 0.78 #> 8 0.17 1.50 -2.12 -0.45 -0.73 #> 9 -0.60 0.69 -0.43 -1.40 1.14 #> 10 0.18 0.96 -1.37 -0.58 -0.63 summarise_draws(x, "mean", "sd", "median", "mad") #> # A tibble: 5 × 5 #> variable mean sd median mad #> #> 1 V1 -0.174 1.16 -0.00490 1.03 #> 2 V2 0.467 0.651 0.358 0.596 #> 3 V3 -0.817 0.770 -0.671 0.798 #> 4 V4 -0.301 0.773 -0.486 0.672 #> 5 V5 -0.000826 1.27 0.338 1.27 ``` Instead of `as_draws_matrix()` we also could have just used `as_draws()`, which attempts to find the closest available format to the input object. In this case this would result in a `draws_matrix` object either way. ### Contributing to posterior We welcome contributions! The **posterior** package is under active development. If you find bugs or have ideas for new features (for us or yourself to implement) please open an issue on GitHub (). ### Citing posterior Developing and maintaining open source software is an important yet often underappreciated contribution to scientific progress. Thus, whenever you are using open source software (or software in general), please make sure to cite it appropriately so that developers get credit for their work. When using **posterior**, please cite it as follows: - Bürkner P. C., Gabry J., Kay M., & Vehtari A. (2020). “posterior: Tools for Working with Posterior Distributions.” R package version XXX, \\>. When using the MCMC convergence diagnostics `rhat`, `ess_bulk`, or `ess_tail`, please also cite - Vehtari A., Gelman A., Simpson D., Carpenter B., & Bürkner P. C. (2021). Rank-normalization, folding, and localization: An improved Rhat for assessing convergence of MCMC (with discussion). *Bayesian Analysis*. 16(2), 667–718. doi.org/10.1214/20-BA1221 The same information can be obtained by running `citation("posterior")`. ### References Gelman A., Carlin J. B., Stern H. S., David B. Dunson D. B., Aki Vehtari A., & Rubin D. B. (2013). *Bayesian Data Analysis, Third Edition*. Chapman and Hall/CRC. Vehtari A., Gelman A., Simpson D., Carpenter B., & Bürkner P. C. (2021). Rank-normalization, folding, and localization: An improved Rhat for assessing convergence of MCMC (with discussion). *Bayesian Analysis*. 16(2), 667–718. doi.org/10.1214/20-BA1221 ### Licensing The **posterior** package is licensed under the following licenses: - Code: BSD 3-clause () - Documentation: CC-BY 4.0 () posterior/man/0000755000175000017500000000000014165340155013211 5ustar nileshnileshposterior/man/print.draws_df.Rd0000644000175000017500000000255714165314652016440 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/print.R \name{print.draws_df} \alias{print.draws_df} \title{Print \code{draws_df} objects} \usage{ \method{print}{draws_df}( x, digits = 2, max_draws = getOption("posterior.max_draws", 10), max_variables = getOption("posterior.max_variables", 8), reserved = FALSE, ... ) } \arguments{ \item{x}{(draws) A \code{draws} object or another \R object for which the method is defined.} \item{digits}{(nonnegative integer) The minimum number of significant digits to print.} \item{max_draws}{(positive integer) The maximum number of draws to print. Can be controlled globally via the \code{"posterior.max_draws"} \link[base:options]{option}.} \item{max_variables}{(positive integer) The maximum number of variables to print. Can be controlled globally via the \code{"posterior.max_variables"} \link[base:options]{option}.} \item{reserved}{(logical) Should reserved variables be included in the output? Defaults to \code{FALSE}. See \code{\link{reserved_variables}} for an overview of currently reserved variable names.} \item{...}{Further arguments passed to the underlying \code{\link[=print]{print()}} methods.} } \value{ A \code{draws} object of the same class as \code{x}. } \description{ Pretty printing for \code{\link{draws_df}} objects. } \examples{ x <- as_draws_df(example_draws()) print(x) } posterior/man/rvar_rng.Rd0000755000175000017500000000536414165314652015336 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/rvar-rfun.R \name{rvar_rng} \alias{rvar_rng} \title{Create random variables from existing random number generators} \usage{ rvar_rng(.f, n, ..., ndraws = NULL) } \arguments{ \item{.f}{(function) A function (or string naming a function) representing a random-number generating function that follows the pattern of base random number generators (like \code{rnorm()}, \code{rbinom()}, etc). It must: \itemize{ \item Have a first argument, \code{n}, giving the number of draws to take from the distribution \item Have vectorized parameter arguments \item Return a single vector of length \code{n} }} \item{n}{(positive integer) The length of the output \code{\link{rvar}} vector (\strong{not} the number of draws).} \item{...}{Arguments passed to \code{.f}. These arguments may include \code{\link{rvar}}s, so long as they are vectors only (no multidimensional \code{\link{rvar}}s are allowed).} \item{ndraws}{(positive integer) The number of draws used to construct the returned random variable if no \code{\link{rvar}}s are supplied in \code{...}. If \code{NULL}, \code{getOption("posterior.rvar_ndraws")} is used (default 4000). If \code{...} contains \code{\link{rvar}}s, the number of draws in the provided \code{\link{rvar}}s is used instead of the value of this argument.} } \value{ A single-dimensional \code{\link{rvar}} of length \code{n}. } \description{ Specialized alternative to \code{rdo()} or \code{rfun()} for creating \code{\link{rvar}}s from existing random-number generator functions (such as \code{rnorm()}, \code{rbinom()}, etc). } \details{ This function unwraps the arrays underlying the input \code{\link{rvar}}s in \code{...} and then passes them to \code{.f}, relying on the vectorization of \code{.f} to evaluate it across draws from the input \code{\link{rvar}}s. This is why the arguments of \code{.f} \strong{must} be vectorized. It asks for \code{n} times the number of draws in the input \code{\link{rvar}}s (or \code{ndraws} if none are given) draws from the random number generator \code{.f}, then reshapes the output from \code{.f} into an \code{\link{rvar}} with length \code{n}. \code{rvar_rng()} is a fast alternative to \code{rdo()} or \code{rfun()}, but you \strong{must} ensure that \code{.f} satisfies the preconditions described above for the result to be correct. Most base random number generators satisfy these conditions. It is advisable to test against \code{rdo()} or \code{rfun()} (which should be correct, but slower) if you are uncertain. } \examples{ mu <- rvar_rng(rnorm, 10, mean = 1:10, sd = 1) sigma <- rvar_rng(rgamma, 1, shape = 1, rate = 1) x <- rvar_rng(rnorm, 10, mu, sigma) x } \seealso{ Other rfun: \code{\link{rdo}()}, \code{\link{rfun}()} } \concept{rfun} posterior/man/chol.rvar.Rd0000755000175000017500000000111014165314652015375 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/rvar-math.R \name{chol.rvar} \alias{chol.rvar} \title{Cholesky decomposition of random matrix} \usage{ \method{chol}{rvar}(x, ...) } \arguments{ \item{x}{(rvar) A 2-dimensional \code{\link{rvar}}.} \item{...}{Additional parameters passed on to \code{chol.tensor()}} } \value{ An \code{\link{rvar}} containing the upper triangular factor of the Cholesky decomposition, i.e., the matrix \eqn{R} such that \eqn{R'R = x}. } \description{ Cholesky decomposition of an \code{\link{rvar}} containing a matrix. } posterior/man/draws_array.Rd0000755000175000017500000000412214165314652016023 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/as_draws_array.R \name{draws_array} \alias{draws_array} \alias{as_draws_array} \alias{as_draws_array.default} \alias{as_draws_array.draws_array} \alias{as_draws_array.draws_matrix} \alias{as_draws_array.draws_df} \alias{as_draws_array.draws_list} \alias{as_draws_array.draws_rvars} \alias{as_draws_array.mcmc} \alias{as_draws_array.mcmc.list} \alias{is_draws_array} \title{The \code{draws_array} format} \usage{ as_draws_array(x, ...) \method{as_draws_array}{default}(x, ...) \method{as_draws_array}{draws_array}(x, ...) \method{as_draws_array}{draws_matrix}(x, ...) \method{as_draws_array}{draws_df}(x, ...) \method{as_draws_array}{draws_list}(x, ...) \method{as_draws_array}{draws_rvars}(x, ...) \method{as_draws_array}{mcmc}(x, ...) \method{as_draws_array}{mcmc.list}(x, ...) draws_array(..., .nchains = 1) is_draws_array(x) } \arguments{ \item{x}{An object to convert to a \code{draws_array} object.} \item{...}{For \code{as_draws_array()}: Arguments passed to individual methods (if applicable). For \code{draws_array()}: Named arguments containing numeric vectors each defining a separate variable.} \item{.nchains}{(positive integer) The number of chains. The default is \code{1}.} } \value{ A \code{draws_array} object, which has classes \code{c("draws_array", "draws", "array")}. } \description{ The \code{as_draws_array()} methods convert objects to the \code{draws_array} format. The \code{draws_array()} function creates an object of the \code{draws_array} format based on a set of numeric vectors. See \strong{Details}. } \details{ Objects of class \code{"draws_array"} are 3-D arrays with dimensions \code{"iteration"}, \code{"chain"}, and \code{"variable"}. See \strong{Examples}. } \examples{ x1 <- as_draws_array(example_draws()) class(x1) print(x1) str(x1) x2 <- draws_array(a = rnorm(10), b = rnorm(10), c = 1) class(x2) print(x2) str(x2) } \seealso{ Other formats: \code{\link{draws_df}()}, \code{\link{draws_list}()}, \code{\link{draws_matrix}()}, \code{\link{draws_rvars}()}, \code{\link{draws}} } \concept{formats} posterior/man/bind_draws.Rd0000644000175000017500000000307314165314652015622 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/bind_draws.R \name{bind_draws} \alias{bind_draws} \alias{bind_draws.draws_matrix} \alias{bind_draws.draws_array} \alias{bind_draws.draws_df} \alias{bind_draws.draws_list} \alias{bind_draws.draws_rvars} \title{Bind \code{draws} objects together} \usage{ bind_draws(x, ...) \method{bind_draws}{draws_matrix}(x, ..., along = "variable") \method{bind_draws}{draws_array}(x, ..., along = "variable") \method{bind_draws}{draws_df}(x, ..., along = "variable") \method{bind_draws}{draws_list}(x, ..., along = "variable") \method{bind_draws}{draws_rvars}(x, ..., along = "variable") } \arguments{ \item{x}{(draws) A \code{\link{draws}} object. The draws format of \code{x} will define the format of the returned draws object.} \item{...}{(draws) Additional \code{\link{draws}} objects to bind to \code{x}.} \item{along}{(string) The dimension along which draws objects should be bound together. Possible values are \code{"variable"} (the default), \code{"chain"}, \code{"iteration"}, and \code{"draw"}. Not all options are supported for all input formats.} } \value{ A \code{draws} object of the same class as \code{x}. } \description{ Bind multiple \code{\link{draws}} objects together to form a single \code{draws} object. } \examples{ x1 <- draws_matrix(alpha = rnorm(5), beta = rnorm(5)) x2 <- draws_matrix(alpha = rnorm(5), beta = rnorm(5)) ndraws(x1) ndraws(x2) x3 <- bind_draws(x1, x2, along = "draw") ndraws(x3) x4 <- draws_matrix(theta = rexp(5)) x5 <- bind_draws(x1, x4, along = "variable") variables(x5) } posterior/man/r_scale.Rd0000644000175000017500000000103414165314652015111 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/convergence.R \name{r_scale} \alias{r_scale} \title{Rank values} \usage{ r_scale(x) } \arguments{ \item{x}{(numeric) A scalar, vector, matrix, or array of values.} } \value{ A numeric array of ranked values with the same size and dimension as the input. } \description{ Compute ranks for a numeric array, that is, replace each value by its rank. Average rank for ties are used to conserve the number of unique values of discrete quantities. } \keyword{internal} posterior/man/z_scale.Rd0000644000175000017500000000134714165314652015130 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/convergence.R \name{z_scale} \alias{z_scale} \title{Rank normalization} \usage{ z_scale(x, c = 3/8) } \arguments{ \item{x}{(numeric) A scalar, vector, matrix, or array of values.} \item{c}{(numeric) Fractional offset used in the back-transformation of ranks. Defaults to \code{3/8}.} } \value{ A numeric array of rank normalized values with the same size and dimension as the input. } \description{ Compute rank normalization for a numeric array. First replace each value by its rank. Average rank for ties are used to conserve the number of unique values of discrete quantities. Second, normalize ranks via the inverse normal transformation. } \keyword{internal} posterior/man/draws_df.Rd0000755000175000017500000000564214165314652015306 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/as_draws_df.R \name{draws_df} \alias{draws_df} \alias{as_draws_df} \alias{as_draws_df.default} \alias{as_draws_df.data.frame} \alias{as_draws_df.draws_df} \alias{as_draws_df.draws_matrix} \alias{as_draws_df.draws_array} \alias{as_draws_df.draws_list} \alias{as_draws_df.draws_rvars} \alias{as_draws_df.mcmc} \alias{as_draws_df.mcmc.list} \alias{is_draws_df} \title{The \code{draws_df} format} \usage{ as_draws_df(x, ...) \method{as_draws_df}{default}(x, ...) \method{as_draws_df}{data.frame}(x, ...) \method{as_draws_df}{draws_df}(x, ...) \method{as_draws_df}{draws_matrix}(x, ...) \method{as_draws_df}{draws_array}(x, ...) \method{as_draws_df}{draws_list}(x, ...) \method{as_draws_df}{draws_rvars}(x, ...) \method{as_draws_df}{mcmc}(x, ...) \method{as_draws_df}{mcmc.list}(x, ...) draws_df(..., .nchains = 1) is_draws_df(x) } \arguments{ \item{x}{An object to convert to a \code{draws_df} object.} \item{...}{For \code{as_draws_df()}: Arguments passed to individual methods (if applicable). For \code{draws_df()}: Named arguments containing numeric vectors each defining a separate variable.} \item{.nchains}{(positive integer) The number of chains. The default is \code{1}.} } \value{ A \code{draws_df} object, which has classes \code{c("draws_df", "draws", class(tibble::tibble()))}. } \description{ The \code{as_draws_df()} methods convert objects to the \code{draws_df} format. The \code{draws_df()} function creates an object of the \code{draws_df} format based on a set of numeric vectors. See \strong{Details}. } \details{ Objects of class \code{"draws_df"} are \link[tibble:tibble]{tibble} data frames. They have one column per variable as well as additional metadata columns \code{".iteration"}, \code{".chain"}, and \code{".draw"}. The difference between the \code{".iteration"} and \code{".draw"} columns is that the former is relative to the MCMC chain while the latter ignores the chain information and has all unique values. See \strong{Examples}. If a \code{data.frame}-like object is supplied to \code{as_draws_df} that contains columns named \code{".iteration"} or \code{".chain"}, they will be treated as iteration and chain indices, respectively. See \strong{Examples}. } \examples{ x1 <- as_draws_df(example_draws()) class(x1) print(x1) str(x1) x2 <- draws_df(a = rnorm(10), b = rnorm(10), c = 1) class(x2) print(x2) str(x2) # the difference between iteration and draw is clearer when contrasting # the head and tail of the data frame print(head(x1), reserved = TRUE, max_variables = 2) print(tail(x1), reserved = TRUE, max_variables = 2) # manually supply chain information xnew <- data.frame(mu = rnorm(10), .chain = rep(1:2, each = 5)) xnew <- as_draws_df(xnew) print(xnew) } \seealso{ Other formats: \code{\link{draws_array}()}, \code{\link{draws_list}()}, \code{\link{draws_matrix}()}, \code{\link{draws_rvars}()}, \code{\link{draws}} } \concept{formats} posterior/man/autocorrelation.Rd0000644000175000017500000000110414165314652016711 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/convergence.R \name{autocorrelation} \alias{autocorrelation} \title{Autocorrelation estimates} \usage{ autocorrelation(x) } \arguments{ \item{x}{(numeric vector) A sequence of values.} } \value{ A numeric vector of autocorrelations at every lag (scaled by N-lag). } \description{ Compute autocorrelation estimates for every lag for the specified input sequence using a fast Fourier transform approach. The estimate for lag t is scaled by N-t where N is the length of the sequence. } \keyword{internal} posterior/man/draws-index.Rd0000644000175000017500000000353414165314652015735 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/draws-index.R \name{draws-index} \alias{draws-index} \alias{variables} \alias{variables<-} \alias{iteration_ids} \alias{chain_ids} \alias{draw_ids} \alias{nvariables} \alias{niterations} \alias{nchains} \alias{ndraws} \title{Index \code{draws} objects} \usage{ variables(x, ...) variables(x) <- value iteration_ids(x) chain_ids(x) draw_ids(x) nvariables(x, ...) niterations(x) nchains(x) ndraws(x) } \arguments{ \item{x}{(draws) A \code{draws} object or another \R object for which the method is defined.} \item{...}{Arguments passed to individual methods (if applicable).} \item{value}{(character vector) For \code{variables(x) <- value}, the new variable names to use.} } \value{ For \code{variables()}, a character vector. For \code{iteration_ids()}, \code{chain_ids()}, and \code{draw_ids()}, an integer vector. For \code{niterations()}, \code{nchains()}, and \code{ndraws()}, a scalar integer. } \description{ Index variables, iterations, chains, and draws. } \details{ The methods \code{variables()}, \code{iteration_ids()}, \code{chain_ids()}, and \code{draw_ids()} return vectors of all variables, iterations, chains, and draws, respectively. In contrast, the methods \code{nvariables()}, \code{niterations()}, \code{nchains()}, and \code{ndraws()} return the number of variables, iterations, chains, and draws, respectively. \code{variables(x) <- value} allows you to modify the vector of variable names, similar to how \code{names(x) <- value} works for vectors and lists. For renaming specific variables, \code{\link[=rename_variables]{rename_variables()}} may offer a more convenient approach. } \examples{ x <- example_draws() variables(x) nvariables(x) variables(x) <- letters[1:nvariables(x)] iteration_ids(x) niterations(x) chain_ids(x) nchains(x) draw_ids(x) ndraws(x) } posterior/man/rvar_apply.Rd0000755000175000017500000000577214165314652015700 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/rvar-apply.R \name{rvar_apply} \alias{rvar_apply} \title{Random variable resulting from a function applied over margins of an array or random variable} \usage{ rvar_apply(.x, .margin, .f, ...) } \arguments{ \item{.x}{An array or an \code{\link{rvar}}.} \item{.margin}{(multiple options) The subscripts which the function will be applied over: \itemize{ \item An integer vector. E.g., for a matrix \code{1} indicates rows, \code{2} indicates columns, \code{c(1, 2)} indicates rows and columns. \item A character vector of dimension names if \code{.x} has named dimensions. }} \item{.f}{(function) The function to be applied. The function \code{.f} must return an \code{\link{rvar}} and the dimensions of the result of \code{.f} applied to each margin of \code{.x} must be able to be broadcasted to a common shape (otherwise the resulting \code{\link{rvar}} cannot be simplified). See \strong{Details}.} \item{...}{Optional arguments passed to \code{.f}.} } \value{ An \code{\link{rvar}}. If the result of each call to \code{.f} returns an \code{\link{rvar}} of dimension \code{d} after being broadcast to a common shape, then \code{rvar_apply()} returns an \code{\link{rvar}} of dimension \code{c(d, dim(.x)[.margin])}. If the last dimension of the result would be \code{1}, it is dropped (other dimensions equal to \code{1} are retained). If \code{d} is \code{0}, the result has length \code{0} but not necessarily the 'correct' dimension. } \description{ Returns an \code{\link{rvar}} obtained by applying a function to margins of an array or \code{\link{rvar}}. Acts like \code{apply()}, except that the function supplied (\code{.f}) should return an \code{\link{rvar}}, and the final result is always an \code{\link{rvar}}. } \details{ This function acts much like \code{apply()}, except that the function passed to it (\code{.f}) must return \code{\link{rvar}}s, and the result is simplified into an \code{\link{rvar}}. Unlike \code{apply()}, it also keeps the dimensions of the returned values along each margin, rather than simplifying each margin to a vector, and if the results of \code{.f} do not all have the same dimensions, it applies the \code{\link{rvar}} broadcasting rules to bind results together rather than using vector recycling. If you wish to apply functions over \code{\link{rvar}}s where the result is not intended to be simplified into an \code{\link{rvar}}, you can use the standard \code{apply()}, \code{lapply()}, \code{sapply()}, or \code{vapply()} functions. } \examples{ set.seed(3456) x <- rvar_rng(rnorm, 24, mean = 1:24) dim(x) <- c(2,3,4) # we can find the distributions of marginal means of the above array # using rvar_mean along with rvar_apply rvar_apply(x, 1, rvar_mean) rvar_apply(x, 2:3, rvar_mean) } \seealso{ \code{\link[=as_rvar]{as_rvar()}} to convert objects to \code{rvar}s. See \code{\link[=rdo]{rdo()}}, \code{\link[=rfun]{rfun()}}, and \code{\link[=rvar_rng]{rvar_rng()}} for higher-level interfaces for creating \code{rvar}s. } posterior/man/rdo.Rd0000755000175000017500000000532614165314652014300 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/rvar-rfun.R \name{rdo} \alias{rdo} \title{Execute expressions of random variables} \usage{ rdo(expr, dim = NULL, ndraws = NULL) } \arguments{ \item{expr}{(expression) A bare expression that can (optionally) contain \code{\link{rvar}}s. The expression supports \link{quasiquotation}.} \item{dim}{(integer vector) One or more integers giving the maximal indices in each dimension to override the dimensions of the \code{\link{rvar}} to be created (see \code{\link[=dim]{dim()}}). If \code{NULL} (the default), \code{dim} is determined by the input. \strong{NOTE:} This argument controls the dimensions of the \code{\link{rvar}}, not the underlying array, so you cannot change the number of draws using this argument.} \item{ndraws}{(positive integer) The number of draws used to construct new random variables if no \code{\link{rvar}}s are supplied in \code{expr}. If \code{NULL}, \code{getOption("posterior.rvar_ndraws")} is used (default 4000). If \code{expr} contains \code{\link{rvar}}s, the number of draws in the provided \code{\link{rvar}}s is used instead of the value of this argument.} } \value{ An \code{\link{rvar}}. } \description{ Execute (nearly) arbitrary \R expressions that may include \code{\link{rvar}}s, producing a new \code{\link{rvar}}. } \details{ This function evaluates \code{expr} possibly multiple times, once for each draw of the \code{\link{rvar}}s it contains, then returns a new \code{\link{rvar}} representing the output of those expressions. To identify \code{\link{rvar}}s, \code{rdo()} searches the calling environment for any variables named in \code{expr} for which \code{\link[=is_rvar]{is_rvar()}} evaluates to \code{TRUE}. If \code{expr} contains no \code{\link{rvar}}s, then it will be executed \code{ndraws} times and an \code{\link{rvar}} with that many draws returned. \code{rdo()} is not necessarily \emph{fast} (in fact in some cases it may be very slow), but it has the advantage of allowing a nearly arbitrary R expression to be executed against \code{\link{rvar}}s simply by wrapping it with \code{rdo( ... )}. This makes it especially useful as a prototyping tool. If you create code with \code{rdo()} and it is unacceptably slow for your application, consider rewriting it using math operations directly on \code{\link{rvar}}s (which should be fast), using \code{\link[=rvar_rng]{rvar_rng()}}, and/or using operations directly on the arrays that back the \code{\link{rvar}}s (via \code{\link[=draws_of]{draws_of()}}). } \examples{ mu <- rdo(rnorm(10, mean = 1:10, sd = 1)) sigma <- rdo(rgamma(1, shape = 1, rate = 1)) x <- rdo(rnorm(10, mu, sigma)) x } \seealso{ Other rfun: \code{\link{rfun}()}, \code{\link{rvar_rng}()} } \concept{rfun} posterior/man/draws_matrix.Rd0000755000175000017500000000415414165314652016216 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/as_draws_matrix.R \name{draws_matrix} \alias{draws_matrix} \alias{as_draws_matrix} \alias{as_draws_matrix.default} \alias{as_draws_matrix.draws_matrix} \alias{as_draws_matrix.draws_array} \alias{as_draws_matrix.draws_df} \alias{as_draws_matrix.draws_list} \alias{as_draws_matrix.draws_rvars} \alias{as_draws_matrix.mcmc} \alias{as_draws_matrix.mcmc.list} \alias{is_draws_matrix} \title{The \code{draws_matrix} format} \usage{ as_draws_matrix(x, ...) \method{as_draws_matrix}{default}(x, ...) \method{as_draws_matrix}{draws_matrix}(x, ...) \method{as_draws_matrix}{draws_array}(x, ...) \method{as_draws_matrix}{draws_df}(x, ...) \method{as_draws_matrix}{draws_list}(x, ...) \method{as_draws_matrix}{draws_rvars}(x, ...) \method{as_draws_matrix}{mcmc}(x, ...) \method{as_draws_matrix}{mcmc.list}(x, ...) draws_matrix(..., .nchains = 1) is_draws_matrix(x) } \arguments{ \item{x}{An object to convert to a \code{draws_matrix} object.} \item{...}{For \code{as_draws_matrix()}: Arguments passed to individual methods (if applicable). For \code{draws_matrix()}: Named arguments containing numeric vectors each defining a separate variable.} \item{.nchains}{(positive integer) The number of chains. The default is \code{1}.} } \value{ A \code{draws_matrix} object, which has classes \code{c("draws_matrix", "draws", "matrix")}. } \description{ The \code{as_draws_matrix()} methods convert objects to the \code{draws_matrix} format. The \code{draws_matrix()} function creates an object of the \code{draws_matrix} format based on a set of numeric vectors. See \strong{Details}. } \details{ Objects of class \code{"draws_matrix"} are matrices (2-D arrays) with dimensions \code{"draw"} and \code{"variable"}. See \strong{Examples}. } \examples{ x1 <- as_draws_matrix(example_draws()) class(x1) print(x1) str(x1) x2 <- draws_matrix(a = rnorm(10), b = rnorm(10), c = 1) class(x2) print(x2) str(x2) } \seealso{ Other formats: \code{\link{draws_array}()}, \code{\link{draws_df}()}, \code{\link{draws_list}()}, \code{\link{draws_rvars}()}, \code{\link{draws}} } \concept{formats} posterior/man/ess_quantile.Rd0000755000175000017500000000611714165316131016201 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/convergence.R \name{ess_quantile} \alias{ess_quantile} \alias{ess_quantile.default} \alias{ess_quantile.rvar} \alias{ess_median} \alias{ess_mean.default} \title{Effective sample sizes for quantiles} \usage{ ess_quantile(x, probs = c(0.05, 0.95), ...) \method{ess_quantile}{default}(x, probs = c(0.05, 0.95), names = TRUE, ...) \method{ess_quantile}{rvar}(x, probs = c(0.05, 0.95), names = TRUE, ...) ess_median(x, ...) \method{ess_mean}{default}(x, ...) } \arguments{ \item{x}{(multiple options) One of: \itemize{ \item A matrix of draws for a single variable (iterations x chains). See \code{\link[=extract_variable_matrix]{extract_variable_matrix()}}. \item An \code{\link{rvar}}. }} \item{probs}{(numeric vector) Probabilities in \verb{[0, 1]}.} \item{...}{Arguments passed to individual methods (if applicable).} \item{names}{(logical) Should the result have a \code{names} attribute? The default is \code{TRUE}, but use \code{FALSE} for improved speed if there are many values in \code{probs}.} } \value{ If the input is an array, returns a numeric vector with one element per quantile. If any of the draws is non-finite, that is, \code{NA}, \code{NaN}, \code{Inf}, or \code{-Inf}, the returned output will be a vector of (numeric) \code{NA} values. Also, if all draws of a variable are the same (constant), the returned output will be a vector of (numeric) \code{NA} values as well. The reason for the latter is that, for constant draws, we cannot distinguish between variables that are supposed to be constant (e.g., a diagonal element of a correlation matrix is always 1) or variables that just happened to be constant because of a failure of convergence or other problems in the sampling process. If the input is an \code{\link{rvar}} and \code{length(probs) == 1}, returns an array of the same dimensions as the \code{\link{rvar}}, where each element is equal to the value that would be returned by passing the draws array for that element of the \code{\link{rvar}} to this function. If \code{length(probs) > 1}, the first dimension of the result indexes the input probabilities; i.e. the result has dimension \code{c(length(probs), dim(x))}. } \description{ Compute effective sample size estimates for quantile estimates of a single variable. } \examples{ mu <- extract_variable_matrix(example_draws(), "mu") ess_quantile(mu, probs = c(0.1, 0.9)) d <- as_draws_rvars(example_draws("multi_normal")) ess_quantile(d$mu, probs = c(0.1, 0.9)) } \references{ Aki Vehtari, Andrew Gelman, Daniel Simpson, Bob Carpenter, and Paul-Christian Bürkner (2021). Rank-normalization, folding, and localization: An improved R-hat for assessing convergence of MCMC (with discussion). \emph{Bayesian Data Analysis}. 16(2), 667-–718. doi:10.1214/20-BA1221 } \seealso{ Other diagnostics: \code{\link{ess_basic}()}, \code{\link{ess_bulk}()}, \code{\link{ess_sd}()}, \code{\link{ess_tail}()}, \code{\link{mcse_mean}()}, \code{\link{mcse_quantile}()}, \code{\link{mcse_sd}()}, \code{\link{rhat_basic}()}, \code{\link{rhat}()}, \code{\link{rstar}()} } \concept{diagnostics} posterior/man/resample_draws.Rd0000644000175000017500000000550214165314652016515 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/resample_draws.R \name{resample_draws} \alias{resample_draws} \alias{resample_draws.draws} \title{Resample \code{draws} objects} \usage{ resample_draws(x, ...) \method{resample_draws}{draws}(x, weights = NULL, method = "stratified", ndraws = NULL, ...) } \arguments{ \item{x}{(draws) A \code{draws} object or another \R object for which the method is defined.} \item{...}{Arguments passed to individual methods (if applicable).} \item{weights}{(numeric vector) A vector of positive weights of length \code{ndraws(x)}. The weights will be internally normalized. If \code{weights} is not specified, an attempt will be made to extract any weights already stored in the draws object (via \code{\link[=weight_draws]{weight_draws()}}). How exactly the weights influence the resampling depends on the \code{method} argument.} \item{method}{(string) The resampling method to use: \itemize{ \item \code{"simple"}: simple random resampling with replacement \item \code{"simple_no_replace"}: simple random resampling without replacement \item \code{"stratified"}: stratified resampling with replacement \item \code{"deterministic"}: deterministic resampling with replacement } Currently, \code{"stratified"} is the default as it has comparably low variance and bias with respect to ideal resampling. The latter would sample perfectly proportional to the weights, but this is not possible in practice due to the finite number of draws available. For more details about resampling methods, see Kitagawa (1996).} \item{ndraws}{(positive integer) The number of draws to be returned. By default \code{ndraws} is set internally to the total number of draws in \code{x} if sensible.} } \value{ A \code{draws} object of the same class as \code{x}. } \description{ Resample \code{\link{draws}} objects according to provided weights, for example weights obtained through importance sampling. } \details{ Upon usage of \code{resample_draws()}, chains will automatically be merged due to subsetting of individual draws (see \code{\link{subset_draws}} for details). Also, weights stored in the \code{draws} object will be removed in the process, as resampling invalidates existing weights. } \examples{ x <- as_draws_df(example_draws()) # random weights for justr for demonstration w <- runif(ndraws(x), 0, 10) # use default stratified sampling x_rs <- resample_draws(x, weights = w) summarise_draws(x_rs, default_summary_measures()) # use simple random sampling x_rs <- resample_draws(x, weights = w, method = "simple") summarise_draws(x_rs, default_summary_measures()) } \references{ Kitagawa, G., Monte Carlo Filter and Smoother for Non-Gaussian Nonlinear ' State Space Models, \emph{Journal of Computational and Graphical Statistics}, 5(1):1-25, 1996. } \seealso{ \code{\link[=resample_draws]{resample_draws()}} } posterior/man/ess_bulk.Rd0000755000175000017500000000552614165316332015322 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/convergence.R \name{ess_bulk} \alias{ess_bulk} \alias{ess_bulk.default} \alias{ess_bulk.rvar} \title{Bulk effective sample size (bulk-ESS)} \usage{ ess_bulk(x, ...) \method{ess_bulk}{default}(x, ...) \method{ess_bulk}{rvar}(x, ...) } \arguments{ \item{x}{(multiple options) One of: \itemize{ \item A matrix of draws for a single variable (iterations x chains). See \code{\link[=extract_variable_matrix]{extract_variable_matrix()}}. \item An \code{\link{rvar}}. }} \item{...}{Arguments passed to individual methods (if applicable).} } \value{ If the input is an array, returns a single numeric value. If any of the draws is non-finite, that is, \code{NA}, \code{NaN}, \code{Inf}, or \code{-Inf}, the returned output will be (numeric) \code{NA}. Also, if all draws within any of the chains of a variable are the same (constant), the returned output will be (numeric) \code{NA} as well. The reason for the latter is that, for constant draws, we cannot distinguish between variables that are supposed to be constant (e.g., a diagonal element of a correlation matrix is always 1) or variables that just happened to be constant because of a failure of convergence or other problems in the sampling process. If the input is an \code{\link{rvar}}, returns an array of the same dimensions as the \code{\link{rvar}}, where each element is equal to the value that would be returned by passing the draws array for that element of the \code{\link{rvar}} to this function. } \description{ Compute a bulk effective sample size estimate (bulk-ESS) for a single variable. Bulk-ESS is useful as a diagnostic for the sampling efficiency in the bulk of the posterior. It is defined as the effective sample size for rank normalized values using split chains. For the tail effective sample size see \code{\link[=ess_tail]{ess_tail()}}. See Vehtari (2021) for an in-depth comparison of different effective sample size estimators. } \examples{ mu <- extract_variable_matrix(example_draws(), "mu") ess_bulk(mu) d <- as_draws_rvars(example_draws("multi_normal")) ess_bulk(d$Sigma) } \references{ Aki Vehtari, Andrew Gelman, Daniel Simpson, Bob Carpenter, and Paul-Christian Bürkner (2021). Rank-normalization, folding, and localization: An improved R-hat for assessing convergence of MCMC (with discussion). \emph{Bayesian Data Analysis}. 16(2), 667-–718. doi:10.1214/20-BA1221 Aki Vehtari (2021). Comparison of MCMC effective sample size estimators. Retrieved from https://avehtari.github.io/rhat_ess/ess_comparison.html } \seealso{ Other diagnostics: \code{\link{ess_basic}()}, \code{\link{ess_quantile}()}, \code{\link{ess_sd}()}, \code{\link{ess_tail}()}, \code{\link{mcse_mean}()}, \code{\link{mcse_quantile}()}, \code{\link{mcse_sd}()}, \code{\link{rhat_basic}()}, \code{\link{rhat}()}, \code{\link{rstar}()} } \concept{diagnostics} posterior/man/extract_variable_matrix.Rd0000644000175000017500000000220514165314652020405 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/extract_variable_matrix.R \name{extract_variable_matrix} \alias{extract_variable_matrix} \alias{extract_variable_matrix.default} \alias{extract_variable_matrix.draws} \alias{extract_variable_matrix.draws_rvars} \title{Extract matrix of a single variable} \usage{ extract_variable_matrix(x, variable, ...) \method{extract_variable_matrix}{default}(x, variable, ...) \method{extract_variable_matrix}{draws}(x, variable, ...) \method{extract_variable_matrix}{draws_rvars}(x, variable, ...) } \arguments{ \item{x}{(draws) A \code{draws} object or another \R object for which the method is defined.} \item{variable}{(string) The name of the variable to extract.} \item{...}{Arguments passed to individual methods (if applicable).} } \value{ A \code{matrix} with dimension iterations x chains. } \description{ Extract an iterations x chains matrix of draws of a single variable. This is primarily used for convergence diagnostic functions such as \code{\link[=rhat]{rhat()}}. } \examples{ x <- example_draws() mu <- extract_variable_matrix(x, variable = "mu") dim(mu) rhat(mu) } posterior/man/extract_variable.Rd0000644000175000017500000000167514165314652017033 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/extract_variable.R \name{extract_variable} \alias{extract_variable} \alias{extract_variable.default} \alias{extract_variable.draws} \alias{extract_variable.draws_rvars} \title{Extract draws of a single variable} \usage{ extract_variable(x, variable, ...) \method{extract_variable}{default}(x, variable, ...) \method{extract_variable}{draws}(x, variable, ...) \method{extract_variable}{draws_rvars}(x, variable, ...) } \arguments{ \item{x}{(draws) A \code{draws} object or another \R object for which the method is defined.} \item{variable}{(string) The name of the variable to extract.} \item{...}{Arguments passed to individual methods (if applicable).} } \value{ A numeric vector of length equal to the number of draws. } \description{ Extract a vector of draws of a single variable. } \examples{ x <- example_draws() mu <- extract_variable(x, variable = "mu") str(mu) } posterior/man/reexports.Rd0000755000175000017500000000075614165314652015551 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/rvar-dist.R, R/rvar-summaries-over-draws.R \docType{import} \name{reexports} \alias{reexports} \alias{cdf} \alias{variance} \title{Objects exported from other packages} \keyword{internal} \description{ These objects are imported from other packages. Follow the links below to see their documentation. \describe{ \item{distributional}{\code{\link[distributional]{cdf}}, \code{\link[distributional]{variance}}} }} posterior/man/example_draws.Rd0000644000175000017500000000345614165314652016346 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/example_draws.R \name{example_draws} \alias{example_draws} \title{Example \code{draws} objects} \usage{ example_draws(example = "eight_schools") } \arguments{ \item{example}{(string) The name of the example \code{draws} object. See \strong{Details} for available options.} } \value{ A \code{draws} object. } \description{ Objects for use in examples, vignettes, and tests. } \details{ The following example \code{draws} objects are available. \strong{eight_schools}: A \code{\link{draws_array}} object with 100 iterations from each of 4 Markov chains obtained by fitting the eight schools model described in Gelman et al. (2013) with \href{https://mc-stan.org}{Stan}. The variables are: \itemize{ \item \code{mu}: Overall mean of the eight schools \item \code{tau}: Standard deviation between schools \item \code{theta}: Individual means of each of the eight schools } \strong{multi_normal}: A \code{\link{draws_array}} object with 100 iterations from each of the 4 Markov chains obtained by fitting a 3-dimensional multivariate normal model to 100 simulated observations. The variables are: \itemize{ \item \code{mu}: Mean parameter vector of length 3 \item \code{Sigma}: Covariance matrix of dimension 3 x 3 } } \note{ These objects are only intended to be used in demonstrations and tests. They contain fewer iterations and chains than recommended for performing actual inference. } \examples{ draws_eight_schools <- example_draws("eight_schools") summarise_draws(draws_eight_schools) draws_multi_normal <- example_draws("multi_normal") summarise_draws(draws_multi_normal) } \references{ Andrew Gelman, John B. Carlin, Hal S. Stern, David B. Dunson, Aki Vehtari and Donald B. Rubin (2013). Bayesian Data Analysis, Third Edition. Chapman and Hall/CRC. } posterior/man/split_chains.Rd0000644000175000017500000000120514165314652016161 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/split_chains.R \name{split_chains} \alias{split_chains} \title{Split Chains} \usage{ split_chains(x, ...) } \arguments{ \item{x}{(draws) A \code{draws} object or another \R object for which the method is defined.} \item{...}{Arguments passed to individual methods (if applicable).} } \value{ A \code{draws} object of the same class as \code{x}. } \description{ Split chains by halving the number of iterations per chain and doubling the number of chains. } \examples{ x <- example_draws() niterations(x) nchains(x) x <- split_chains(x) niterations(x) nchains(x) } posterior/man/draws_list.Rd0000755000175000017500000000425514165314652015667 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/as_draws_list.R \name{draws_list} \alias{draws_list} \alias{as_draws_list} \alias{as_draws_list.default} \alias{as_draws_list.draws_list} \alias{as_draws_list.draws_matrix} \alias{as_draws_list.draws_array} \alias{as_draws_list.draws_df} \alias{as_draws_list.draws_rvars} \alias{as_draws_list.mcmc} \alias{as_draws_list.mcmc.list} \alias{is_draws_list} \title{The \code{draws_list} format} \usage{ as_draws_list(x, ...) \method{as_draws_list}{default}(x, ...) \method{as_draws_list}{draws_list}(x, ...) \method{as_draws_list}{draws_matrix}(x, ...) \method{as_draws_list}{draws_array}(x, ...) \method{as_draws_list}{draws_df}(x, ...) \method{as_draws_list}{draws_rvars}(x, ...) \method{as_draws_list}{mcmc}(x, ...) \method{as_draws_list}{mcmc.list}(x, ...) draws_list(..., .nchains = 1) is_draws_list(x) } \arguments{ \item{x}{An object to convert to a \code{draws_list} object.} \item{...}{For \code{as_draws_list()}: Arguments passed to individual methods (if applicable). For \code{draws_list()}: Named arguments containing numeric vectors each defining a separate variable.} \item{.nchains}{(positive integer) The number of chains. The default is \code{1}.} } \value{ A \code{draws_list} object, which has classes \code{c("draws_list", "draws", "list")}. } \description{ The \code{as_draws_list()} methods convert objects to the \code{draws_list} format. The \code{draws_list()} function creates an object of the \code{draws_list} format based on a set of numeric vectors. See \strong{Details}. } \details{ Objects of class \code{"draws_list"} are lists with one element per MCMC chain. Each of these elements is itself a named list of numeric vectors with one vector per variable. The length of each vector is equal to the number of saved iterations per chain. See \strong{Examples}. } \examples{ x1 <- as_draws_list(example_draws()) class(x1) print(x1) str(x1) x2 <- draws_list(a = rnorm(10), b = rnorm(10), c = 1) class(x2) print(x2) str(x2) } \seealso{ Other formats: \code{\link{draws_array}()}, \code{\link{draws_df}()}, \code{\link{draws_matrix}()}, \code{\link{draws_rvars}()}, \code{\link{draws}} } \concept{formats} posterior/man/rfun.Rd0000755000175000017500000000553414165314652014467 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/rvar-rfun.R \name{rfun} \alias{rfun} \title{Create functions of random variables} \usage{ rfun(.f, rvar_args = NULL, ndraws = NULL) } \arguments{ \item{.f}{(multiple options) A function to turn into a function that accepts and/or produces random variables: \itemize{ \item A function \item A one-sided formula that can be parsed by \code{\link[rlang:as_function]{rlang::as_function()}} }} \item{rvar_args}{(character vector) The names of the arguments of \code{.f} that should be allowed to accept \code{\link{rvar}}s as arguments. If \code{NULL} (the default), all arguments to \code{.f} are turned into arguments that accept \code{\link{rvar}}s.} \item{ndraws}{(positive integer). The number of draws used to construct new random variables if no \code{\link{rvar}}s are supplied as arguments to the returned function. If \code{NULL}, \code{getOption("posterior.rvar_ndraws")} is used (default \code{4000}). If any arguments to the returned function contain \code{\link{rvar}}s, the number of draws in the provided \code{\link{rvar}}s is used instead of the value of this argument.} } \value{ A function with the same argument specification as \code{.f}, but which can accept and return \code{\link{rvar}}s. } \description{ Function that create functions that can accept and/or produce \code{\link{rvar}}s. } \details{ This function wraps an existing function (\code{.f}) such that it returns \code{\link{rvar}}s containing whatever type of data \code{.f} would normally return. The returned function, when called, executes \code{.f} possibly multiple times, once for each draw of the \code{\link{rvar}}s passed to it, then returns a new \code{\link{rvar}} representing the output of those function evaluations. If the arguments contain no \code{\link{rvar}}s, then \code{.f} will be executed \code{ndraws} times and an \code{\link{rvar}} with that many draws returned. Functions created by \code{rfun()} are not necessarily \emph{fast} (in fact in some cases they may be very slow), but they have the advantage of allowing a nearly arbitrary R functions to be executed against \code{\link{rvar}}s simply by wrapping them with \code{rfun()}. This makes it especially useful as a prototyping tool. If you create code with \code{rfun()} and it is unacceptably slow for your application, consider rewriting it using math operations directly on \code{\link{rvar}}s (which should be fast), using \code{\link[=rvar_rng]{rvar_rng()}}, and/or using operations directly on the arrays that back the \code{\link{rvar}}s (via \code{\link[=draws_of]{draws_of()}}). } \examples{ rvar_norm <- rfun(rnorm) rvar_gamma <- rfun(rgamma) mu <- rvar_norm(10, mean = 1:10, sd = 1) sigma <- rvar_gamma(1, shape = 1, rate = 1) x <- rvar_norm(10, mu, sigma) x } \seealso{ Other rfun: \code{\link{rdo}()}, \code{\link{rvar_rng}()} } \concept{rfun} posterior/man/draws_summary.Rd0000755000175000017500000000754014165314652016411 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/summarise_draws.R \name{draws_summary} \alias{draws_summary} \alias{summarise_draws} \alias{summarize_draws} \alias{summarise_draws.draws} \alias{summary.draws} \alias{summarise_draws.rvar} \alias{summary.rvar} \alias{default_summary_measures} \alias{default_convergence_measures} \alias{default_mcse_measures} \title{Summaries of \code{draws} objects} \usage{ summarise_draws(.x, ...) summarize_draws(.x, ...) \method{summarise_draws}{draws}(.x, ..., .args = list(), .cores = 1) \method{summary}{draws}(object, ...) \method{summarise_draws}{rvar}(.x, ...) \method{summary}{rvar}(object, ...) default_summary_measures() default_convergence_measures() default_mcse_measures() } \arguments{ \item{.x, object}{(draws) A \code{draws} object or one coercible to a \code{draws} object.} \item{...}{Name-value pairs of summary or \link[=diagnostics]{diagnostic} functions. The provided names will be used as the names of the columns in the result \emph{unless} the function returns a named vector, in which case the latter names are used. The functions can be specified in any format supported by \link[rlang:as_function]{as_function()}. See \strong{Examples}.} \item{.args}{(named list) Optional arguments passed to the summary functions.} \item{.cores}{(positive integer) The number of cores to use for computing summaries for different variables in parallel. Coerced to integer if possible, otherwise errors. The default is \code{.cores = 1}, in which case no parallelization is implemented. By default, a socket cluster is used on Windows and forks otherwise.} } \value{ The \code{summarise_draws()} methods return a \link[tibble:tibble]{tibble} data frame. The first column (\code{"variable"}) contains the variable names and the remaining columns contain summary statistics and diagnostics. The functions \code{default_summary_measures()}, \code{default_convergence_measures()}, and \code{default_mcse_measures()} return character vectors of names of the default measures. } \description{ The \code{summarise_draws()} (and \code{summarize_draws()}) methods provide a quick way to get a table of summary statistics and diagnostics. These methods will convert an object to a \code{draws} object if it isn't already. For convenience, a \link[base:summary]{summary()} method for \code{draws} and \code{rvar} objects are also provided as an alias for \code{summarise_draws()} if the input object is a \code{draws} or \code{rvar} object. } \details{ The default summary functions used are the ones specified by \code{default_summary_measures()} and \code{default_convergence_measures()}: \code{default_summary_measures()} \itemize{ \item \code{\link[=mean]{mean()}} \item \code{\link[=median]{median()}} \item \code{\link[=sd]{sd()}} \item \code{\link[=mad]{mad()}} \item \code{\link[=quantile2]{quantile2()}} } \code{default_convergence_measures()} \itemize{ \item \code{\link[=rhat]{rhat()}} \item \code{\link[=ess_bulk]{ess_bulk()}} \item \code{\link[=ess_tail]{ess_tail()}} } The \code{var()} function should not be used to compute variances due to its inconsistent behavior with matrices. Instead, please use \code{distributional::variance()}. } \examples{ x <- example_draws("eight_schools") class(x) str(x) summarise_draws(x) summarise_draws(x, "mean", "median") summarise_draws(x, mean, mcse = mcse_mean) summarise_draws(x, ~quantile(.x, probs = c(0.4, 0.6))) # using default_*_meaures() summarise_draws(x, default_summary_measures()) summarise_draws(x, default_convergence_measures()) summarise_draws(x, default_mcse_measures()) # compute variance of variables summarise_draws(x, var = distributional::variance) # illustrate use of '.args' ws <- rexp(ndraws(x)) summarise_draws(x, weighted.mean, .args = list(w = ws)) } \seealso{ \code{\link{diagnostics}} for a list of available diagnostics and links to their individual help pages. } posterior/man/rvar_is_finite.Rd0000755000175000017500000000246414165314652016517 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/rvar-summaries-within-draws.R \name{rvar_is_finite} \alias{rvar_is_finite} \alias{rvar_is_infinite} \alias{rvar_is_nan} \alias{rvar_is_na} \title{Special value predicates for random variables} \usage{ rvar_is_finite(x) rvar_is_infinite(x) rvar_is_nan(x) rvar_is_na(x) } \arguments{ \item{x}{(rvar) An \code{\link{rvar}}.} } \value{ A logical \code{\link{rvar}} of the same length as the input. } \description{ Compute special value predicates (checking for finite / infinite values, \code{NaN}, and \code{NA}) on all draws within a random variable, returning a random variable. } \details{ These functions return a new \code{\link{rvar}} that is the result of applying \code{is.finite()}, \code{is.infinite()}, \code{is.nan()}, or \code{is.na()} to every draw in the input random variable. } \examples{ x <- rvar(c(1, Inf, -Inf, NaN, NA)) x rvar_is_finite(x) rvar_is_infinite(x) rvar_is_nan(x) rvar_is_na(x) } \seealso{ \link{rvar-summaries-over-draws} for summary functions across draws, including implementations of \code{is.finite()}, \code{is.infinite()}, \code{is.nan()}, and \code{is.na()} for \code{rvar}s. Other rvar-summaries: \code{\link{rvar-summaries-over-draws}}, \code{\link{rvar-summaries-within-draws}} } \concept{rvar-summaries} posterior/man/reserved_variables.Rd0000644000175000017500000000353114165314652017354 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/reserved_variables.R \name{reserved_variables} \alias{reserved_variables} \alias{reserved_variables.default} \alias{reserved_variables.draws_matrix} \alias{reserved_variables.draws_array} \alias{reserved_variables.draws_df} \alias{reserved_variables.draws_list} \alias{reserved_variables.draws_rvars} \title{Reserved variables} \usage{ reserved_variables(x, ...) \method{reserved_variables}{default}(x, ...) \method{reserved_variables}{draws_matrix}(x, ...) \method{reserved_variables}{draws_array}(x, ...) \method{reserved_variables}{draws_df}(x, ...) \method{reserved_variables}{draws_list}(x, ...) \method{reserved_variables}{draws_rvars}(x, ...) } \arguments{ \item{x}{(draws) A \code{draws} object or another \R object for which the method is defined.} \item{...}{Arguments passed to individual methods (if applicable).} } \value{ A character vector of reserved variables used in \code{x}. } \description{ Get names of reserved variables from objects in the \pkg{posterior} package. } \details{ \code{reserved_variables()} returns the names of reserved variables in use by an object. The following variables names are currently reserved for special use cases in all \code{\link{draws}} formats: \itemize{ \item \code{.log_weight}: Log weights per draw (see \code{\link{weight_draws}}). } Further, specific for the \code{\link{draws_df}} format, there are three additional reserved variables: \itemize{ \item \code{.chain}: Chain index per draw \item \code{.iteration}: Iteration index within each chain \item \code{.draw}: Draw index across chains } More reserved variables may be added in the future. } \examples{ x <- example_draws() reserved_variables(x) # if we add weights, the `.log_weight` reserved variable is used x <- weight_draws(x, rexp(ndraws(x))) reserved_variables(x) } posterior/man/print.draws_list.Rd0000644000175000017500000000316514165314652017016 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/print.R \name{print.draws_list} \alias{print.draws_list} \title{Print \code{draws_list} objects} \usage{ \method{print}{draws_list}( x, digits = 2, max_iterations = getOption("posterior.max_iterations", 10), max_chains = getOption("posterior.max_chains", 2), max_variables = getOption("posterior.max_variables", 4), reserved = FALSE, ... ) } \arguments{ \item{x}{(draws) A \code{draws} object or another \R object for which the method is defined.} \item{digits}{(nonnegative integer) The minimum number of significant digits to print.} \item{max_iterations}{(positive integer) The maximum number of iterations to print. Can be controlled globally via the \code{"posterior.max_iterations"} \link[base:options]{option}.} \item{max_chains}{(positive integer) The maximum number of chains to print. Can be controlled globally via the \code{"posterior.max_chains"} \link[base:options]{option}.} \item{max_variables}{(positive integer) The maximum number of variables to print. Can be controlled globally via the \code{"posterior.max_variables"} \link[base:options]{option}.} \item{reserved}{(logical) Should reserved variables be included in the output? Defaults to \code{FALSE}. See \code{\link{reserved_variables}} for an overview of currently reserved variable names.} \item{...}{Further arguments passed to the underlying \code{\link[=print]{print()}} methods.} } \value{ A \code{draws} object of the same class as \code{x}. } \description{ Pretty printing for \code{\link{draws_list}} objects. } \examples{ x <- as_draws_list(example_draws()) print(x) } posterior/man/ess_mean.Rd0000755000175000017500000000361014165317763015306 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/convergence.R \name{ess_mean} \alias{ess_mean} \alias{ess_mean.rvar} \title{Effective sample size for the mean} \usage{ ess_mean(x, ...) \method{ess_mean}{rvar}(x, ...) } \arguments{ \item{x}{(multiple options) One of: \itemize{ \item A matrix of draws for a single variable (iterations x chains). See \code{\link[=extract_variable_matrix]{extract_variable_matrix()}}. \item An \code{\link{rvar}}. }} \item{...}{Arguments passed to individual methods (if applicable).} } \value{ If the input is an array, returns a single numeric value. If any of the draws is non-finite, that is, \code{NA}, \code{NaN}, \code{Inf}, or \code{-Inf}, the returned output will be (numeric) \code{NA}. Also, if all draws within any of the chains of a variable are the same (constant), the returned output will be (numeric) \code{NA} as well. The reason for the latter is that, for constant draws, we cannot distinguish between variables that are supposed to be constant (e.g., a diagonal element of a correlation matrix is always 1) or variables that just happened to be constant because of a failure of convergence or other problems in the sampling process. If the input is an \code{\link{rvar}}, returns an array of the same dimensions as the \code{\link{rvar}}, where each element is equal to the value that would be returned by passing the draws array for that element of the \code{\link{rvar}} to this function. } \description{ Compute an effective sample size estimate for a mean (expectation) estimate of a single variable. } \examples{ mu <- extract_variable_matrix(example_draws(), "mu") ess_mean(mu) d <- as_draws_rvars(example_draws("multi_normal")) ess_mean(d$Sigma) } \references{ Andrew Gelman, John B. Carlin, Hal S. Stern, David B. Dunson, Aki Vehtari and Donald B. Rubin (2013). \emph{Bayesian Data Analysis, Third Edition}. Chapman and Hall/CRC. } posterior/man/rhat.Rd0000755000175000017500000000464214165316131014444 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/convergence.R \name{rhat} \alias{rhat} \alias{rhat.default} \alias{rhat.rvar} \title{Rhat convergence diagnostic} \usage{ rhat(x, ...) \method{rhat}{default}(x, ...) \method{rhat}{rvar}(x, ...) } \arguments{ \item{x}{(multiple options) One of: \itemize{ \item A matrix of draws for a single variable (iterations x chains). See \code{\link[=extract_variable_matrix]{extract_variable_matrix()}}. \item An \code{\link{rvar}}. }} \item{...}{Arguments passed to individual methods (if applicable).} } \value{ If the input is an array, returns a single numeric value. If any of the draws is non-finite, that is, \code{NA}, \code{NaN}, \code{Inf}, or \code{-Inf}, the returned output will be (numeric) \code{NA}. Also, if all draws within any of the chains of a variable are the same (constant), the returned output will be (numeric) \code{NA} as well. The reason for the latter is that, for constant draws, we cannot distinguish between variables that are supposed to be constant (e.g., a diagonal element of a correlation matrix is always 1) or variables that just happened to be constant because of a failure of convergence or other problems in the sampling process. If the input is an \code{\link{rvar}}, returns an array of the same dimensions as the \code{\link{rvar}}, where each element is equal to the value that would be returned by passing the draws array for that element of the \code{\link{rvar}} to this function. } \description{ Compute the Rhat convergence diagnostic for a single variable as the maximum of rank normalized split-Rhat and rank normalized folded-split-Rhat as proposed in Vehtari et al. (2021). } \examples{ mu <- extract_variable_matrix(example_draws(), "mu") rhat(mu) d <- as_draws_rvars(example_draws("multi_normal")) rhat(d$Sigma) } \references{ Aki Vehtari, Andrew Gelman, Daniel Simpson, Bob Carpenter, and Paul-Christian Bürkner (2021). Rank-normalization, folding, and localization: An improved R-hat for assessing convergence of MCMC (with discussion). \emph{Bayesian Data Analysis}. 16(2), 667-–718. doi:10.1214/20-BA1221 } \seealso{ Other diagnostics: \code{\link{ess_basic}()}, \code{\link{ess_bulk}()}, \code{\link{ess_quantile}()}, \code{\link{ess_sd}()}, \code{\link{ess_tail}()}, \code{\link{mcse_mean}()}, \code{\link{mcse_quantile}()}, \code{\link{mcse_sd}()}, \code{\link{rhat_basic}()}, \code{\link{rstar}()} } \concept{diagnostics} posterior/man/u_scale.Rd0000644000175000017500000000141714165314652015121 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/convergence.R \name{u_scale} \alias{u_scale} \title{Rank uniformization} \usage{ u_scale(x, c = 3/8) } \arguments{ \item{x}{(numeric) A scalar, vector, matrix, or array of values.} \item{c}{(numeric) Fractional offset used in the back-transformation of ranks. Defaults to \code{3/8}.} } \value{ A numeric array of uniformized values with the same size and dimension as the input. } \description{ Compute rank uniformization for a numeric array. First replace each value by its rank. Average rank for ties are used to conserve the number of unique values of discrete quantities. Second, uniformize ranks to the scale \verb{[1/(2S), 1-1/(2S)]}, where \code{S} is the number of values. } \keyword{internal} posterior/man/print.draws_rvars.Rd0000755000175000017500000000274614165314652017207 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/print.R \encoding{UTF-8} \name{print.draws_rvars} \alias{print.draws_rvars} \title{Print \code{draws_rvars} objects} \usage{ \method{print}{draws_rvars}( x, digits = 2, max_variables = getOption("posterior.max_variables", 8), summary = getOption("posterior.rvar_summary", "mean_sd"), reserved = FALSE, ... ) } \arguments{ \item{x}{(draws) A \code{draws} object or another \R object for which the method is defined.} \item{digits}{(nonnegative integer) The minimum number of significant digits to print.} \item{max_variables}{(positive integer) The maximum number of variables to print. Can be controlled globally via the \code{"posterior.max_variables"} \link[base:options]{option}.} \item{summary}{(string) The style of summary to display: \code{"mean_sd"} displays \verb{mean±sd}, \code{"median_mad"} displays \verb{median±mad}. If \code{NULL}, \code{getOption("posterior.rvar_summary")} is used (default \verb{"mean_sd}).} \item{reserved}{(logical) Should reserved variables be included in the output? Defaults to \code{FALSE}. See \code{\link{reserved_variables}} for an overview of currently reserved variable names.} \item{...}{Further arguments passed to the underlying \code{\link[=print]{print()}} methods.} } \value{ A \code{draws} object of the same class as \code{x}. } \description{ Pretty printing for \code{\link{draws_rvars}} objects. } \examples{ x <- as_draws_rvars(example_draws()) print(x) } posterior/man/draws_of.Rd0000755000175000017500000000466614165314652015326 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/rvar-.R \name{draws_of} \alias{draws_of} \alias{draws_of<-} \title{Get/set array of draws underlying a random variable} \usage{ draws_of(x, with_chains = FALSE) draws_of(x, with_chains = FALSE) <- value } \arguments{ \item{x}{(rvar) An \code{\link{rvar}} object.} \item{with_chains}{(logical) Should the array of draws include a dimension for chains? If \code{FALSE} (the default), chains are not included and the array has dimension \code{c(ndraws(x), dim(x))}. If \code{TRUE}, chains are included and the array has dimension \code{c(niterations(x), nchains(x), dim(x))}.} \item{value}{(array) An array of values to use as the backing array of \code{x}.} } \value{ If \code{with_chains = FALSE}, an array with dimensions \code{c(ndraws(x), dim(x))}. If \code{with_chains = TRUE}, an array with dimensions \code{c(niterations(x), nchains(x), dim(x))}. } \description{ Gets/sets the array-representation that backs an \code{\link{rvar}}. Should be used rarely. } \details{ While \code{\link{rvar}}s implement fast versions of basic math operations (including \link[=rvar-matmult]{matrix multiplication}), sometimes you may need to bypass the \code{\link{rvar}} abstraction to do what you need to do more efficiently. \code{draws_of()} allows you to get / set the underlying array of draws in order to do that. \code{\link{rvar}}s represent draws internally using arrays of arbitrary dimension, which is returned by \code{draws_of(x)} and can be set using \code{draws_of(x) <- value}. The \strong{first} dimension of these arrays is the index of the draws. If \code{with_chains = TRUE}, then the dimensions of the returned array are modified so that the first dimension is the index of the iterations and the second dimension is the index of the chains. } \examples{ x <- rvar(1:10, nchains = 2) x # draws_of() without arguments will return the array of draws without # chain information (first dimension is draw) draws_of(x) # draws_of() with with_chains = TRUE will reshape the returned array to # include chain information in the second dimension draws_of(x, with_chains = TRUE) # you can also set draws using draws_of(). When with_chains = FALSE the # existing chain information will be retained ... draws_of(x) <- 2:11 x # when with_chains = TRUE the chain information will be set by the # second dimension of the assigned array draws_of(x, with_chains = TRUE) <- array(2:11, dim = c(2,5)) x } posterior/man/rvar-summaries-over-draws.Rd0000755000175000017500000001006614165314652020555 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/rvar-summaries-over-draws.R \name{rvar-summaries-over-draws} \alias{rvar-summaries-over-draws} \alias{E} \alias{mean.rvar} \alias{Pr} \alias{Pr.default} \alias{Pr.logical} \alias{Pr.rvar} \alias{median.rvar} \alias{min.rvar} \alias{max.rvar} \alias{sum.rvar} \alias{prod.rvar} \alias{all.rvar} \alias{any.rvar} \alias{Summary.rvar} \alias{variance.rvar} \alias{var} \alias{var.default} \alias{var.rvar} \alias{sd} \alias{sd.default} \alias{sd.rvar} \alias{mad} \alias{mad.default} \alias{mad.rvar} \alias{range.rvar} \alias{is.finite.rvar} \alias{is.infinite.rvar} \alias{is.nan.rvar} \alias{is.na.rvar} \title{Summaries of random variables within array elements, over draws} \usage{ E(x, ...) \method{mean}{rvar}(x, ...) Pr(x, ...) \method{Pr}{default}(x, ...) \method{Pr}{logical}(x, ...) \method{Pr}{rvar}(x, ...) \method{median}{rvar}(x, ...) \method{min}{rvar}(x, ...) \method{max}{rvar}(x, ...) \method{sum}{rvar}(x, ...) \method{prod}{rvar}(x, ...) \method{all}{rvar}(x, ...) \method{any}{rvar}(x, ...) \method{Summary}{rvar}(...) \method{variance}{rvar}(x, ...) var(x, ...) \method{var}{default}(x, ...) \method{var}{rvar}(x, ...) sd(x, ...) \method{sd}{default}(x, ...) \method{sd}{rvar}(x, ...) mad(x, ...) \method{mad}{default}(x, ...) \method{mad}{rvar}(x, ...) \method{range}{rvar}(x, ...) \method{is.finite}{rvar}(x) \method{is.infinite}{rvar}(x) \method{is.nan}{rvar}(x) \method{is.na}{rvar}(x) } \arguments{ \item{x}{(rvar) An \code{\link{rvar}}.} \item{...}{Further arguments passed to underlying functions (e.g., \code{base::mean()} or \code{base::median()}), such as \code{na.rm}.} } \value{ A numeric or logical vector with the same dimensions as the given random variable, where each entry in the vector is the mean, median, or variance of the corresponding entry in \code{x}. } \description{ Compute summaries within elements of an \code{\link{rvar}} and over draws of each element, producing an array of the same shape as the input random variable (except in the case of \code{range()}, see \strong{Details}). } \details{ Summaries include expectations (\code{E()} or \code{mean()}), probabilities (\code{Pr()}), medians (\code{median()}), spread (\code{var()}, \code{variance()}, \code{sd()}, \code{mad()}), sums and products (\code{sum()}, \code{prod()}), extrema and ranges (\code{min()}, \code{max()}, \code{range()}), logical summaries (\code{all()}, \code{any()}), and special value predicates (\code{is.finite()}, \code{is.infinite()}, \code{is.nan()}, \code{is.na()}). Unless otherwise stated, these functions return a numeric array with the same shape (same dimensions) as the input \code{\link{rvar}}, \code{x}. \code{range(x)} returns an array with dimensions \code{c(2, dim(x))}, where the last dimension contains the minimum and maximum values. \code{is.infinite(x)}, \code{is.nan(x)}, and \code{is.na(x)} return logical arrays, where each element is \code{TRUE} if \strong{any} draws in its corresponding element in \code{x} match the predicate. Each elements in the result of \code{is.finite(x)} is \code{TRUE} if \strong{all} draws in the corresponding element in \code{x} are finite. Both \code{E()}, \code{mean()}, and \code{Pr()} return the means of each element in the input. \code{Pr()} additionally checks that the provided \code{\link{rvar}} is a logical variable (hence, taking its expectation results in a probability). For consistency, \code{E()} and \code{Pr()} are also defined for base arrays so that they can be used as summary functions in \code{summarise_draws()}. } \examples{ set.seed(5678) x = rvar_rng(rnorm, 4, mean = 1:4, sd = 2) # These should all be ~= c(1, 2, 3, 4) E(x) mean(x) median(x) # This ... Pr(x < 1.5) # ... should be about the same as this: pnorm(1.5, mean = 1:4, sd = 2) } \seealso{ \link{rvar-summaries-within-draws} for summary functions within draws. \link{rvar-dist} for density, CDF, and quantile functions of random variables. Other rvar-summaries: \code{\link{rvar-summaries-within-draws}}, \code{\link{rvar_is_finite}()} } \concept{rvar-summaries} posterior/man/rvar-summaries-within-draws.Rd0000755000175000017500000000557714165314652021117 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/rvar-summaries-within-draws.R \name{rvar-summaries-within-draws} \alias{rvar-summaries-within-draws} \alias{rvar_mean} \alias{rvar_median} \alias{rvar_sum} \alias{rvar_prod} \alias{rvar_min} \alias{rvar_max} \alias{rvar_sd} \alias{rvar_var} \alias{rvar_mad} \alias{rvar_range} \alias{rvar_quantile} \alias{rvar_all} \alias{rvar_any} \title{Summaries of random variables over array elements, within draws} \usage{ rvar_mean(..., na.rm = FALSE) rvar_median(..., na.rm = FALSE) rvar_sum(..., na.rm = FALSE) rvar_prod(..., na.rm = FALSE) rvar_min(..., na.rm = FALSE) rvar_max(..., na.rm = FALSE) rvar_sd(..., na.rm = FALSE) rvar_var(..., na.rm = FALSE) rvar_mad(..., constant = 1.4826, na.rm = FALSE) rvar_range(..., na.rm = FALSE) rvar_quantile(..., probs, names = FALSE, na.rm = FALSE) rvar_all(..., na.rm = FALSE) rvar_any(..., na.rm = FALSE) } \arguments{ \item{...}{(rvar) One or more \code{\link{rvar}}s.} \item{na.rm}{(logical) Should \code{NA}s be removed from the input before summaries are computed? The default is \code{FALSE}.} \item{constant}{(scalar real) For \code{rvar_mad()}, a scale factor for computing the median absolute deviation. See the details of \code{stats::mad()} for the justification for the default value.} \item{probs}{(numeric vector) For \code{rvar_quantile()}, probabilities in \verb{[0, 1]}.} \item{names}{(logical) For \code{rvar_quantile()}, if \code{TRUE}, the result has a \code{names} attribute.} } \value{ An \code{\link{rvar}} of length 1 (for \code{range()}, length 2; for \code{quantile()}, length equal to \code{length(probs)}) with the same number of draws as the input rvar(s) containing the summary statistic computed within each draw of the input rvar(s). } \description{ Compute summaries of random variables over array elements and within draws, producing a new random variable of length 1 (except in the case of \code{rvar_range()}, see \strong{Details}). } \details{ These functions compute statistics within each draw of the random variable. For summaries over draws (such as expectations), see \link{rvar-summaries-over-draws}. Each function defined here corresponds to the base function of the same name without the \code{rvar_} prefix (e.g., \code{rvar_mean()} calls \code{mean()} under the hood, etc). } \examples{ set.seed(5678) x = rvar_rng(rnorm, 4, mean = 1:4, sd = 2) # These will give similar results to mean(1:4), # median(1:4), sum(1:4), prod(1:4), etc rvar_mean(x) rvar_median(x) rvar_sum(x) rvar_prod(x) rvar_range(x) rvar_quantile(x, probs = c(0.25, 0.5, 0.75), names = TRUE) } \seealso{ \link{rvar-summaries-over-draws} for summary functions across draws (e.g. expectations). \link{rvar-dist} for density, CDF, and quantile functions of random variables. Other rvar-summaries: \code{\link{rvar-summaries-over-draws}}, \code{\link{rvar_is_finite}()} } \concept{rvar-summaries} posterior/man/ess_sd.Rd0000755000175000017500000000502514165316131014762 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/convergence.R \name{ess_sd} \alias{ess_sd} \alias{ess_sd.default} \alias{ess_sd.rvar} \title{Effective sample size for the standard deviation} \usage{ ess_sd(x, ...) \method{ess_sd}{default}(x, ...) \method{ess_sd}{rvar}(x, ...) } \arguments{ \item{x}{(multiple options) One of: \itemize{ \item A matrix of draws for a single variable (iterations x chains). See \code{\link[=extract_variable_matrix]{extract_variable_matrix()}}. \item An \code{\link{rvar}}. }} \item{...}{Arguments passed to individual methods (if applicable).} } \value{ If the input is an array, returns a single numeric value. If any of the draws is non-finite, that is, \code{NA}, \code{NaN}, \code{Inf}, or \code{-Inf}, the returned output will be (numeric) \code{NA}. Also, if all draws within any of the chains of a variable are the same (constant), the returned output will be (numeric) \code{NA} as well. The reason for the latter is that, for constant draws, we cannot distinguish between variables that are supposed to be constant (e.g., a diagonal element of a correlation matrix is always 1) or variables that just happened to be constant because of a failure of convergence or other problems in the sampling process. If the input is an \code{\link{rvar}}, returns an array of the same dimensions as the \code{\link{rvar}}, where each element is equal to the value that would be returned by passing the draws array for that element of the \code{\link{rvar}} to this function. } \description{ Compute an effective sample size estimate for the standard deviation (SD) estimate of a single variable. This is defined as minimum of the effective sample size estimate for the mean and the the effective sample size estimate for the mean of the squared value. } \examples{ mu <- extract_variable_matrix(example_draws(), "mu") ess_sd(mu) d <- as_draws_rvars(example_draws("multi_normal")) ess_sd(d$Sigma) } \references{ Aki Vehtari, Andrew Gelman, Daniel Simpson, Bob Carpenter, and Paul-Christian Bürkner (2021). Rank-normalization, folding, and localization: An improved R-hat for assessing convergence of MCMC (with discussion). \emph{Bayesian Data Analysis}. 16(2), 667-–718. doi:10.1214/20-BA1221 } \seealso{ Other diagnostics: \code{\link{ess_basic}()}, \code{\link{ess_bulk}()}, \code{\link{ess_quantile}()}, \code{\link{ess_tail}()}, \code{\link{mcse_mean}()}, \code{\link{mcse_quantile}()}, \code{\link{mcse_sd}()}, \code{\link{rhat_basic}()}, \code{\link{rhat}()}, \code{\link{rstar}()} } \concept{diagnostics} posterior/man/mcse_sd.Rd0000755000175000017500000000467414165316131015130 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/convergence.R \name{mcse_sd} \alias{mcse_sd} \alias{mcse_sd.default} \alias{mcse_sd.rvar} \title{Monte Carlo standard error for the standard deviation} \usage{ mcse_sd(x, ...) \method{mcse_sd}{default}(x, ...) \method{mcse_sd}{rvar}(x, ...) } \arguments{ \item{x}{(multiple options) One of: \itemize{ \item A matrix of draws for a single variable (iterations x chains). See \code{\link[=extract_variable_matrix]{extract_variable_matrix()}}. \item An \code{\link{rvar}}. }} \item{...}{Arguments passed to individual methods (if applicable).} } \value{ If the input is an array, returns a single numeric value. If any of the draws is non-finite, that is, \code{NA}, \code{NaN}, \code{Inf}, or \code{-Inf}, the returned output will be (numeric) \code{NA}. Also, if all draws within any of the chains of a variable are the same (constant), the returned output will be (numeric) \code{NA} as well. The reason for the latter is that, for constant draws, we cannot distinguish between variables that are supposed to be constant (e.g., a diagonal element of a correlation matrix is always 1) or variables that just happened to be constant because of a failure of convergence or other problems in the sampling process. If the input is an \code{\link{rvar}}, returns an array of the same dimensions as the \code{\link{rvar}}, where each element is equal to the value that would be returned by passing the draws array for that element of the \code{\link{rvar}} to this function. } \description{ Compute the Monte Carlo standard error for the standard deviation (SD) of a single variable using Stirling's approximation and assuming approximate normality. } \examples{ mu <- extract_variable_matrix(example_draws(), "mu") mcse_sd(mu) d <- as_draws_rvars(example_draws("multi_normal")) mcse_sd(d$Sigma) } \references{ Aki Vehtari, Andrew Gelman, Daniel Simpson, Bob Carpenter, and Paul-Christian Bürkner (2021). Rank-normalization, folding, and localization: An improved R-hat for assessing convergence of MCMC (with discussion). \emph{Bayesian Data Analysis}. 16(2), 667-–718. doi:10.1214/20-BA1221 } \seealso{ Other diagnostics: \code{\link{ess_basic}()}, \code{\link{ess_bulk}()}, \code{\link{ess_quantile}()}, \code{\link{ess_sd}()}, \code{\link{ess_tail}()}, \code{\link{mcse_mean}()}, \code{\link{mcse_quantile}()}, \code{\link{rhat_basic}()}, \code{\link{rhat}()}, \code{\link{rstar}()} } \concept{diagnostics} posterior/man/print.rvar.Rd0000755000175000017500000000530714165314652015620 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/rvar-print.R \encoding{UTF-8} \name{print.rvar} \alias{print.rvar} \alias{format.rvar} \alias{str.rvar} \title{Print or format a random variable} \usage{ \method{print}{rvar}(x, ..., summary = NULL, digits = 2, color = TRUE) \method{format}{rvar}(x, ..., summary = NULL, digits = 2, color = FALSE) \method{str}{rvar}( object, ..., summary = NULL, vec.len = NULL, indent.str = paste(rep.int(" ", max(0, nest.lev + 1)), collapse = ".."), nest.lev = 0, give.attr = TRUE ) } \arguments{ \item{x, object}{(rvar) The \code{\link{rvar}} to print.} \item{...}{Further arguments passed to the underlying \code{\link[=print]{print()}} methods.} \item{summary}{(string) The style of summary to display: \code{"mean_sd"} displays \verb{mean±sd}, \code{"median_mad"} displays \verb{median±mad}. If \code{NULL}, \code{getOption("posterior.rvar_summary")} is used (default \verb{"mean_sd}).} \item{digits}{(nonnegative integer) The minimum number of significant digits to print.} \item{color}{(logical) Whether or not to use color when formatting the output. If \code{TRUE}, the \code{\link[pillar:style_subtle]{pillar::style_num()}} functions may be used to produce strings containing control sequences to produce colored output on the terminal.} \item{vec.len}{(nonnegative integer) How many 'first few' elements are displayed of each vector. If \code{NULL}, defaults to \code{getOption("str")$vec.len}, which defaults to 4.} \item{indent.str}{(string) The indentation string to use.} \item{nest.lev}{(nonnegative integer) Current nesting level in the recursive calls to \code{str()}.} \item{give.attr}{(logical) If \code{TRUE} (default), show attributes as sub structures.} } \value{ For \code{print()}, an invisible version of the input object. For \code{str()}, nothing; i.e. \code{invisible(NULL)}. For \code{format()}, a character vector of the same dimensions as \code{x} where each entry is of the form \code{"mean±sd"} or \code{"median±mad"}, depending on the value of \code{summary}. } \description{ Printing and formatting methods for \code{\link{rvar}}s. } \details{ \code{print()} and \code{str()} print out \code{\link{rvar}} objects by summarizing each element in the random variable with either its mean±sd or median±mad, depending on the value of \code{summary}. Both functions use the \code{format()} implementation for \code{\link{rvar}} objects under the hood, which returns a character vector in the mean±sd or median±mad form. } \examples{ set.seed(5678) x = rbind( cbind(rvar(rnorm(1000, 1)), rvar(rnorm(1000, 2))), cbind(rvar(rnorm(1000, 3)), rvar(rnorm(1000, 4))) ) print(x) print(x, summary = "median_mad") str(x) format(x) } posterior/man/repair_draws.Rd0000644000175000017500000000261414165314652016170 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/repair_draws.R \name{repair_draws} \alias{repair_draws} \alias{repair_draws.draws_matrix} \alias{repair_draws.draws_array} \alias{repair_draws.draws_df} \alias{repair_draws.draws_list} \alias{repair_draws.draws_rvars} \alias{repair_draws.rvar} \title{Repair indices of \code{draws} objects} \usage{ repair_draws(x, order = TRUE, ...) \method{repair_draws}{draws_matrix}(x, order = TRUE, ...) \method{repair_draws}{draws_array}(x, order = TRUE, ...) \method{repair_draws}{draws_df}(x, order = TRUE, ...) \method{repair_draws}{draws_list}(x, order = TRUE, ...) \method{repair_draws}{draws_rvars}(x, order = TRUE, ...) \method{repair_draws}{rvar}(x, order = TRUE, ...) } \arguments{ \item{x}{(draws) A \code{draws} object or another \R object for which the method is defined.} \item{order}{(logical) Should draws be ordered (via \code{\link[=order_draws]{order_draws()}}) before repairing indices? Defaults to \code{TRUE}.} \item{...}{Arguments passed to individual methods (if applicable).} } \value{ A \code{draws} object of the same class as \code{x}. } \description{ Repair indices of \code{draws} objects so that iterations, chains, and draws are continuously and consistently numbered. } \examples{ x <- as_draws_array(example_draws()) (x <- x[10:5, 3:4, ]) repair_draws(x) } \seealso{ \code{\link[=order_draws]{order_draws()}} } posterior/man/subset_draws.Rd0000644000175000017500000000554714165314652016223 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/subset_draws.R \name{subset_draws} \alias{subset_draws} \alias{subset_draws.draws_matrix} \alias{subset_draws.draws_array} \alias{subset_draws.draws_df} \alias{subset_draws.draws_list} \alias{subset_draws.draws_rvars} \alias{subset.draws} \title{Subset \code{draws} objects} \usage{ subset_draws(x, ...) \method{subset_draws}{draws_matrix}( x, variable = NULL, iteration = NULL, chain = NULL, draw = NULL, regex = FALSE, unique = TRUE, ... ) \method{subset_draws}{draws_array}( x, variable = NULL, iteration = NULL, chain = NULL, draw = NULL, regex = FALSE, unique = TRUE, ... ) \method{subset_draws}{draws_df}( x, variable = NULL, iteration = NULL, chain = NULL, draw = NULL, regex = FALSE, unique = TRUE, ... ) \method{subset_draws}{draws_list}( x, variable = NULL, iteration = NULL, chain = NULL, draw = NULL, regex = FALSE, unique = TRUE, ... ) \method{subset_draws}{draws_rvars}( x, variable = NULL, iteration = NULL, chain = NULL, draw = NULL, regex = FALSE, unique = TRUE, ... ) \method{subset}{draws}(x, ...) } \arguments{ \item{x}{(draws) A \code{draws} object or another \R object for which the method is defined.} \item{...}{Arguments passed to individual methods (if applicable).} \item{variable}{(character vector) The variables to select. All elements of non-scalar variables can be selected at once.} \item{iteration}{(integer vector) The iteration indices to select.} \item{chain}{(integer vector) The chain indices to select.} \item{draw}{(integer vector) The draw indices to be select. Subsetting draw indices will lead to an automatic merging of chains via \code{\link{merge_chains}}.} \item{regex}{(logical) Should \code{variable} should be treated as a (vector of) regular expressions? Any variable in \code{x} matching at least one of the regular expressions will be selected. Defaults to \code{FALSE}.} \item{unique}{(logical) Should duplicated selection of chains, iterations, or draws be allowed? If \code{TRUE} (the default) only unique chains, iterations, and draws are selected regardless of how often they appear in the respective selecting arguments.} } \value{ A \code{draws} object of the same class as \code{x}. } \description{ Subset \code{\link{draws}} objects by variables, iterations, chains, and draws indices. } \details{ To ensure that multiple consecutive subsetting operations work correctly, \code{subset()} \emph{\link[=repair_draws]{repairs}} the \code{draws} object before and after subsetting. } \examples{ x <- example_draws() subset_draws(x, variable = c("mu", "tau")) subset_draws(x, chain = 2) subset_draws(x, iteration = 5:10, chain = 3:4) # extract the first chain twice subset_draws(x, chain = c(1, 1), unique = FALSE) # extract all elements of 'theta' subset_draws(x, variable = "theta") } posterior/man/ess_basic.Rd0000755000175000017500000000623414165317763015454 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/convergence.R \name{ess_basic} \alias{ess_basic} \alias{ess_basic.default} \alias{ess_basic.rvar} \title{Basic version of the effective sample size} \usage{ ess_basic(x, ...) \method{ess_basic}{default}(x, split = TRUE, ...) \method{ess_basic}{rvar}(x, split = TRUE, ...) } \arguments{ \item{x}{(multiple options) One of: \itemize{ \item A matrix of draws for a single variable (iterations x chains). See \code{\link[=extract_variable_matrix]{extract_variable_matrix()}}. \item An \code{\link{rvar}}. }} \item{...}{Arguments passed to individual methods (if applicable).} \item{split}{(logical) Should the estimate be computed on split chains? The default is \code{TRUE}.} } \value{ If the input is an array, returns a single numeric value. If any of the draws is non-finite, that is, \code{NA}, \code{NaN}, \code{Inf}, or \code{-Inf}, the returned output will be (numeric) \code{NA}. Also, if all draws within any of the chains of a variable are the same (constant), the returned output will be (numeric) \code{NA} as well. The reason for the latter is that, for constant draws, we cannot distinguish between variables that are supposed to be constant (e.g., a diagonal element of a correlation matrix is always 1) or variables that just happened to be constant because of a failure of convergence or other problems in the sampling process. If the input is an \code{\link{rvar}}, returns an array of the same dimensions as the \code{\link{rvar}}, where each element is equal to the value that would be returned by passing the draws array for that element of the \code{\link{rvar}} to this function. } \description{ Compute the basic effective sample size (ESS) estimate for a single variable as described in Gelman et al. (2013) with some changes according to Vehtari et al. (2021). For practical applications, we strongly recommend the improved ESS convergence diagnostics implemented in \code{\link[=ess_bulk]{ess_bulk()}} and \code{\link[=ess_tail]{ess_tail()}}. See Vehtari (2021) for an in-depth comparison of different effective sample size estimators. } \examples{ mu <- extract_variable_matrix(example_draws(), "mu") ess_basic(mu) d <- as_draws_rvars(example_draws("multi_normal")) ess_basic(d$Sigma) } \references{ Andrew Gelman, John B. Carlin, Hal S. Stern, David B. Dunson, Aki Vehtari and Donald B. Rubin (2013). \emph{Bayesian Data Analysis, Third Edition}. Chapman and Hall/CRC. Aki Vehtari, Andrew Gelman, Daniel Simpson, Bob Carpenter, and Paul-Christian Bürkner (2021). Rank-normalization, folding, and localization: An improved R-hat for assessing convergence of MCMC (with discussion). \emph{Bayesian Data Analysis}. 16(2), 667-–718. doi:10.1214/20-BA1221 Aki Vehtari (2021). Comparison of MCMC effective sample size estimators. Retrieved from https://avehtari.github.io/rhat_ess/ess_comparison.html } \seealso{ Other diagnostics: \code{\link{ess_bulk}()}, \code{\link{ess_quantile}()}, \code{\link{ess_sd}()}, \code{\link{ess_tail}()}, \code{\link{mcse_mean}()}, \code{\link{mcse_quantile}()}, \code{\link{mcse_sd}()}, \code{\link{rhat_basic}()}, \code{\link{rhat}()}, \code{\link{rstar}()} } \concept{diagnostics} posterior/man/draws_rvars.Rd0000755000175000017500000000414314165314652016045 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/as_draws_rvars.R \name{draws_rvars} \alias{draws_rvars} \alias{as_draws_rvars} \alias{as_draws_rvars.default} \alias{as_draws_rvars.draws_rvars} \alias{as_draws_rvars.list} \alias{as_draws_rvars.draws_matrix} \alias{as_draws_rvars.draws_array} \alias{as_draws_rvars.draws_df} \alias{as_draws_rvars.draws_list} \alias{as_draws_rvars.mcmc} \alias{as_draws_rvars.mcmc.list} \alias{is_draws_rvars} \title{The \code{draws_rvars} format} \usage{ as_draws_rvars(x, ...) \method{as_draws_rvars}{default}(x, ...) \method{as_draws_rvars}{draws_rvars}(x, ...) \method{as_draws_rvars}{list}(x, ...) \method{as_draws_rvars}{draws_matrix}(x, ...) \method{as_draws_rvars}{draws_array}(x, ...) \method{as_draws_rvars}{draws_df}(x, ...) \method{as_draws_rvars}{draws_list}(x, ...) \method{as_draws_rvars}{mcmc}(x, ...) \method{as_draws_rvars}{mcmc.list}(x, ...) draws_rvars(..., .nchains = 1) is_draws_rvars(x) } \arguments{ \item{x}{An object to convert to a \code{draws_rvars} object.} \item{...}{For \code{as_draws_rvars()}: Arguments passed to individual methods (if applicable). For \code{draws_rvars()}: Named arguments containing numeric vectors each defining a separate variable.} \item{.nchains}{(positive integer) The number of chains. The default is \code{1}.} } \value{ A \code{draws_rvars} object, which has classes \code{c("draws_rvars", "draws", "list")}. } \description{ The \code{as_draws_rvars()} methods convert objects to the \code{draws_rvars} format. The \code{draws_rvars()} function creates an object of the \code{draws_rvars} format based on a set of numeric vectors. See \strong{Details}. } \details{ Objects of class \code{"draws_rvars"} are lists of \code{\link{rvar}} objects. See \strong{Examples}. } \examples{ x1 <- as_draws_rvars(example_draws()) class(x1) print(x1) str(x1) x2 <- draws_rvars(a = rnorm(10), b = rnorm(10), c = 1) class(x2) print(x2) str(x2) } \seealso{ Other formats: \code{\link{draws_array}()}, \code{\link{draws_df}()}, \code{\link{draws_list}()}, \code{\link{draws_matrix}()}, \code{\link{draws}} } \concept{formats} posterior/man/ess_tail.Rd0000755000175000017500000000552414165316332015314 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/convergence.R \name{ess_tail} \alias{ess_tail} \alias{ess_tail.default} \alias{ess_tail.rvar} \title{Tail effective sample size (tail-ESS)} \usage{ ess_tail(x, ...) \method{ess_tail}{default}(x, ...) \method{ess_tail}{rvar}(x, ...) } \arguments{ \item{x}{(multiple options) One of: \itemize{ \item A matrix of draws for a single variable (iterations x chains). See \code{\link[=extract_variable_matrix]{extract_variable_matrix()}}. \item An \code{\link{rvar}}. }} \item{...}{Arguments passed to individual methods (if applicable).} } \value{ If the input is an array, returns a single numeric value. If any of the draws is non-finite, that is, \code{NA}, \code{NaN}, \code{Inf}, or \code{-Inf}, the returned output will be (numeric) \code{NA}. Also, if all draws within any of the chains of a variable are the same (constant), the returned output will be (numeric) \code{NA} as well. The reason for the latter is that, for constant draws, we cannot distinguish between variables that are supposed to be constant (e.g., a diagonal element of a correlation matrix is always 1) or variables that just happened to be constant because of a failure of convergence or other problems in the sampling process. If the input is an \code{\link{rvar}}, returns an array of the same dimensions as the \code{\link{rvar}}, where each element is equal to the value that would be returned by passing the draws array for that element of the \code{\link{rvar}} to this function. } \description{ Compute a tail effective sample size estimate (tail-ESS) for a single variable. Tail-ESS is useful as a diagnostic for the sampling efficiency in the tails of the posterior. It is defined as the minimum of the effective sample sizes for 5\% and 95\% quantiles. For the bulk effective sample size see \code{\link[=ess_bulk]{ess_bulk()}}. See Vehtari (2021) for an in-depth comparison of different effective sample size estimators. } \examples{ mu <- extract_variable_matrix(example_draws(), "mu") ess_tail(mu) d <- as_draws_rvars(example_draws("multi_normal")) ess_tail(d$Sigma) } \references{ Aki Vehtari, Andrew Gelman, Daniel Simpson, Bob Carpenter, and Paul-Christian Bürkner (2021). Rank-normalization, folding, and localization: An improved R-hat for assessing convergence of MCMC (with discussion). \emph{Bayesian Data Analysis}. 16(2), 667-–718. doi:10.1214/20-BA1221 Aki Vehtari (2021). Comparison of MCMC effective sample size estimators. Retrieved from https://avehtari.github.io/rhat_ess/ess_comparison.html } \seealso{ Other diagnostics: \code{\link{ess_basic}()}, \code{\link{ess_bulk}()}, \code{\link{ess_quantile}()}, \code{\link{ess_sd}()}, \code{\link{mcse_mean}()}, \code{\link{mcse_quantile}()}, \code{\link{mcse_sd}()}, \code{\link{rhat_basic}()}, \code{\link{rhat}()}, \code{\link{rstar}()} } \concept{diagnostics} posterior/man/merge_chains.Rd0000644000175000017500000000261514165314652016133 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/merge_chains.R \name{merge_chains} \alias{merge_chains} \alias{merge_chains.draws_matrix} \alias{merge_chains.draws_array} \alias{merge_chains.draws_df} \alias{merge_chains.draws_list} \alias{merge_chains.rvar} \alias{merge_chains.draws_rvars} \title{Merge chains of \code{draws} objects} \usage{ merge_chains(x, ...) \method{merge_chains}{draws_matrix}(x, ...) \method{merge_chains}{draws_array}(x, ...) \method{merge_chains}{draws_df}(x, ...) \method{merge_chains}{draws_list}(x, ...) \method{merge_chains}{rvar}(x, ...) \method{merge_chains}{draws_rvars}(x, ...) } \arguments{ \item{x}{(draws) A \code{draws} object or another \R object for which the method is defined.} \item{...}{Arguments passed to individual methods (if applicable).} } \value{ A \code{draws} object of the same class as \code{x}. } \description{ Merge chains of \code{\link{draws}} objects into a single chain. Some operations will trigger an automatic merging of chains, for example, because chains do not match between two objects involved in a binary operation. By default, no warning will be issued when this happens but you can activate one via \code{options(posterior.warn_on_merge_chains = TRUE)}. } \examples{ x <- example_draws() # draws_array with 4 chains, 100 iters each str(x) # draws_array with 1 chain of 400 iterations str(merge_chains(x)) } posterior/man/mcse_quantile.Rd0000755000175000017500000000600714165316131016334 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/convergence.R \name{mcse_quantile} \alias{mcse_quantile} \alias{mcse_quantile.default} \alias{mcse_quantile.rvar} \alias{mcse_median} \title{Monte Carlo standard error for quantiles} \usage{ mcse_quantile(x, probs = c(0.05, 0.95), ...) \method{mcse_quantile}{default}(x, probs = c(0.05, 0.95), names = TRUE, ...) \method{mcse_quantile}{rvar}(x, probs = c(0.05, 0.95), names = TRUE, ...) mcse_median(x, ...) } \arguments{ \item{x}{(multiple options) One of: \itemize{ \item A matrix of draws for a single variable (iterations x chains). See \code{\link[=extract_variable_matrix]{extract_variable_matrix()}}. \item An \code{\link{rvar}}. }} \item{probs}{(numeric vector) Probabilities in \verb{[0, 1]}.} \item{...}{Arguments passed to individual methods (if applicable).} \item{names}{(logical) Should the result have a \code{names} attribute? The default is \code{TRUE}, but use \code{FALSE} for improved speed if there are many values in \code{probs}.} } \value{ If the input is an array, returns a numeric vector with one element per quantile. If any of the draws is non-finite, that is, \code{NA}, \code{NaN}, \code{Inf}, or \code{-Inf}, the returned output will be a vector of (numeric) \code{NA} values. Also, if all draws of a variable are the same (constant), the returned output will be a vector of (numeric) \code{NA} values as well. The reason for the latter is that, for constant draws, we cannot distinguish between variables that are supposed to be constant (e.g., a diagonal element of a correlation matrix is always 1) or variables that just happened to be constant because of a failure of convergence or other problems in the sampling process. If the input is an \code{\link{rvar}} and \code{length(probs) == 1}, returns an array of the same dimensions as the \code{\link{rvar}}, where each element is equal to the value that would be returned by passing the draws array for that element of the \code{\link{rvar}} to this function. If \code{length(probs) > 1}, the first dimension of the result indexes the input probabilities; i.e. the result has dimension \code{c(length(probs), dim(x))}. } \description{ Compute Monte Carlo standard errors for quantile estimates of a single variable. } \examples{ mu <- extract_variable_matrix(example_draws(), "mu") mcse_quantile(mu, probs = c(0.1, 0.9)) d <- as_draws_rvars(example_draws("multi_normal")) mcse_quantile(d$mu) } \references{ Aki Vehtari, Andrew Gelman, Daniel Simpson, Bob Carpenter, and Paul-Christian Bürkner (2021). Rank-normalization, folding, and localization: An improved R-hat for assessing convergence of MCMC (with discussion). \emph{Bayesian Data Analysis}. 16(2), 667-–718. doi:10.1214/20-BA1221 } \seealso{ Other diagnostics: \code{\link{ess_basic}()}, \code{\link{ess_bulk}()}, \code{\link{ess_quantile}()}, \code{\link{ess_sd}()}, \code{\link{ess_tail}()}, \code{\link{mcse_mean}()}, \code{\link{mcse_sd}()}, \code{\link{rhat_basic}()}, \code{\link{rhat}()}, \code{\link{rstar}()} } \concept{diagnostics} posterior/man/rvar.Rd0000755000175000017500000001214214165314652014460 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/rvar-.R \name{rvar} \alias{rvar} \title{Random variables of arbitrary dimension} \usage{ rvar( x = double(), dim = NULL, dimnames = NULL, nchains = 1L, with_chains = FALSE ) } \arguments{ \item{x}{(multiple options) The object to convert to an \code{rvar}: \itemize{ \item A vector of draws from a distribution. \item An array where the first dimension represents draws from a distribution. The resulting \code{\link{rvar}} will have dimension \code{dim(x)[-1]}; that is, everything except the first dimension is used for the shape of the variable, and the first dimension is used to index draws from the distribution (see \strong{Examples}). Optionally, if \code{with_chains == TRUE}, the first dimension indexes the iteration and the second dimension indexes the chain (see \code{with_chains}). }} \item{dim}{(integer vector) One or more integers giving the maximal indices in each dimension to override the dimensions of the \code{\link{rvar}} to be created (see \code{\link[=dim]{dim()}}). If \code{NULL} (the default), \code{dim} is determined by the input. \strong{NOTE:} This argument controls the dimensions of the \code{\link{rvar}}, not the underlying array, so you cannot change the number of draws using this argument.} \item{dimnames}{(list) Character vectors giving the names in each dimension to override the names of the dimensions of the \code{\link{rvar}} to be created (see \code{\link[=dimnames]{dimnames()}}). If \code{NULL} (the default), this is determined by the input. \strong{NOTE:} This argument controls the names of the dimensions of the \code{\link{rvar}}, not the underlying array.} \item{nchains}{(positive integer) The number of chains. The default is \code{1}.} \item{with_chains}{(logical) Does \code{x} include a dimension for chains? If \code{FALSE} (the default), chains are not included, the first dimension of the input array should index draws, and the \code{nchains} argument can be used to determine the number of chains. If \code{TRUE}, the \code{nchains} argument is ignored and the second dimension of \code{x} is used to index chains. Internally, the array will be converted to a format without the chain index.} } \value{ An object of class \code{"rvar"} representing a random variable. } \description{ Random variables backed by arrays of arbitrary dimension } \details{ The \code{"rvar"} class internally represents random variables as arrays of arbitrary dimension, where the first dimension is used to index draws from the distribution. Most mathematical operators and functions are supported, including efficient matrix multiplication and vector and array-style indexing. The intent is that an \code{rvar} works as closely as possible to how a base vector/matrix/array does, with a few differences: \itemize{ \item The default behavior when subsetting is not to drop extra dimensions (i.e. the default \code{drop} argument for \code{[} is \code{FALSE}, not \code{TRUE}). \item Rather than base R-style recycling, \code{rvar}s use a limited form of broadcasting: if an operation is being performed on two vectors with different size of the same dimension, the smaller vector will be recycled up to the size of the larger one along that dimension so long as it has size 1. } For functions that expect base numeric arrays and for which \code{rvar}s cannot be used directly as arguments, you can use \code{\link[=rfun]{rfun()}} or \code{\link[=rdo]{rdo()}} to translate your code into code that executes across draws from one or more random variables and returns a random variable as output. Typically \code{\link[=rdo]{rdo()}} offers the most straightforward translation. As \code{\link[=rfun]{rfun()}} and \code{\link[=rdo]{rdo()}} incur some performance cost, you can also operate directly on the underlying array using the \code{\link[=draws_of]{draws_of()}} function. To re-use existing random number generator functions to efficiently create \code{rvar}s, use \code{\link[=rvar_rng]{rvar_rng()}}. } \examples{ set.seed(1234) # To create a "scalar" `rvar`, pass a one-dimensional array or a vector # whose length (here `4000`) is the desired number of draws: x <- rvar(rnorm(4000, mean = 1, sd = 1)) x # Create random vectors by adding an additional dimension: n <- 4 # length of output vector x <- rvar(array(rnorm(4000 * n, mean = rep(1:n, each = 4000), sd = 1), dim = c(4000, n))) x # Create a random matrix: rows <- 4 cols <- 3 x <- rvar(array(rnorm(4000 * rows * cols, mean = 1, sd = 1), dim = c(4000, rows, cols))) x # If the input sample comes from multiple chains, we can indicate that using the # nchains argument (here, 1000 draws each from 4 chains): x <- rvar(rnorm(4000, mean = 1, sd = 1), nchains = 4) x # Or if the input sample has chain information as its second dimension, we can # use with_chains to create the rvar x <- rvar(array(rnorm(4000, mean = 1, sd = 1), dim = c(1000, 4)), with_chains = TRUE) x } \seealso{ \code{\link[=as_rvar]{as_rvar()}} to convert objects to \code{rvar}s. See \code{\link[=rdo]{rdo()}}, \code{\link[=rfun]{rfun()}}, and \code{\link[=rvar_rng]{rvar_rng()}} for higher-level interfaces for creating \code{rvar}s. } posterior/man/rstar.Rd0000644000175000017500000001126714165314652014645 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/rstar.R \name{rstar} \alias{rstar} \title{Calculate R* convergence diagnostic} \usage{ rstar( x, split = TRUE, uncertainty = FALSE, method = "rf", hyperparameters = NULL, training_proportion = 0.7, nsimulations = 1000, ... ) } \arguments{ \item{x}{(draws) A \code{\link{draws_df}} object or one coercible to a \code{draws_df} object.} \item{split}{(logical) Should the estimate be computed on split chains? The default is \code{TRUE}.} \item{uncertainty}{(logical). Indicates whether to provide a vector of R* values representing uncertainty in the calculated value (if \code{TRUE}) or a single value (if \code{FALSE}). The default is \code{TRUE.}} \item{method}{(string) The machine learning classifier to use (must be available in the \pkg{caret} package). The default is \code{"rf"}, which calls the random forest classifier.} \item{hyperparameters}{(named list) Hyperparameter settings passed to the classifier. The default for the random forest classifier (\code{method = "rf"}) is \code{list(mtry = floor(sqt(nvariables(x))))}. The default for the gradient-based model (\code{method = "gbm"}) is \code{list(interaction.depth = 3, n.trees = 50, shrinkage = 0.1, n.minobsinnode = 10)}.} \item{training_proportion}{(positive real) The proportion (in \verb{(0,1)}) of iterations in used to train the classifier. The default is \code{0.7}.} \item{nsimulations}{(positive integer) The number of R* values in the returned vector if \code{uncertainty} is \code{TRUE}. The default is \code{1000.}} \item{...}{Other arguments passed to \code{caret::train()}.} } \value{ A numeric vector of length 1 (by default) or length \code{nsimulations} (if \code{uncertainty = TRUE}). } \description{ The \code{rstar()} function generates a measure of convergence for MCMC draws based on whether it is possible to determine the Markov chain that generated a draw with probability greater than chance. To do so, it fits a machine learning classifier to a training set of MCMC draws and evaluates its predictive accuracy on a testing set: giving the ratio of accuracy to predicting a chain uniformly at random. } \details{ The \code{rstar()} function provides a measure of MCMC convergence based on whether it is possible to determine the chain that generated a particular draw with a probability greater than chance. To do so, it fits a machine learning classifier to a subset of the original MCMC draws (the training set) and evaluates its predictive accuracy on the remaining draws (the testing set). If predictive accuracy exceeds chance (i.e. predicting the chain that generated a draw uniformly at random), the diagnostic measure R* will be above 1, indicating that convergence has yet to occur. This statistic is recently developed, and it is currently unclear what is a reasonable threshold for diagnosing convergence. The statistic, R*, is stochastic, meaning that each time the test is run, unless the random seed is fixed, it will generally produce a different result. To minimize the implications of this stochasticity, it is recommended to repeatedly run this function to calculate a distribution of R*; alternatively, an approximation to this distribution can be obtained by setting \code{uncertainty = TRUE}, although this approximation of uncertainty will generally have a lower mean. By default, a random forest classifier is used (\code{method = "rf"}), which tends to perform best for target distributions of around 4 dimensions and above. For lower dimensional targets, gradient boosted models (called via \code{method = "gbm"}) tend to have a higher classification accuracy. On a given MCMC sample, it is recommended to try both of these classifiers. } \examples{ \donttest{ if (require("caret", quietly = TRUE)) { x <- example_draws("eight_schools") print(rstar(x)) print(rstar(x, split = FALSE)) print(rstar(x, method = "gbm")) # can pass additional arguments to methods print(rstar(x, method = "gbm", verbose = FALSE)) # with uncertainty, returns a vector of R* values hist(rstar(x, uncertainty = TRUE)) hist(rstar(x, uncertainty = TRUE, nsimulations = 100)) # can use other classification methods in caret library print(rstar(x, method = "knn")) } } } \references{ Ben Lambert, Aki Vehtari (2020) R*: A robust MCMC convergence diagnostic with uncertainty using gradient-boosted machines. \emph{arXiv preprint} \code{arXiv:2003.07900}. } \seealso{ Other diagnostics: \code{\link{ess_basic}()}, \code{\link{ess_bulk}()}, \code{\link{ess_quantile}()}, \code{\link{ess_sd}()}, \code{\link{ess_tail}()}, \code{\link{mcse_mean}()}, \code{\link{mcse_quantile}()}, \code{\link{mcse_sd}()}, \code{\link{rhat_basic}()}, \code{\link{rhat}()} } \concept{diagnostics} posterior/man/mcse_mean.Rd0000755000175000017500000000440414165317763015445 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/convergence.R \name{mcse_mean} \alias{mcse_mean} \alias{mcse_mean.default} \alias{mcse_mean.rvar} \title{Monte Carlo standard error for the mean} \usage{ mcse_mean(x, ...) \method{mcse_mean}{default}(x, ...) \method{mcse_mean}{rvar}(x, ...) } \arguments{ \item{x}{(multiple options) One of: \itemize{ \item A matrix of draws for a single variable (iterations x chains). See \code{\link[=extract_variable_matrix]{extract_variable_matrix()}}. \item An \code{\link{rvar}}. }} \item{...}{Arguments passed to individual methods (if applicable).} } \value{ If the input is an array, returns a single numeric value. If any of the draws is non-finite, that is, \code{NA}, \code{NaN}, \code{Inf}, or \code{-Inf}, the returned output will be (numeric) \code{NA}. Also, if all draws within any of the chains of a variable are the same (constant), the returned output will be (numeric) \code{NA} as well. The reason for the latter is that, for constant draws, we cannot distinguish between variables that are supposed to be constant (e.g., a diagonal element of a correlation matrix is always 1) or variables that just happened to be constant because of a failure of convergence or other problems in the sampling process. If the input is an \code{\link{rvar}}, returns an array of the same dimensions as the \code{\link{rvar}}, where each element is equal to the value that would be returned by passing the draws array for that element of the \code{\link{rvar}} to this function. } \description{ Compute the Monte Carlo standard error for the mean (expectation) of a single variable. } \examples{ mu <- extract_variable_matrix(example_draws(), "mu") mcse_mean(mu) d <- as_draws_rvars(example_draws("multi_normal")) mcse_mean(d$Sigma) } \references{ Andrew Gelman, John B. Carlin, Hal S. Stern, David B. Dunson, Aki Vehtari and Donald B. Rubin (2013). \emph{Bayesian Data Analysis, Third Edition}. Chapman and Hall/CRC. } \seealso{ Other diagnostics: \code{\link{ess_basic}()}, \code{\link{ess_bulk}()}, \code{\link{ess_quantile}()}, \code{\link{ess_sd}()}, \code{\link{ess_tail}()}, \code{\link{mcse_quantile}()}, \code{\link{mcse_sd}()}, \code{\link{rhat_basic}()}, \code{\link{rhat}()}, \code{\link{rstar}()} } \concept{diagnostics} posterior/man/posterior-package.Rd0000644000175000017500000000501114165314652017117 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/posterior-package.R \docType{package} \name{posterior-package} \alias{posterior-package} \alias{posterior} \title{Tools for working with posterior (and prior) distributions} \description{ \if{html}{ \figure{stanlogo.png}{options: width="50"} \url{https://mc-stan.org/posterior/} } The \pkg{posterior} package is intended to provide useful tools for both users and developers of packages for fitting Bayesian models or working with output from Bayesian models. The primary goals of the package are to: \itemize{ \item Efficiently convert between many different useful formats of draws (samples) from posterior or prior distributions. \item Provide consistent methods for operations commonly performed on draws, for example, subsetting, binding, or mutating draws. \item Provide various summaries of draws in convenient formats. \item Provide lightweight implementations of state of the art posterior inference diagnostics. } } \section{Package options}{ The following options are used to format and print \code{\link{draws}} objects, as in \code{print.draws_array()}, \code{print.draws_df()}, \code{print.draws_list()}, \code{print.draws_matrix()}, and \code{print.draws_rvars()}: \itemize{ \item \code{posterior.max_draws}: Maximum number of draws to print. \item \code{posterior.max_iterations}: Maximum number of iterations to print. \item \code{posterior.max_chains}: Maximum number of chains to print. \item \code{posterior.max_variables}: Maximum number of variables to print. } The following option is used to format and print \code{\link{rvar}} objects, as in \code{print.rvar()} and \code{print.draws_rvars()}: \itemize{ \item \code{posterior.rvar_summary}: What style of summary to display: \code{"mean_sd"} displays \verb{mean±sd}, \code{"median_mad"} displays \verb{median±mad}. } The following option is used to construct new \code{\link{rvar}} objects, as in \code{rfun()} and \code{rdo()}: \itemize{ \item \code{posterior.rvar_ndraws}: The number of draws used to construct new random variables when this number cannot be determined from existing arguments (e.g., other \code{\link{rvar}}s passed to a function). } The following options are used to control warning messages: \itemize{ \item \code{posterior.warn_on_merge_chains}: (logical) Some operations will trigger an automatic merging of chains, for example, because chains do not match between two objects involved in a binary operation. Whether this causes a warning can be controlled by this option. } } posterior/man/as_rvar.Rd0000755000175000017500000000447414165314652015154 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/rvar-cast.R \name{as_rvar} \alias{as_rvar} \title{Coerce to a random variable} \usage{ as_rvar(x, dim = NULL, dimnames = NULL, nchains = NULL) } \arguments{ \item{x}{(multiple options) An object that can be converted to an \code{\link{rvar}}, such as a vector, array, or an \code{\link{rvar}} itself.} \item{dim}{(integer vector) One or more integers giving the maximal indices in each dimension to override the dimensions of the \code{\link{rvar}} to be created (see \code{\link[=dim]{dim()}}). If \code{NULL} (the default), \code{dim} is determined by the input. \strong{NOTE:} This argument controls the dimensions of the \code{\link{rvar}}, not the underlying array, so you cannot change the number of draws using this argument.} \item{dimnames}{(list) Character vectors giving the names in each dimension to override the names of the dimensions of the \code{\link{rvar}} to be created (see \code{\link[=dimnames]{dimnames()}}). If \code{NULL} (the default), this is determined by the input. \strong{NOTE:} This argument controls the names of the dimensions of the \code{\link{rvar}}, not the underlying array.} \item{nchains}{(positive integer) The number of chains. The default is \code{1}.} } \value{ An object of class \code{"rvar"} representing a random variable. } \description{ Convert \code{x} to an \code{\link{rvar}} object. } \details{ For objects that are already \code{\link{rvar}}s, returns them (with modified dimensions if \code{dim} is not \code{NULL}). For numeric or logical vectors or arrays, returns an \code{\link{rvar}} with a single draw and the same dimensions as \code{x}. This is in contrast to the \code{\link[=rvar]{rvar()}} constructor, which treats the first dimension of \code{x} as the draws dimension. As a result, \code{as_rvar()} is useful for creating constants. } \examples{ # You can use as_rvar() to create "constant" rvars (having only one draw): x <- as_rvar(1) x # Such constants can be of arbitrary shape: as_rvar(1:4) as_rvar(matrix(1:10, nrow = 5)) as_rvar(array(1:12, dim = c(2, 3, 2))) } \seealso{ \code{\link[=rvar]{rvar()}} to construct \code{\link{rvar}}s directly. See \code{\link[=rdo]{rdo()}}, \code{\link[=rfun]{rfun()}}, and \code{\link[=rvar_rng]{rvar_rng()}} for higher-level interfaces for creating \code{rvar}s. } posterior/man/is_rvar.Rd0000755000175000017500000000071614165314652015157 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/rvar-cast.R \name{is_rvar} \alias{is_rvar} \title{Is \code{x} a random variable?} \usage{ is_rvar(x) } \arguments{ \item{x}{(any object) An object to test.} } \value{ \code{TRUE} if \code{x} is an \code{\link{rvar}}, \code{FALSE} otherwise. } \description{ Test if \code{x} is an \code{\link{rvar}}. } \seealso{ \code{\link[=as_rvar]{as_rvar()}} to convert objects to \code{rvar}s. } posterior/man/rename_variables.Rd0000755000175000017500000000246014165314652017007 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/rename_variables.R \name{rename_variables} \alias{rename_variables} \alias{rename_variables.draws} \title{Rename variables in \code{draws} objects} \usage{ rename_variables(.x, ...) \method{rename_variables}{draws}(.x, ...) } \arguments{ \item{.x}{(draws) A \code{\link{draws}} object.} \item{...}{One or more expressions, separated by commas, indicating the variables to rename. The variable names can be unquoted (\code{new_name = old_name}) or quoted (\code{"new_name" = "old_name"}). For non-scalar variables, all elements can be renamed together (\code{"new_name" = "old_name"}) or they can be renamed individually (\code{"new_name[1]" = "old_name[1]"}).} } \value{ Returns a \code{\link{draws}} object of the same format as \code{.x}, with variables renamed according to the expressions provided in \code{...}. } \description{ Rename variables in a \code{\link{draws}} object. } \examples{ x <- as_draws_df(example_draws()) variables(x) x <- rename_variables(x, mean = mu, sigma = tau) variables(x) x <- rename_variables(x, b = `theta[1]`) # or b = "theta[1]" variables(x) # rename all elements of 'theta' at once x <- rename_variables(x, alpha = theta) variables(x) } \seealso{ \code{\link{variables}}, \code{\link{mutate_variables}} } posterior/man/mutate_variables.Rd0000644000175000017500000000420014165314652017026 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/mutate_variables.R \name{mutate_variables} \alias{mutate_variables} \alias{mutate_variables.draws_matrix} \alias{mutate_variables.draws_array} \alias{mutate_variables.draws_df} \alias{mutate_variables.draws_list} \alias{mutate_variables.draws_rvars} \title{Mutate variables in \code{draws} objects} \usage{ mutate_variables(.x, ...) \method{mutate_variables}{draws_matrix}(.x, ...) \method{mutate_variables}{draws_array}(.x, ...) \method{mutate_variables}{draws_df}(.x, ...) \method{mutate_variables}{draws_list}(.x, ...) \method{mutate_variables}{draws_rvars}(.x, ...) } \arguments{ \item{.x}{(draws) A \code{\link{draws}} object.} \item{...}{Name-value pairs of expressions, each with either length 1 or the same length as in the entire input (i.e., number of iterations or draws). The name of each argument will be the name of a new variable, and the value will be its corresponding value. Use a \code{NULL} value in \code{mutate_variables} to drop a variable. New variables overwrite existing variables of the same name.} } \value{ Returns a \code{\link{draws}} object of the same format as \code{.x}, with variables mutated according to the expressions provided in \code{...}. } \description{ Mutate variables in a \code{\link{draws}} object. } \details{ In order to mutate variables in \code{\link{draws_matrix}} and \code{\link{draws_array}} objects, they are transformed to \code{\link{draws_df}} objects first and then transformed back after mutation. As those transformations are quite expensive for larger number of draws, we recommend using \code{mutate_variables} on \code{\link{draws_df}} and \code{\link{draws_list}} objects if speed is an issue. In \code{\link{draws_rvars}} objects, the output of each expression in \code{...} is coerced to an \code{\link{rvar}} object if it is not already one using \code{as_rvar()}. } \examples{ x <- as_draws_df(example_draws()) x <- subset(x, variable = c("mu", "tau")) mutate_variables(x, tau2 = tau^2) mutate_variables(x, scale = 1.96 * tau, lower = mu - scale) } \seealso{ \code{\link{variables}}, \code{\link{rename_variables}} } posterior/man/draws.Rd0000755000175000017500000000240614165314652014630 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/as_draws.R \name{draws} \alias{draws} \alias{as_draws} \alias{is_draws} \title{Transform to \code{draws} objects} \usage{ as_draws(x, ...) is_draws(x) } \arguments{ \item{x}{(draws) A \code{draws} object or another \R object for which the method is defined.} \item{...}{Arguments passed to individual methods (if applicable).} } \value{ If possible, a \code{draws} object in the closest supported format to \code{x}. The formats are linked to in the \strong{See Also} section below. } \description{ Try to transform an \R object to a format supported by the \pkg{posterior} package. } \details{ The class \code{"draws"} is the parent class of all supported formats, which also have their own subclasses of the form \code{"draws_{format}"} (e.g. \code{"draws_array"}). } \examples{ # create some random draws x <- matrix(rnorm(30), nrow = 10) colnames(x) <- c("a", "b", "c") str(x) # transform to a draws object y <- as_draws(x) str(y) # remove the draws classes from the object class(y) <- class(y)[-(1:2)] str(y) } \seealso{ Other formats: \code{\link{draws_array}()}, \code{\link{draws_df}()}, \code{\link{draws_list}()}, \code{\link{draws_matrix}()}, \code{\link{draws_rvars}()} } \concept{formats} posterior/man/order_draws.Rd0000644000175000017500000000233614165314652016022 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/order_draws.R \name{order_draws} \alias{order_draws} \alias{order_draws.draws_matrix} \alias{order_draws.draws_array} \alias{order_draws.draws_df} \alias{order_draws.draws_list} \alias{order_draws.draws_rvars} \alias{order_draws.rvar} \title{Order \code{draws} objects} \usage{ order_draws(x, ...) \method{order_draws}{draws_matrix}(x, ...) \method{order_draws}{draws_array}(x, ...) \method{order_draws}{draws_df}(x, ...) \method{order_draws}{draws_list}(x, ...) \method{order_draws}{draws_rvars}(x, ...) \method{order_draws}{rvar}(x, ...) } \arguments{ \item{x}{(draws) A \code{draws} object or another \R object for which the method is defined.} \item{...}{Arguments passed to individual methods (if applicable).} } \value{ A \code{draws} object of the same class as \code{x}. } \description{ Order \code{\link{draws}} objects according to iteration and chain number. By default, draws objects are ordered but subsetting or extracting parts of them may leave them in an unordered state. } \examples{ x <- as_draws_array(example_draws()) dimnames(x[10:5, 4:3, ]) dimnames(order_draws(x[10:5, 4:3, ])) } \seealso{ \code{\link[=repair_draws]{repair_draws()}} } posterior/man/diagnostics.Rd0000644000175000017500000000251414165314652016014 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/convergence.R \name{diagnostics} \alias{diagnostics} \alias{convergence} \title{List of available convergence diagnostics} \value{ See individual functions for a description of return types. } \description{ A list of available diagnostics and links to their individual help pages. } \details{ \tabular{ll}{ \strong{Function} \tab \strong{Description} \cr \code{\link[=ess_basic]{ess_basic()}} \tab Basic version of effective sample size \cr \code{\link[=ess_bulk]{ess_bulk()}} \tab Bulk effective sample size \cr \code{\link[=ess_tail]{ess_tail()}} \tab Tail effective sample size \cr \code{\link[=ess_quantile]{ess_quantile()}} \tab Effective sample sizes for quantiles \cr \code{\link[=ess_sd]{ess_sd()}} \tab Effective sample sizes for standard deviations \cr \code{\link[=mcse_mean]{mcse_mean()}} \tab Monte Carlo standard error for the mean \cr \code{\link[=mcse_quantile]{mcse_quantile()}} \tab Monte Carlo standard error for quantiles \cr \code{\link[=mcse_sd]{mcse_sd()}} \tab Monte Carlo standard error for standard deviations \cr \code{\link[=rhat_basic]{rhat_basic()}} \tab Basic version of Rhat \cr \code{\link[=rhat]{rhat()}} \tab Improved, rank-based version of Rhat \cr \code{\link[=rstar]{rstar()}} \tab R* diagnostic \cr } } posterior/man/quantile2.Rd0000755000175000017500000000313614165314652015415 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/convergence.R \name{quantile2} \alias{quantile2} \alias{quantile2.default} \alias{quantile2.rvar} \title{Compute Quantiles} \usage{ quantile2(x, probs = c(0.05, 0.95), na.rm = FALSE, ...) \method{quantile2}{default}(x, probs = c(0.05, 0.95), na.rm = FALSE, names = TRUE, ...) \method{quantile2}{rvar}(x, probs = c(0.05, 0.95), na.rm = FALSE, names = TRUE, ...) } \arguments{ \item{x}{(multiple options) One of: \itemize{ \item A matrix of draws for a single variable (iterations x chains). See \code{\link[=extract_variable_matrix]{extract_variable_matrix()}}. \item An \code{\link{rvar}}. }} \item{probs}{(numeric vector) Probabilities in \verb{[0, 1]}.} \item{na.rm}{(logical) Should \code{NA} and \code{NaN} values be removed from \code{x} prior to computing quantiles? The default is \code{FALSE}.} \item{...}{Arguments passed to individual methods (if applicable) and then on to \code{\link[stats:quantile]{stats::quantile()}}.} \item{names}{(logical) Should the result have a \code{names} attribute? The default is \code{TRUE}, but use \code{FALSE} for improved speed if there are many values in \code{probs}.} } \value{ A numeric vector of length \code{length(probs)}. If \code{names = TRUE}, it has a \link{names} attribute with names like \code{"q5"}, \code{"q95"}, etc, based on the values of \code{probs}. } \description{ Compute quantiles of a sample and return them in a format consistent with other summary functions in the \pkg{posterior} package. } \examples{ mu <- extract_variable_matrix(example_draws(), "mu") quantile2(mu) } posterior/man/sub-.draws_matrix.Rd0000644000175000017500000000172214165314652017056 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/as_draws_matrix.R \name{[.draws_matrix} \alias{[.draws_matrix} \title{Extract parts of a \code{draws_matrix} object} \usage{ \method{[}{draws_matrix}(x, i, j, ..., drop = FALSE) } \arguments{ \item{x, i, j, ..., drop}{Same as in the default extraction method but with \code{drop} being set to \code{FALSE} by default.} } \value{ An object of class \code{"draws_matrix"} unless any of the dimensions was dropped during the extraction. } \description{ Extract parts of a \code{draws_matrix} object. They are strictly defined as matrices (draws x variable) so dropping any of the dimensions breaks the expected structure of the object. Accordingly, no dropping of dimensions is done by default even if the extracted slices are of length 1. If \code{drop} is manually set to \code{TRUE} and any of the dimensions is actually dropped, this will lead to dropping the \code{"draws_matrix"} class as well. } posterior/man/autocovariance.Rd0000644000175000017500000000107614165314652016512 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/convergence.R \name{autocovariance} \alias{autocovariance} \title{Autocovariance estimates} \usage{ autocovariance(x) } \arguments{ \item{x}{(numeric vector) A sequence of values.} } \value{ A numeric vector of autocovariances at every lag (scaled by N-lag). } \description{ Compute autocovariance estimates for every lag for the specified input sequence using a fast Fourier transform approach. The estimate for lag t is scaled by N-t where N is the length of the sequence. } \keyword{internal} posterior/man/rvar-matmult.Rd0000755000175000017500000000365114165314652016146 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/rvar-math.R \name{rvar-matmult} \alias{rvar-matmult} \alias{\%**\%} \title{Matrix multiplication of random variables} \usage{ x \%**\% y } \arguments{ \item{x}{(multiple options) The object to be postmultiplied by \code{y}: \itemize{ \item An \code{\link{rvar}} \item A \code{\link{numeric}} vector or matrix \item A \code{\link{logical}} vector or matrix } If a vector is used, it is treated as a \emph{row} vector.} \item{y}{(multiple options) The object to be premultiplied by \code{x}: \itemize{ \item An \code{\link{rvar}} \item A \code{\link{numeric}} vector or matrix \item A \code{\link{logical}} vector or matrix } If a vector is used, it is treated as a \emph{column} vector.} } \value{ An \code{\link{rvar}} representing the matrix product of \code{x} and \code{y}. } \description{ Matrix multiplication of random variables. } \details{ If \code{x} or \code{y} are vectors, they are converted into matrices prior to multiplication, with \code{x} converted to a row vector and \code{y} to a column vector. Numerics and logicals can be multiplied by \code{\link{rvar}}s and are broadcasted across all draws of the \code{\link{rvar}} argument. Tensor multiplication is used to efficiently multiply matrices across draws, so if either \code{x} or \code{y} is an \code{\link{rvar}}, \code{x \%**\% y} will be much faster than \code{rdo(x \%*\% y)}. Because \code{\link{rvar}} is an S3 class and S3 classes cannot properly override \code{\%*\%}, \code{\link{rvar}}s use \verb{\%**\%} for matrix multiplication. } \examples{ # d has mu (mean vector of length 3) and Sigma (3x3 covariance matrix) d <- as_draws_rvars(example_draws("multi_normal")) d$Sigma # trivial example: multiplication by a non-random matrix d$Sigma \%**\% diag(1:3) # Decompose Sigma into R s.t. R'R = Sigma ... R <- chol(d$Sigma) # ... and recreate Sigma using matrix multiplication t(R) \%**\% R } posterior/man/print.draws_matrix.Rd0000644000175000017500000000260714165314652017347 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/print.R \name{print.draws_matrix} \alias{print.draws_matrix} \title{Print \code{draws_matrix} objects} \usage{ \method{print}{draws_matrix}( x, digits = 2, max_draws = getOption("posterior.max_draws", 10), max_variables = getOption("posterior.max_variables", 8), reserved = FALSE, ... ) } \arguments{ \item{x}{(draws) A \code{draws} object or another \R object for which the method is defined.} \item{digits}{(nonnegative integer) The minimum number of significant digits to print.} \item{max_draws}{(positive integer) The maximum number of draws to print. Can be controlled globally via the \code{"posterior.max_draws"} \link[base:options]{option}.} \item{max_variables}{(positive integer) The maximum number of variables to print. Can be controlled globally via the \code{"posterior.max_variables"} \link[base:options]{option}.} \item{reserved}{(logical) Should reserved variables be included in the output? Defaults to \code{FALSE}. See \code{\link{reserved_variables}} for an overview of currently reserved variable names.} \item{...}{Further arguments passed to the underlying \code{\link[=print]{print()}} methods.} } \value{ A \code{draws} object of the same class as \code{x}. } \description{ Pretty printing for \code{\link{draws_matrix}} objects. } \examples{ x <- as_draws_matrix(example_draws()) print(x) } posterior/man/print.draws_array.Rd0000644000175000017500000000317214165314652017157 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/print.R \name{print.draws_array} \alias{print.draws_array} \title{Print \code{draws_array} objects} \usage{ \method{print}{draws_array}( x, digits = 2, max_iterations = getOption("posterior.max_iterations", 5), max_chains = getOption("posterior.max_chains", 8), max_variables = getOption("posterior.max_variables", 4), reserved = FALSE, ... ) } \arguments{ \item{x}{(draws) A \code{draws} object or another \R object for which the method is defined.} \item{digits}{(nonnegative integer) The minimum number of significant digits to print.} \item{max_iterations}{(positive integer) The maximum number of iterations to print. Can be controlled globally via the \code{"posterior.max_iterations"} \link[base:options]{option}.} \item{max_chains}{(positive integer) The maximum number of chains to print. Can be controlled globally via the \code{"posterior.max_chains"} \link[base:options]{option}.} \item{max_variables}{(positive integer) The maximum number of variables to print. Can be controlled globally via the \code{"posterior.max_variables"} \link[base:options]{option}.} \item{reserved}{(logical) Should reserved variables be included in the output? Defaults to \code{FALSE}. See \code{\link{reserved_variables}} for an overview of currently reserved variable names.} \item{...}{Further arguments passed to the underlying \code{\link[=print]{print()}} methods.} } \value{ A \code{draws} object of the same class as \code{x}. } \description{ Pretty printing for \code{\link{draws_array}} objects. } \examples{ x <- as_draws_array(example_draws()) print(x) } posterior/man/thin_draws.Rd0000644000175000017500000000141614165314652015647 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/thin_draws.R \name{thin_draws} \alias{thin_draws} \alias{thin} \alias{thin_draws.draws} \title{Thin \code{draws} objects} \usage{ thin_draws(x, thin, ...) \method{thin_draws}{draws}(x, thin, ...) } \arguments{ \item{x}{(draws) A \code{draws} object or another \R object for which the method is defined.} \item{thin}{(positive integer) The period for selecting draws.} \item{...}{Arguments passed to individual methods (if applicable).} } \value{ A \code{draws} object of the same class as \code{x}. } \description{ Thin \code{\link{draws}} objects to reduce their size and autocorrelation in the chains. } \examples{ x <- example_draws() niterations(x) x <- thin_draws(x, thin = 5) niterations(x) } posterior/man/weights.draws.Rd0000644000175000017500000000276214165314652016303 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/weight_draws.R \name{weights.draws} \alias{weights.draws} \title{Extract Weights from Draws Objects} \usage{ \method{weights}{draws}(object, log = FALSE, normalize = TRUE, ...) } \arguments{ \item{object}{(draws) A \code{\link{draws}} object.} \item{log}{(logical) Should the weights be returned on the log scale? Defaults to \code{FALSE}.} \item{normalize}{(logical) Should the weights be normalized to sum to 1 on the standard scale? Defaults to \code{TRUE}.} \item{...}{Arguments passed to individual methods (if applicable).} } \value{ A vector of weights, with one weight per draw. } \description{ Extract weights from \code{\link{draws}} objects, with one weight per draw. See \code{\link{weight_draws}} for details how to add weights to \code{\link{draws}} objects. } \examples{ x <- example_draws() # sample some random weights for illustration wts <- rexp(ndraws(x)) head(wts) # add weights x <- weight_draws(x, weights = wts) # extract weights head(weights(x)) # defaults to normalized weights head(weights(x, normalize=FALSE)) # recover original weights head(weights(x, log=TRUE)) # get normalized log-weights # add weights which are already on the log scale log_wts <- log(wts) head(log_wts) x <- weight_draws(x, weights = log_wts, log = TRUE) # extract weights head(weights(x)) head(weights(x, log=TRUE, normalize = FALSE)) # recover original log_wts } \seealso{ \code{\link{weight_draws}}, \code{\link{resample_draws}} } posterior/man/figures/0000755000175000017500000000000014157600276014661 5ustar nileshnileshposterior/man/figures/stanlogo.png0000644000175000017500000003745413670414573017234 0ustar nileshnileshPNG  IHDRwx+sBIT|d pHYs&:4tEXtSoftwarewww.inkscape.org< IDATxw|ՙsf$w+$` ؘbQCB ے'7B6R6uq6e7M ل$ ؒm Л$W43+WY{nyޯ/lIw >̙31 B2J #7¡# #a@H P U] ]tuW~V-nUt+ˊ@l sy#/f TILxC&f~I&`= PX]&b.{gʘɋE 邞0t hrh=OuO\Κ;gnnՓ zt2L¾xYIqAsb?l_3bw끳1s+WAŮmZ􇕻OA_LӀsxH`9pO_Can5 j.͠gڪ' UX;i\}2Ə A|g2xEnE٬Z;),V%sNLbALpCfX3j8w5O+~WϪg}1~X%L]PSyL1|/cʽ atC=؟{9ROLl;-!/aKH> `<` 4u-7%ʽNiܻ ;)x+֑|1c^"Qs.ȇ} hLOSq#cʽ-p+5o P;)7Ŵ0o܋|F dS |1J7(`-Nczʽ,a؈#~ܔgw3VE`ܗyBwS o0{V,sQ?|}1K"{/Y.+q5Jy9NZx "j9UX\oӶwa^2[xmoG!F@ǘ,٤׆2O2X{Lã)A¿6ҲwrdgK?%F#c]JF>;H9rϓJ?#ti;/evyʁ{4Qs%AFb_ .YB*2wc K ^;Kri*oC}1@J;-ߙ 0=Q=S8NRJܳZRGӠ_.[|s~5wS JBja킾 ˘ʎ7՞6rfjߣOASdb1E 8y)PF҄we߁ʑ{-aї1hnY@ʽG1a8wc Jл,Exq@f_VsaLy%p",CþYTFnwc r =U[(H_,N?+LpleK鲑;ɕt\/;}g1&V.NpTi/}2W徘 z+YɒdFɒzd˽ ^ r,C<{hyt$CʶR}&{)R{)-`ʲQ} VĘUnw*{9+EԾW¦mDe_鑲*&j&` J5Kgw Sʦܛ -=;r\Ȕ(&j?s^KY;)M%_¿aʚMޕ )|wSvv 9A;[Y;)?%9r^#ࣾ@,]NߙLy+ro?@;)i1"ДܴLfnrdP%Xs(%5roS5sJE2^n1Ţdʽ+\O 7oV.܂9/E)*%Q~ <5}" 9~wc˽F)&̞*"ܔ.%AQd mĉ_1( $W69I1ٗ۩{AP!Ug[S2r_ȸG,003.;1&rA5 Z[hL}15O89}4 5U|'1GNK}؍)/9-SypZ.a0B"Fq xN\t뮐z˘ÑY{sO;hnLƏ Vӕ|bYモc= [܊"&p 4a/71 b؍)5xSLSXHwyܛȋ@U6kЖ&u-y4,er$S''L&o+Hl;#wV7؍g9;U0i S#'!> |*[6rof\<?dϫevA)TiB2k$~*?+/z1ٷqnT 2 =϶vO][V-e쨈j`@6gzF3 9zk|g1X)d"]8&B8ɄY=&(Vy ؍f L z2ȉ'v]qx pe9Xhg7f?ׁ͋la\v(o#y/Vy'r{)w9$`*N2S+'r4/2zYҟ+H35O`F5&sSZjXOG+i2_#b3e­L<"E<]$EO9`-x]Eh]L^o ˜@j'(LKΡSA|BKĻ1sKЇzg;}12ۀ'+:ݡ')LVuG`j=ˋɻ$-T pCNQS]T[?^}'(7&(-3K"_ie&?1G"'55'_{DVA+)\Z]U]yBJ ~ړq rES>lV|*=NHftɚ*7.zX=ZD8Vlk> Cꩂ:8;) NՇ U4p{a۽~\n68Ȕ%Nu]#1\;y͵ԥb*SaG~ȅq{&kuϋLo88d3ɂW}M\Vy߳bYc# z:l8͘Cp!ɥa]!kLOll}(UK86">8]f88"3zOMqpn˽R&IoRHe5h!JR&W=[3߹ɂeF6m;t;rBA$sh 9pTzZÖωHW 6hJKcC}ae%V55ss 3dގw)u̦.%YOd?P-vxΑmph66*7H߬ Z|qȟ&jM4y"i;wBڣ8`&pv1HN͚nF\2Jpe|TQ{<{X87A'eLq.Kn޴ V!e9(3Ag>ksw$g*6Le2|#m#W.5g8$ru9c~;D?WթzUvB$:̍?}ș 5Cs@,!zKqtu;ZE.>v#azblbɳCh=<#?QB + \1>}`;U]oorF&VˠԞ -L˸JTo9vO >ҮɻSW\8G!` \'.慃س}ޠQc;Bڈ.$S#!=g&`TOjuW>fX|a_uLz7:.ΊǎQ#ԖBm)}LxE< zZ>s~c撷"8o8* 83d1Y9z6}0SP"~c_N.ʘqQ`+yc"!5sorדRږ_]~q+UAѱcZ2Jޘ~C'*3 88jB{*zx`.ΑmR2HLX'u{~ V<+EGhn%(/c␩Q@13ݞLF>zn7=η3zsnv\]ld+$!p|r|ƌ) `o7E\½ 4(dBߚ81.wE&o)cB-scae~*m[Dy0ˆcc 6ecʀ1j2Vd]wRuOJݛ\2WrK'Ȉq(({p)aw 2&ϡe{j{ڵo5 q k*:88ҾMQdr,%Ikw?t^n+a vQ ##jqH͛1]a(5M+ { >w s8`R؍v;Miџ*;9m]<FK<-ܘ;YȸG'dҗ]bJcj0(և<~d^ҒyKAĈD8&maSƅ [=/Vw]Edt8P+wpVg :*Xś%_R, eN r/E\Qh?5%V0Q|RÉMQゎ .`x,XVfˎ"i)PF694/\|YivT8W]sA !S P Δ=ӵ<qVgtӣЖ^[nHžw sU*483p^N{8HIKvb'^q / !τ123  A6;W|1sd831]Ɍ(dXsx;*:Xk-EB`&;*T8. &R67ފNBlRxw]Bf)qzgA Agĺx$"R P`j”b^ bۍ-f?/u}_#e{9%dsed 'D!6Ɓ-4X'>;͡WrJ=mSGM.aetM" wWtp~Gm%MQ, Ч|1:y]5U8!VE'ɲ jS3f(mABKK솗25@:*f_TbD`<@Eiq Ͷ /;hnQLAT8Mԧ+9% 9v,§"kX ]7)V\QACΐV%o(:mGҢ E 6r76H)qȔ^vѝ0IDAT .Rgv|G1r+Y0~RLҢuYԊb&{jTbRccbeKX^%0fdaqJne2WgD&Hhu1ĊH)ʃN.IWlrU>ØBLNx9Hhski+1Q cN陂tM,Ua^S(뜲&iu VE!+` zZ=K!Qg2JJu,]ɬt%ӣБV޼:{K$gO7Q 0<ɒK,c=|$OБb\bw5zHUgy]3!P;jbv&$]2g9.x޿٧yr7%Axqe%%촢Ϫ];dL 0:qNu+Niu-Ab ^kSiyv4N0"IqJ]f+M _ ҜzD^3S v42nEct>Bb}P˘0L9J.(d-{wn*\PצnBNBwc|쒁*^nh6Ӣ.aUb6gJQc)/Joc{ bd#&2,,FnØči¿Jճvd2x^GFgeLQ;岢 O.TOeŖ?xL61#j‚8Si Zu..7$2T;v8 A61+E湱oHѐ(Ű[q3Dݦ;*~ R=htܝ"ywci 'D'D] fK(7!$M+_QJ.B7D9cLu.fe&(i)xaz-)TN8g[zWS`|03EcΐE2ms4$Ċ!]lݘz%J.8,إ'U~^y>;C.9Id9]*U\@J=Az[N"`D9C}>ہrsHU 'DJ蘒&?͵ w}KNyc{cU>{97d71$1cgBbuM Wo|mlcYy `rE c鋁*{.cyCƷw}c7L~h7ЃuM> z\"cay*;wHJwmof@%h M_h]7ݘ4> :*CdItŞ+P[ \ϒhNA_AM85Q&jZKk]a+g olߴP_LjGi0onɴ 4e-1&%uTpNg\x Ck+vE?O;LCoN[~2q800"sT"EaCǺ!ȦdAOG從Q< `S)*!prrtH*]RqM?=@9џ]\Ý@0!*Q1:ݛb,2 Y =|u/'&E>Nk]#-}Cw;w!Yzp=MAy8O1S4'Oy8)L߭urG]flnLaFZ>| =-v` 1&T`A@2bM[0Y 7/CAz:cLN$@Sۥ=6S}"bh7/c1~%W+ <+I "z~cX k1/z^ neq+3^(6Tŋ޼3_cCPޓbpDƊ`}|zy0ч17t~-ٖC E_^rn}}1[OhW='3ۚyBo19w_ 4rPGZ=?>Rws֭Դ>z_ OY+D3V8t`}}u:kzc \=`bm_YQ{AgJ_D2vTDq)#i&%[RWǸ )Y ;#YM X<Ê|2"_OB*v +B"ءs{"G3ۂڲHc*l<;̡dls=AۋYK{cJD$$pˌ@Յ\ U؞C[/#0_cSYp pͪuMԾ'KlHS6*̇y_¦T Ɓ2rv4oBЛҶ<|3ɍ}g1;V5S}"1)iл/f߁jW`,WO뙽yRw6rHo ,1$ p.Re߁Vj @;9l;dyǰ.ެ7r@5QȧJy!@yEy\cr(^'pk#k}ʆLJrC?pnVG%dqLYwlzԷZqs@coLYwl[L }حԋm Łs2r̕_\Ø hSi!Sx;Dq_s:mL!ɃaZ)yw ڜ.߁r)˄K}?h=P;ɪ6\ >nstqk^Ϩ?^ÝO!$ﳟ$R@Yyrk?>?Քd K}?S4_ne[@;-FZs~g.4QspIg*;,ͮq@0p* odA@8SΖB>NpwֳY߁e)+#җ]^A६DDNfjyN㝂> !s=XHC\;CFZ)_kgvzmGeB5^S.s@13tu;9M959.p @ܗd` \͡\\Oy>gپ3%)NEt$ֳv@LxE%3L(H{}޼]P[@>od2S-LqoF \Z:@-M):?.7Qn|Vpp#>3=AV*:T%(:[tY@l_g2-GĖy!w[PM30Uq 0))&d[@Q |+w2g"] ^;!H) \( b7י,R}gDR;sdLѻqnK4!""A.dJZ;i":R80w".Kp*S9 Id&91QXƔ0J|,AR@O(,sݻH[.oo#zp>0^2@}o; y{H];Or)d΂|AO@މr@[<~20SLY v(ٴ\;Au[9@c:oȧhSD/{.p"h=ɩn8Aꀩsiw(=яU) /)Kۮ|?0iBBtVW}yNeܱBw{6v5f AuJR'TcKam+QlȻOf98vM|g+~ZNƟ )rt{j1EqWLӺcKymS^Νͪud{7v/?k9rcJIK@xlV$ܻ۬dZq)r}VN{e]pϡe$PN}m+Ӏscf% Xw\)r_DI7KɌk}g2xd@Rc_Qs N#B|lZ7kw|hdwŸ|g1xs_;Y[e2-R&WFo.W^_9ޭvoP63ƔE!o+]av&Y-3crGJG[VʲwkKW)ƔLė/E^!诀c]};Oe_ >! )vil~A|rLxyQY;H!(u=QOۚv4b-Czk2imT+czJ{1\B+9&jjLڮiY;H!rBj:t0wc>^ppZPٴL7.ieY|Y1{4gXwF=DA Ř2+GiyL7{g+fwcʉB$idrYMB=kS.Jd+ޱ{d6 `<Ɣ]|Ra1G'}ifbLy( yl<;Hi~Cˊ!wcJXܳd5 ;1E5z FYHCh?i'[gs 3Z4Y)pwXrR1ǘ +|g.ľÔ"+~Y) H>lLs=O~ A?_Oo})VyC;IY=jLإ*:b\X{̸Z} ]؟)iꕾ+R}f(:Y.}TOF=S&)7&M['>L/^YTB>%9aK$?gNa{Y!~8wc' I;1[|1r/PVm}s-cd^S;9gv+m89{[1[BywO<۫^~y4vq>>̮reoh3q{6s +2邼O@<&o^+zs#m 4z >]]r們w@TUsKo D7~1ʝ{jv8wu nZִˡjWtSw.$qoX

Vf>?+}piܱ++G0YS 4^~әnD r{gC8F05M`U~k'yZ&>00<)Ky#bڴkKup\!S9 Hq;<,VfV14wC8y +Vp{.fzUU ޠ*X|X5j9W/ׯyAEy qK鱽oA )9 3"2p_}x}qOq$sCuO+o}LJNDÖ+w'F CdFg98ɶ)fAy6K|Yk++G 7*=`GPy7/z\lerj5*0MHLf|gˣx^yOͦe 9pQEeˍ#N ԝae4`F,\|Y[jd (0O1.`+dUׯW%z<{5wzΗs6lS]os$7^%LI4!@&&1F(:BHō t3f 3c}f]yJX9Q4Gn@~NERCI;D8'WݴsByK)j0~D%P! d޹EQpm,Fi*RڂX U`$j2G1l?Πɡ"^@p_zNƙa$FF:u5ȏ2IENDB`posterior/man/weight_draws.Rd0000644000175000017500000000472414165314652016201 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/weight_draws.R \name{weight_draws} \alias{weight_draws} \alias{weight_draws.draws_matrix} \alias{weight_draws.draws_array} \alias{weight_draws.draws_df} \alias{weight_draws.draws_list} \alias{weight_draws.draws_rvars} \title{Weight \code{draws} objects} \usage{ weight_draws(x, weights, ...) \method{weight_draws}{draws_matrix}(x, weights, log = FALSE, ...) \method{weight_draws}{draws_array}(x, weights, log = FALSE, ...) \method{weight_draws}{draws_df}(x, weights, log = FALSE, ...) \method{weight_draws}{draws_list}(x, weights, log = FALSE, ...) \method{weight_draws}{draws_rvars}(x, weights, log = FALSE, ...) } \arguments{ \item{x}{(draws) A \code{draws} object or another \R object for which the method is defined.} \item{weights}{(numeric vector) A vector of weights of length \code{ndraws(x)}. Weights will be internally stored on the log scale (in a variable called \code{.log_weight}) and will not be normalized, but normalized (non-log) weights can be returned via the \code{\link[=weights.draws]{weights.draws()}} method later.} \item{...}{Arguments passed to individual methods (if applicable).} \item{log}{(logicla) Are the weights passed already on the log scale? The default is \code{FALSE}, that is, expecting \code{weights} to be on the standard (non-log) scale.} } \value{ A \code{draws} object of the same class as \code{x}. } \description{ Add weights to \code{\link{draws}} objects, with one weight per draw, for use in subsequent weighting operations. For reasons of numerical accuracy, weights are stored in the form of unnormalized log-weights (in a variable called \code{.log_weight}). See \code{\link[=weights.draws]{weights.draws()}} for details how to extract weights from \code{draws} objects. } \examples{ x <- example_draws() # sample some random weights for illustration wts <- rexp(ndraws(x)) head(wts) # add weights x <- weight_draws(x, weights = wts) # extract weights head(weights(x)) # defaults to normalized weights head(weights(x, normalize=FALSE)) # recover original weights head(weights(x, log=TRUE)) # get normalized log-weights # add weights which are already on the log scale log_wts <- log(wts) head(log_wts) x <- weight_draws(x, weights = log_wts, log = TRUE) # extract weights head(weights(x)) head(weights(x, log=TRUE, normalize = FALSE)) # recover original log_wts } \seealso{ \code{\link[=weights.draws]{weights.draws()}}, \code{\link[=resample_draws]{resample_draws()}} } posterior/man/sub-.draws_array.Rd0000644000175000017500000000174414165314652016674 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/as_draws_array.R \name{[.draws_array} \alias{[.draws_array} \title{Extract parts of a \code{draws_array} object} \usage{ \method{[}{draws_array}(x, i, j, ..., drop = FALSE) } \arguments{ \item{x, i, j, ..., drop}{Same as in the default extraction method but with \code{drop} being set to \code{FALSE} by default.} } \value{ An object of class \code{"draws_array"} unless any of the dimensions was dropped during the extraction. } \description{ Extract parts of a \code{draws_array} object. They are strictly defined as arrays of 3 dimensions (iteration x chain x variable) so dropping any of the dimensions breaks the expected structure of the object. Accordingly, no dropping of dimensions is done by default even if the extracted slices are of length 1. If \code{drop} is manually set to \code{TRUE} and any of the dimensions is actually dropped, this will lead to dropping the \code{"draws_array"} class as well. } posterior/man/rhat_basic.Rd0000755000175000017500000000560314165317763015617 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/convergence.R \name{rhat_basic} \alias{rhat_basic} \alias{rhat_basic.default} \alias{rhat_basic.rvar} \title{Basic version of the Rhat convergence diagnostic} \usage{ rhat_basic(x, ...) \method{rhat_basic}{default}(x, split = TRUE, ...) \method{rhat_basic}{rvar}(x, split = TRUE, ...) } \arguments{ \item{x}{(multiple options) One of: \itemize{ \item A matrix of draws for a single variable (iterations x chains). See \code{\link[=extract_variable_matrix]{extract_variable_matrix()}}. \item An \code{\link{rvar}}. }} \item{...}{Arguments passed to individual methods (if applicable).} \item{split}{(logical) Should the estimate be computed on split chains? The default is \code{TRUE}.} } \value{ If the input is an array, returns a single numeric value. If any of the draws is non-finite, that is, \code{NA}, \code{NaN}, \code{Inf}, or \code{-Inf}, the returned output will be (numeric) \code{NA}. Also, if all draws within any of the chains of a variable are the same (constant), the returned output will be (numeric) \code{NA} as well. The reason for the latter is that, for constant draws, we cannot distinguish between variables that are supposed to be constant (e.g., a diagonal element of a correlation matrix is always 1) or variables that just happened to be constant because of a failure of convergence or other problems in the sampling process. If the input is an \code{\link{rvar}}, returns an array of the same dimensions as the \code{\link{rvar}}, where each element is equal to the value that would be returned by passing the draws array for that element of the \code{\link{rvar}} to this function. } \description{ Compute the basic Rhat convergence diagnostic for a single variable as described in Gelman et al. (2013) with some changes according to Vehtari et al. (2021). For practical applications, we strongly recommend the improved Rhat convergence diagnostic implemented in \code{\link[=rhat]{rhat()}}. } \examples{ mu <- extract_variable_matrix(example_draws(), "mu") rhat_basic(mu) d <- as_draws_rvars(example_draws("multi_normal")) rhat_basic(d$Sigma) } \references{ Andrew Gelman, John B. Carlin, Hal S. Stern, David B. Dunson, Aki Vehtari and Donald B. Rubin (2013). \emph{Bayesian Data Analysis, Third Edition}. Chapman and Hall/CRC. Aki Vehtari, Andrew Gelman, Daniel Simpson, Bob Carpenter, and Paul-Christian Bürkner (2021). Rank-normalization, folding, and localization: An improved R-hat for assessing convergence of MCMC (with discussion). \emph{Bayesian Data Analysis}. 16(2), 667-–718. doi:10.1214/20-BA1221 } \seealso{ Other diagnostics: \code{\link{ess_basic}()}, \code{\link{ess_bulk}()}, \code{\link{ess_quantile}()}, \code{\link{ess_sd}()}, \code{\link{ess_tail}()}, \code{\link{mcse_mean}()}, \code{\link{mcse_quantile}()}, \code{\link{mcse_sd}()}, \code{\link{rhat}()}, \code{\link{rstar}()} } \concept{diagnostics} posterior/man/rvar-dist.Rd0000644000175000017500000000361414165314652015422 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/rvar-dist.R \name{rvar-dist} \alias{rvar-dist} \alias{density.rvar} \alias{cdf.rvar} \alias{quantile.rvar} \title{Density, CDF, and quantile functions of random variables} \usage{ \method{density}{rvar}(x, at, ...) \method{cdf}{rvar}(x, q, ...) \method{quantile}{rvar}(x, probs, ...) } \arguments{ \item{x}{(rvar) An \code{\link{rvar}} object.} \item{...}{Additional arguments passed onto underlying methods: \itemize{ \item For \code{density()}, these are passed to \code{\link[stats:density]{stats::density()}}. \item For \code{cdf()}, these are ignored. \item For \code{quantile()}, these are passed to \code{\link[stats:quantile]{stats::quantile()}}. }} \item{q, at}{(numeric vector) One or more quantiles.} \item{probs}{(numeric vector) One or more probabilities in \verb{[0,1]}.} } \value{ If \code{x} is a scalar \code{\link{rvar}}, returns a vector of the same length as the input (\code{q}, \code{at}, or \code{probs}) containing values from the corresponding function of the given \code{\link{rvar}}. If \code{x} has length greater than 1, returns an array with dimensions \code{c(length(y), dim(x))} where \code{y} is \code{q}, \code{at}, or \code{probs}, where each \code{result[i,...]} is the value of the corresponding function,\code{f(y[i])}, for the corresponding cell in the input array, \code{x[...]}. } \description{ The probability density function (\code{density()}), cumulative distribution function (\code{cdf()}), and quantile function / inverse CDF (\code{quantile()}) of an \code{\link{rvar}}. } \examples{ set.seed(1234) x = rvar(rnorm(100)) density(x, seq(-2, 2, length.out = 10)) cdf(x, seq(-2, 2, length.out = 10)) quantile(x, ppoints(10)) x2 = c(rvar(rnorm(100, mean = -0.5)), rvar(rnorm(100, mean = 0.5))) density(x2, seq(-2, 2, length.out = 10)) cdf(x2, seq(-2, 2, length.out = 10)) quantile(x2, ppoints(10)) } posterior/vignettes/0000755000175000017500000000000014165340155014446 5ustar nileshnileshposterior/vignettes/posterior.Rmd0000644000175000017500000003502514165314652017150 0ustar nileshnilesh--- title: "The posterior R package" author: "Paul Bürkner, Jonah Gabry, Matthew Kay, and Aki Vehtari" output: rmarkdown::html_vignette: toc: true toc_depth: 3 vignette: > %\VignetteIndexEntry{The posterior R package} %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} --- ## Introduction The posterior R package is intended to provide useful tools for both users and developers of packages for fitting Bayesian models or working with output from Bayesian models. The primary goals of the package are to: * Efficiently convert between many different useful formats of draws (samples) from posterior or prior distributions. * Provide consistent methods for operations commonly performed on draws, for example, subsetting, binding, or mutating draws. * Provide various summaries of draws in convenient formats. * Provide lightweight implementations of state of the art posterior inference diagnostics. ## Installation You can install the latest official release version via ```{r install, eval=FALSE} install.packages("posterior") ``` or the latest development version from GitHub via ```{r install_github, eval=FALSE} # install.packages("remotes") remotes::install_github("stan-dev/posterior") ``` ## Example ```{r setup} library("posterior") ``` To demonstrate how to work with the posterior package, throughout the rest of this vignette we will use example posterior draws obtained from the eight schools hierarchical meta-analysis model described in Gelman et al. (2013). The variables are an estimate per school (`theta[1]` through `theta[8]`) as well as an overall mean (`mu`) and standard deviation across schools (`tau`). ```{r example-drawss} eight_schools_array <- example_draws("eight_schools") print(eight_schools_array, max_variables = 3) ``` The structure of this object is explained in the next section. ## Draws formats ### Available formats Because different formats are preferable in different situations, posterior supports multiple formats and easy conversion between them. The currently supported formats are: * `draws_array`: An iterations by chains by variables array. * `draws_matrix`: A draws (iterations x chains) by variables array. * `draws_df`: A draws by variables data frame with addition meta columns `.chain`, `.iteration`, `.draw`. * `draws_list`: A list with one sublist per chain. Each sublist is a named list with one vector of iterations per variable. * `draws_rvars`: A list of random variable `rvar` objects, one per variable. See `vignette("rvar")` for an introduction to this new data type. These formats are essentially base R object classes and can be used as such. For example, a `draws_matrix` object is just a `matrix` with a little more consistency (e.g., no dropping of dimensions with one level when indexing) and additional methods. The exception to this is the `draws_rvars` format, which contains `rvar` objects that behave somewhat like arrays but are really a unique data type. See the separate vignette on the `rvar` and `draws_rvars` data types for details. The draws for our example come as a `draws_array` object with `r niterations(eight_schools_array)` iterations, `r nchains(eight_schools_array)` chains, and `r nvariables(eight_schools_array)` variables: ```{r draws_array-structure} str(eight_schools_array) ``` ### Converting between formats Each of the formats has a method `as_draws_` (e.g., `as_draws_list()`) for creating an object of the class from any of the other formats. As a demonstration we can convert the example `draws_array` to a `draws_df`, a data frame with additional meta information. To convert to a `draws_df` we use `as_draws_df()`. ```{r draws_df} eight_schools_df <- as_draws_df(eight_schools_array) str(eight_schools_df) print(eight_schools_df) ``` ### Converting regular R objects to `draws` formats The example draws already come in a format natively supported by posterior, but we can of course also import the draws from other sources like common base R objects. #### Example: create draws_matrix from a matrix In addition to converting other `draws` objects to the `draws_matrix` format, the `as_draws_matrix()` function will convert a regular matrix to a `draws_matrix`. ```{r draws_matrix-from-matrix} x <- matrix(rnorm(50), nrow = 10, ncol = 5) colnames(x) <- paste0("V", 1:5) x <- as_draws_matrix(x) print(x) ``` Because the matrix was converted to a `draws_matrix`, all of the methods for working with `draws` objects described in subsequent sections of this vignette will now be available. Instead of `as_draws_matrix()` we also could have just used `as_draws()`, which attempts to find the closest available format to the input object. In this case the result would be a `draws_matrix` object either way. #### Example: create draws_matrix from multiple vectors In addition to the `as_draws_matrix()` converter function there is also a `draws_matrix()` constructor function that can be used to create draws matrix from multiple vectors. ```{r draws_matrix-from-vectors} x <- draws_matrix(alpha = rnorm(50), beta = rnorm(50)) print(x) ``` Analogous functions exist for the other draws formats and are used similarly. ## Manipulating `draws` objects The posterior package provides many methods for manipulating draws objects in useful ways. In this section we demonstrate several of the most commonly used methods. These methods, like the other methods in posterior, are available for every supported draws format. ### Subsetting Subsetting `draws` objects can be done according to various aspects of the draws (iterations, chains, or variables). The posterior package provides a convenient interface for this purpose via `subset_draws()`. For example, here is the code to extract the first five iterations of the first two chains of the variable `mu`. ```{r subset-df} sub_df <- subset_draws(eight_schools_df, variable = "mu", chain = 1:2, iteration = 1:5) str(sub_df) ``` The same call to `subset_draws()` can be used regardless of the draws format. For example, here is the same code except replacing the `draws_df` object with the `draws_array` object. ```{r subset-array} sub_arr <- subset_draws(eight_schools_array, variable = "mu", chain = 1:2, iteration = 1:5) str(sub_arr) ``` We can check that these two calls to `subset_draws()` (the first with the data frame, the second with the array) produce the same result. ```{r subset-compare, results='hold'} identical(sub_df, as_draws_df(sub_arr)) identical(as_draws_array(sub_df), sub_arr) ``` It is also possible to use standard R subsetting syntax with `draws` objects. The following is equivalent to the use of `subset_draws()` with the array above. ```{r subset-standard} eight_schools_array[1:5, 1:2, "mu"] ``` The major difference between how posterior behaves when indexing and how base R behaves is that posterior will _not_ drop dimensions with only one level. That is, even though there is only one variable left after subsetting, the result of the subsetting above is still a `draws_array` and not a `draws_matrix`. ### Mutating (transformations of variables) The magic of having obtained draws from the joint posterior (or prior) distribution of a set of variables is that these draws can also be used to obtain draws from any other variable that is a function of the original variables. That is, if we are interested in the posterior distribution of, say, `phi = (mu + tau)^2` all we have to do is to perform the transformation for each of the individual draws to obtain draws from the posterior distribution of the transformed variable. This procedure is handled by `mutate_variables()`. ```{r mutate} x <- mutate_variables(eight_schools_df, phi = (mu + tau)^2) x <- subset_draws(x, c("mu", "tau", "phi")) print(x) ``` ### Renaming To rename variables use `rename_variables()`. Here we rename the scalar `mu` to `mean` and the vector `theta` to `alpha`. ```{r rename} # mu is a scalar, theta is a vector x <- rename_variables(eight_schools_df, mean = mu, alpha = theta) variables(x) ``` In the call to `rename_variables()` above, `mu` and `theta` can be quoted or unquoted. It is also possible to rename individual elements of non-scalar parameters, for example we can rename just the first element of `alpha`: ```{r rename-element} x <- rename_variables(x, a1 = `alpha[1]`) variables(x) ``` ### Binding The `bind_draws()` method can be used to combine `draws` objects along different dimensions. As an example, suppose we have several different `draws_matrix` objects: ```{r objects-to-bind} x1 <- draws_matrix(alpha = rnorm(5), beta = rnorm(5)) x2 <- draws_matrix(alpha = rnorm(5), beta = rnorm(5)) x3 <- draws_matrix(theta = rexp(5)) ``` We can bind `x1` and `x3` together along the `'variable'` dimension to get a single `draws_matrix` with the variables from both `x1` and `x3`: ```{r bind-variable} x4 <- bind_draws(x1, x3, along = "variable") print(x4) ``` Because `x1` and `x2` have the same variables, we can bind them along the `'draw'` dimension to create a single `draws_matrix` with more draws: ```{r bind-draw} x5 <- bind_draws(x1, x2, along = "draw") print(x5) ``` As with all posterior methods, `bind_draws()` can be used with all draws formats and depending on the format different dimensions are available to bind on. For example, we can bind `draws_array` objects together by `iteration`, `chain`, or `variable`, but a 2-D `draws_matrix` with the chains combined can only by bound by `draw` and `variable`. ## Summaries and diagnostics ### summarise_draws() basic usage Computing summaries of posterior or prior draws and convergence diagnostics for posterior draws are some of the most common tasks when working with Bayesian models fit using Markov Chain Monte Carlo (MCMC) methods. The posterior package provides a flexible interface for this purpose via `summarise_draws()` (or `summarize_draws()`), which can be passed any of the formats supported by the package. ```{r summary} # summarise_draws or summarize_draws summarise_draws(eight_schools_df) ``` The result is a data frame with one row per variable and one column per summary statistic or convergence diagnostic. The summaries `rhat`, `ess_bulk`, and `ess_tail` are described in Vehtari et al. (2020). We can choose which summaries to compute by passing additional arguments, either functions or names of functions. For instance, if we only wanted the mean and its corresponding Monte Carlo Standard Error (MCSE) we could use either of these options: ```{r summary-with-measures} # the function mcse_mean is provided by the posterior package s1 <- summarise_draws(eight_schools_df, "mean", "mcse_mean") s2 <- summarise_draws(eight_schools_df, mean, mcse_mean) identical(s1, s2) print(s1) ``` ### Changing column names The column names in the output can be changed by providing the functions as name-value pairs, where the name is the name to use in the output and the value is a function name or definition. For example, here we change the names `mean` and `sd` to `posterior_mean` and `posterior_sd`. ```{r change-summary-names} summarise_draws(eight_schools_df, posterior_mean = mean, posterior_sd = sd) ``` ### Using custom functions For a function to work with `summarise_draws()`, it needs to take a vector or matrix of numeric values and return a single numeric value or a named vector of numeric values. Additional arguments to the function can be specified in a list passed to the `.args` argument. ```{r summary-.args} weighted_mean <- function(x, wts) { sum(x * wts)/sum(wts) } summarise_draws( eight_schools_df, weighted_mean, .args = list(wts = rexp(ndraws(eight_schools_df))) ) ``` ### Specifying functions using lambda-like syntax It is also possible to specify a summary function using a one-sided formula that follows the conventions supported by `rlang::as_function()`. For example, the function ```{r standard-quantile, eval = FALSE} function(x) quantile(x, probs = c(0.4, 0.6)) ``` can be simplified to ```{r lambda-quantile, eval = FALSE} # for multiple arguments `.x` and `.y` can be used, see ?rlang::as_function ~quantile(., probs = c(0.4, 0.6)) ``` Both can be used with `summarise_draws()` and produce the same output: ```{r lambda-syntax} summarise_draws(eight_schools_df, function(x) quantile(x, probs = c(0.4, 0.6))) summarise_draws(eight_schools_df, ~quantile(.x, probs = c(0.4, 0.6))) ``` See `help("as_function", "rlang")` for details on specifying these functions. ### Other diagnostics In addition to the default diagnostic functions used by `summarise_draws()` (`rhat()`, `ess_bulk()`, `ess_tail()`), posterior also provides additional diagnostics like effective sample sizes and Monte Carlo standard errors for quantiles and standard deviations, an experimental new diagnostic called R*, and others. For a list of available diagnostics and links to their individual help pages see `help("diagnostics", "posterior")`. If you have suggestions for additional diagnostics that should be implemented in posterior, please open an issue at . ## Other methods for working with `draws` objects In addition to the methods demonstrated in this vignette, posterior has various other methods available for working with `draws` objects. The following is a (potentially incomplete) list. |**Method**|**Description**| |:----------|:---------------| | `order_draws()` | Order `draws` objects according to iteration and chain number | | `repair_draws()`| Repair indices of `draws` objects so that iterations chains, and draws are continuously and consistently numbered | |`resample_draws()` | Resample `draws` objects according to provided weights | | `thin_draws()` | Thin `draws` objects to reduce size and autocorrelation | | `weight_draws()`| Add weights to draws objects, with one weight per draw, for use in subsequent weighting operations | | `extract_variable()` | Extract a vector of draws of a single variable | | `extract_variable_matrix()` | Extract an iterations x chains matrix of draws of a single variable | | `merge_chains()` | Merge chains of `draws` objects into a single chain. | | `split_chains()` | Split chains of `draws` objects by halving the number of iterations per chain and doubling the number of chains. | If you have suggestions for additional methods that would be useful for working with `draws` objects, please open an issue at . ## References Gelman A., Carlin J. B., Stern H. S., David B. Dunson D. B., Aki Vehtari A., & Rubin D. B. (2013). *Bayesian Data Analysis, Third Edition*. Chapman and Hall/CRC. Vehtari A., Gelman A., Simpson D., Carpenter B., & Bürkner P. C. (2020). Rank-normalization, folding, and localization: An improved Rhat for assessing convergence of MCMC. *Bayesian Analysis*. posterior/vignettes/rvar.Rmd0000755000175000017500000004331614165314652016101 0ustar nileshnilesh--- title: "rvar: The Random Variable Datatype" author: "Matthew Kay" date: "`r Sys.Date()`" output: html_vignette: toc: yes vignette: > %\VignetteIndexEntry{rvar: The Random Variable Datatype} %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} --- ## Introduction This vignette describes the `rvar()` datatype, a multidimensional, sample-based representation of random variables designed to act as much like base R arrays as possible (e.g., by supporting many math operators and functions). This format is also the basis of the `draws_rvars()` format. The `rvar()` datatype is inspired by the [rv](https://cran.r-project.org/package=rv) package and [Kerman and Gelman (2007)](https://doi.org/10.1007%2Fs11222-007-9020-4), though with a slightly different backing format (multidimensional arrays). It is also designed to interoperate with vectorized distributions in the [distributional](https://pkg.mitchelloharawild.com/distributional/) package, to be able to be used inside `data.frame()`s and `tibble()`s, and to be used with distribution visualizations in the [ggdist](https://mjskay.github.io/ggdist/) package. ```{r setup, include = FALSE} library(posterior) set.seed(1234) ``` ## The `rvars` datatype The `rvar()` datatype is a wrapper around a multidimensional array where the first dimension is the number of draws in the random variable. The most direct way to create a random variable is to pass such an array to the `rvar()` function. For example, to create a "scalar" `rvar`, one would pass a one-dimensional array or a vector whose length (here `4000`) is the desired number of draws: ```{r x_rvar_rnorm} x <- rvar(rnorm(4000, mean = 1, sd = 1)) x ``` The default display of an `rvar` shows the mean and standard deviation of each element of the array. We can create random vectors by adding an additional dimension beyond just the draws dimension to the input array: ```{r x_rvar_array} n <- 4 # length of output vector x <- rvar(array(rnorm(4000*n, mean = 1, sd = 1), dim = c(4000, n))) x ``` Or we can create a random matrix: ```{r x_matrix} rows <- 4 cols <- 3 x <- rvar(array(rnorm(4000 * rows * cols, mean = 1, sd = 1), dim = c(4000, rows, cols))) x ``` Or any array up to an arbitrary number of dimensions. The array backing an `rvar` can be accessed (and modified, with caution) via `draws_of()`: ```{r str_draws} str(draws_of(x)) ``` While the above examples assume all draws come from a single chain, `rvar`s can also contain samples from multiple chains. For example, if your array of draws has iterations as the first dimension and chains as the second dimension, you can use `with_chains = TRUE` to create an `rvar` that includes chain information: ```{r x_matrix_with_chains} iterations <- 1000 chains <- 4 rows <- 4 cols <- 3 x_array <- array( rnorm(iterations * chains * rows * cols, mean = 1, sd = 1), dim = c(iterations, chains, rows, cols) ) x <- rvar(x_array, with_chains = TRUE) x ``` Manual construction and modification of `rvar`s in this way is not always recommended unless you need it for performance reasons: several other higher-level interfaces to constructing and manipulating `rvar`s are described below. ## The `draws_rvars` datatype The `draws_rvars()` datatype, like all `draws` datatypes in posterior, contains multiple variables in a joint sample from some distribution (e.g. a posterior or prior distribution). You can construct `draws_rvars()` objects directly using the `draws_rvars()` function. The input `rvar`s must have the same number of chains and iterations, but can otherwise have different shapes: ```{r draws_rvars} d <- draws_rvars(x = x, y = rvar(rnorm(iterations * chains), nchains = 4)) d ``` Existing objects can also be converted to the `draws_rvars()` format using `as_draws_rvars()`. Below is the `example_draws("multi_normal")` dataset converted into the `draws_rvars()` format. This dataset has 100 iterations from 4 chains from the posterior of a a 3-dimensional multivariate normal model. The `mu` variable is a mean vector of length 3 and the `Sigma` variable is a $3 \times 3$ covariance matrix: ```{r post} post <- as_draws_rvars(example_draws("multi_normal")) post ``` The `draws_rvars()` datatype works much the same way that other `draws` formats do; see the main package vignette at `vignette("posterior")` for an introduction to `draws` objects. One difference is that `draws_rvars` counts variables differently, because it allows variables to be multidimensional. For example, the `post` object above contains two variables, `mu` and `Sigma`: ```{r variables_draws_rvars} variables(post) ``` But converted to a `draws_list()`, it contains one variable for each combination of the dimensions of its variables: ```{r variables_draws_list} variables(as_draws_list(post)) ``` ## Math with `rvar`s The `rvar()` datatype implements most math operations, including basic arithmetic, functions in the *Math* and *Summary* groups, like `log()` and `exp()` (see `help("groupGeneric")` for a list), and more. Binary operators can be performed between multiple `rvar`s or between `rvar`s and `numeric`s. A simple example: ```{r mu_plus_1} mu <- post$mu Sigma <- post$Sigma mu + 1 ``` Matrix multiplication is also implemented (using a tensor product under the hood). Because the normal matrix multiplication operator in R (`%*%`) cannot be properly implemented for S3 datatypes, `rvar` uses `%**%` instead. A trivial example: ```{r matrix_mult} Sigma %**% diag(1:3) ``` The set of mathematical functions and operators supported by `rvar`s includes: | Group | Functions and operators | |:----------------------------|:------------------------| | Arithmetic operators | `+`, `-`, `*`, `/`, `^`, `%%`, `%/%` | | Logical operators | `&`, `|`, `!` | | Comparison operators | `==`, `!=`, `<`, `<=`, `>=`, `>` | | Matrix multiplication | `%**%` | | Basic functions | `abs()`, `sign()`
`sqrt()`
`floor()`, `ceiling()`, `trunc()`, `round()`, `signif()` | | Logarithms and exponentials | `exp()`, `expm1()`
`log()`, `log10()`, `log2()`, `log1p()` | | Trigonometric functions | `cos()`, `sin()`, `tan()`
`cospi()`, `sinpi()`, `tanpi()`
`acos()`, `asin()`, `atan()`| | Hyperbolic functions | `cosh()`, `sinh()`, `tanh()`
`acosh()`, `asinh()`, `atanh()` | | Special functions | `lgamma()`, `gamma()`, `digamma()`, `trigamma()` | | Cumulative functions | `cumsum()`, `cumprod()`, `cummax()`, `cummin()` | | Array transposition | `t()`, `aperm()` | | Matrix decomposition | `chol()` | ## Expectations and summary functions The `E()` function is an alias of `mean()`, producing means within each cell of an `rvar`. For example, given `mu`: ```{r mu} mu ``` We can get the expectation of each cell of `mu`: ```{r E_mu} E(mu) ``` Expectations of logical expressions are probabilities, and can be computed either with `E()` / `mean()` or with `Pr()`. `Pr()` is provided as notational sugar, but also checks that the input is a logical variable before taking the mean: ```{r Pr} Pr(mu > 0) ``` More generally, the `rvar` data type provides two types of summary functions: 1. Summary functions that mimic base-R vector summary functions, except applied to `rvar` vectors. These apply their summaries **over** elements of the input vectors **within** each draw, generally returning an `rvar` of length 1. These functions are prefixed with `rvar_` as a reminder that they return `rvar`s. Here is an example of `rvar_mean()`: ```{r rvar_mean_mu} rvar_mean(mu) ``` 2. Summary functions that summarise **within** elements of input vectors and **over** draws. These summary functions generally return base arrays (`numeric` or `logical`) of the same shape as the input `rvar`, and are especially useful for diagnostic summaries. These summary functions are not prefixed with `rvar_` as they do not return `rvar`s. Here is an example of `mean()`: ```{r mean_mu} mean(mu) ``` You should expect the same values from these functions (though in a different shape) when you use them with `summarise_draws()`, for example: ```{r summarise_draws_mu_mean} summarise_draws(mu, mean) ``` Here is a table of both types of summary functions: | | 1. Summarise *within* draws,
*over* elements | 2. Summarise *over* draws,
*within* elements
| |--------------------------|:------------------------------------------------|:----------------------------------------------------| | **Output format**
of `res = f(x)` | `rvar` of length 1 | `array` of same shape as input `rvar` | | **Help page** | `help("rvar-summaries-within-draws")` | `help("rvar-summaries-over-draws")` | | Numeric summaries | `rvar_median()`
`rvar_sum()`, `rvar_prod()`
`rvar_min()`, `rvar_max()`| `median()`
`sum()`, `prod()`
`min()`, `max()`| | Mean | `rvar_mean()`
*N/A* | `mean()`, `E()`
`Pr()`: enforces that input is `logical` | | Spread | `rvar_sd()`
`rvar_var()`
`rvar_mad()` | `sd()`
`var()`, `variance()`
`mad()`| | Range | `rvar_range()`
**Note:** `length(res) == 2` | `range()`
**Note:** `dim(res) == c(2, dim(x))` | | Quantiles | `rvar_quantile()`
**Note:** `length(res) == length(probs)` | `quantile()`
**Note:** `dim(res) == c(length(probs), dim(x))` | | Logical summaries | `rvar_all()`, `rvar_any()` | `all()`, `any()` | | Special value predicates | `rvar_is_finite()`
`rvar_is_infinite()`
`rvar_is_nan()`
`rvar_is_na()`
**Note:** `dim(res) == dim(x)`. These functions act within draws but do not summarise over elements. | `is.finite()`
`is.infinite()`
`is.nan()`
`is.na()`
**Note:** `res[i] == TRUE` if `x[i]` has any draws matching predicate (except for `is.finite()`, where all draws in `x[i]` must match) | | Diagnostics | *N/A* | `ess_basic()`, `ess_bulk()`, `ess_quantile()`, `ess_sd()`, `ess_tail()`,
`mcse_mean()`, `mcse_quantile()`, `mcse_sd()`
`rhat()`, `rhat_basic()`| ## Constants Constant `rvar`s can be constructed by converting numeric vectors or arrays into `rvar`s using `as_rvar()`, which will return an `rvar` with one draw and the same dimensions as its input: ```{r const} const <- as_rvar(1:3) const ``` While normally `rvar`s must have the same number of draws to be used in the same expression, `rvar`s with one draw are treated like constants, and can be combined with other `rvar`s: ```{r mu_plus_const} mu + const ``` ## Using existing R functions and expressions with `rvar`s While `rvar`s attempt to emulate as much of the functionality of base R arrays as possible, there are situations in which an existing R function may not work directly with an `rvar`. There are several approaches to solving this problem. For example, say you wish to generate samples from the following expression for $\mu$, $\sigma$, and $x$: $$ \begin{align} \left[\begin{matrix}\mu_1 \\ \vdots \\ \mu_4 \end{matrix}\right] &\sim \textrm{Normal}\left(\left[\begin{matrix}1 \\ \vdots \\ 4 \end{matrix}\right],1\right)\\ \sigma &\sim \textrm{Gamma}(1,1)\\ \left[\begin{matrix}x_1 \\ \vdots \\ x_4 \end{matrix}\right] &\sim \textrm{Normal}\left(\left[\begin{matrix}\mu_1 \\ \vdots \\ \mu_4 \end{matrix}\right], \sigma\right) \end{align} $$ There are three different approaches you might take to doing this: converting existing R functions with `rfun()`, executing expressions of random variables with `rdo()`, or evaluating random number generator functions using `rvar_rng()`. ### Converting functions with `rfun()` The `rfun()` wrapper converts an existing R function into a new function that `rvar`s can be passed to it as arguments, and which will return `rvar`s. We can use `rfun()` to convert the base `rnorm()` and `rgamma()` random number generating functions into functions that accept and return `rvar`s: ```{r rfun_defs} rvar_norm <- rfun(rnorm) rvar_gamma <- rfun(rgamma) ``` Then we can translate the above example into code using those functions: ```{r rfun_ex} mu <- rvar_norm(4, mean = 1:4, sd = 1) sigma <- rvar_gamma(1, shape = 1, rate = 1) x <- rvar_norm(4, mu, sigma) x ``` While `rfun()`-converted functions work well for prototyping, they will generally speaking be slower than functions designed specifically for `rvar`s. Thus, you may find you need to adopt other strategies (like `rvar_rng()`, described below; or re-writing functions to support `rvar` directly using math operators and/or the `draws_of()` function). ### Evaluating expressions with `rdo()` An alternative to `rfun()` is to use `rdo()`, which can be passed nearly-arbitrary R expressions. The expression will be executed multiple times to construct an `rvar`. E.g., we can write an expression for `mu` like in the above example: ```{r mu_rdo} mu <- rdo(rnorm(4, mean = 1:4, sd = 1)) mu ``` We can also control the number of draws using the `ndraws` argument: ```{r mu_rdo_ndraws} mu <- rdo(rnorm(4, mean = 1:4, sd = 1), ndraws = 1000) mu ``` `rdo()` expressions can also contain other `rvar`s, so long as all `rvar`s in the expression have the same number of draws. Thus, we can re-write the example above that used `rfun()` as follows: ```{r rdo_ex} mu <- rdo(rnorm(4, mean = 1:4, sd = 1)) sigma <- rdo(rgamma(1, shape = 1, rate = 1)) x <- rdo(rnorm(4, mu, sigma)) x ``` Like `rfun()`, `rdo()` is not necessarily fast, so you may find it more useful for prototyping than production code. ### Evaluating random number generators with `rvar_rng()` `rvar_rng()` is an alternative to `rfun()`/`rdo()` designed specifically to work with random number generating functions that follow the typical API of such functions in base R. Such functions, like `rnorm()`, `rgamma()`, `rbinom()`, etc all following this interface: - They have a first argument, `n`, giving the number of draws to take from the distribution. - Their arguments for distribution parameters (`mean`, `sd`, `shape`, `rate`, etc.) are vectorized. - They return a single vector of length `n`, representing `n` draws from the distribution. You can use any function with this interface with `rvar_rng()`, and it will adapt it to be able to take `rvar` arguments and return an `rvar`, as follows: ```{r rvar_r_ex} mu <- rvar_rng(rnorm, 4, mean = 1:4, sd = 1) sigma <- rvar_rng(rgamma, 1, shape = 1, rate = 1) x <- rvar_rng(rnorm, 4, mu, sigma) x ``` In contrast to the `rfun()` and `rdo()` examples above, `rvar_rng()` takes advantage of the existing vectorization of the underlying random number generating function to execute quickly. ## Broadcasting Broadcasting for `rvar`s does not follow R's vector recycling rules. Instead, when two variables with different dimensions are being used with basic arithmetic functions, dimensions are added until both variables have the same number of dimensions. If two variables $x$ and $y$ differ on the length of dimension $d$, they can be broadcast to the same size so long as one of the variables has dimension $d$ of size 1. Then that variable will be broadcast up to the same size as the other variable along that dimension. If two variables disagree on the size of a dimension and neither has size 1, it is an error. For example, consider this random matrix: ```{r X_matrix} X <- rdo(rnorm(12, 1:12), dim = c(4,3)) X ``` And this vector of length 3: ```{r y_vector} y <- rdo(rnorm(3, 3:1)) y ``` If we attempt to add `X` and `y`, it will produce an error as vectors are by default treated as column vectors, and `y` has length 3 while columns of `X` have length 4: ```{r X_plus_y, error = TRUE} X + y ``` By contrast, R arrays of the same shape will simply recycle `y` until it is the same length as `X` (regardless of the dimensions). Thus will produce a result, though likely not the intended result: ```{r mean_X_plus_y} mean(X) + mean(y) ``` On the other hand, if y were a row vector... ```{r row_y} row_y = t(y) row_y ``` ...it would have the same number of columns as `X` and contain only one row, so it can be broadcast along rows of `X`: ```{r X_plus_row_y} X + row_y ``` ## Applying functions over `rvar`s The `rvar` data type supplies an implementation of `as.list()`, which should give compatibility with the base R family of functions for applying functions over arrays: `apply()`, `lapply()`, `vapply()`, `sapply()`, etc. You can also manually use `as.list()` to convert an `rvar` into a list along its first dimension, which may be necessary for compatibility with some functions (like `purrr:map()`). For example, given this multidimensional `rvar`... ```{r multidim_array} set.seed(3456) x <- rvar_rng(rnorm, 24, mean = 1:24) dim(x) <- c(2,3,4) x ``` ... you can apply functions along the margins using `apply()` (here, a silly example): ```{r apply} apply(x, c(1,2), length) ``` One exception is that while `apply()` will work with an `rvar` input if your function returns base data types (like numerics), it will not give you simplified `rvar` arrays if your function returns an `rvar`. Thus, we supply the `rvar_apply()` function, which takes in either base arrays or `rvar` arrays and returns `rvar` arrays, and which also uses the `rvar` broadcasting rules to combine the results of the applied function. For example, you can use `rvar_apply()` with `rvar_mean()` to compute the distributions of means along one margin of an array: ```{r rvar_apply_one_dim} rvar_apply(x, 1, rvar_mean) ``` Or along multiple dimensions: ```{r rvar_apply_multi_dim} rvar_apply(x, c(2,3), rvar_mean) ``` ## Using `rvar`s in data frames and in ggplot2 `rvar`s can be used as columns in `data.frame()` or `tibble()` objects: ```{r data_frame_with_y} data.frame(x = c("a","b","c"), y) ``` This makes them convenient for adding predictions to a data frame alongside the data used to generate the predictions. `rvar`s can then be visualized with ggplot2 using the `stat_dist_...` family of geometries in the [ggdist](https://mjskay.github.io/ggdist/) package. posterior/build/0000755000175000017500000000000014165340154013534 5ustar nileshnileshposterior/build/vignette.rds0000644000175000017500000000037314165340154016076 0ustar nileshnileshuˮ0E$.6>qsBq;F%%Ѹ;O.Ъ\ocƘ\fC3'8OKQ)A'_؞?xKpD}lV)HDw Sː@J8{m?yIhv n,=eP@4tif6ئ8Z1 "nv"_k`Med꺾*3" }cpObqtposterior/tests/0000755000175000017500000000000014165314652013603 5ustar nileshnileshposterior/tests/testthat/0000755000175000017500000000000014165346072015444 5ustar nileshnileshposterior/tests/testthat/test-rvar-summaries-over-draws.R0000755000175000017500000001166514165314652023623 0ustar nileshnilesh# numeric summaries ------------------------------------------------------- test_that("numeric summaries work", { x_array <- array(1:24, dim = c(4,2,3), dimnames = list(NULL, a = c("a1", "a2"), b = c("b1", "b2", "b3"))) x <- new_rvar(x_array) expect_equal(median(x), apply(x_array, c(2,3), median)) expect_equal(sum(x), apply(x_array, c(2,3), sum)) expect_equal(prod(x), apply(x_array, c(2,3), prod)) expect_equal(min(x), apply(x_array, c(2,3), min)) expect_equal(max(x), apply(x_array, c(2,3), max)) }) # mean -------------------------------------------------------------------- test_that("means work", { x_array <- array(1:24, dim = c(4,2,3), dimnames = list(NULL, a = c("a1", "a2"), b = c("b1", "b2", "b3"))) x <- new_rvar(x_array) expect_equal(Pr(x < 2), apply(x_array < 2, c(2,3), mean)) expect_error(Pr(x)) expect_equal(E(x), apply(x_array, c(2,3), mean)) expect_equal(mean(x), apply(x_array, c(2,3), mean)) # E() and Pr() should also work on base arrays expect_equal(Pr(x_array < 2), mean(x_array < 2)) expect_error(Pr(x_array)) expect_equal(E(x_array), mean(x_array)) # test vector rvars as well since these should be summarized down to vectors # (not one-dimensional arrays) y_array <- array(1:24, dim = c(4,6), dimnames = list(NULL, paste0("a", 1:6))) y <- new_rvar(y_array) expect_equal(mean(y), apply(y_array, 2, mean)) }) # spread ------------------------------------------------------------------ test_that("spread functions work", { x_array <- array(1:24, dim = c(4,2,3), dimnames = list(NULL, a = c("a1", "a2"), b = c("b1", "b2", "b3"))) x <- new_rvar(x_array) expect_equal(sd(x), apply(x_array, c(2,3), sd)) expect_equal(variance(x), apply(x_array, c(2,3), var)) expect_equal(var(x), apply(x_array, c(2,3), var)) expect_equal(mad(x), apply(x_array, c(2,3), mad)) y_array <- array(1:24, dim = c(4,6), dimnames = list(NULL, paste0("a", 1:6))) y <- new_rvar(y_array) expect_equal(sd(y), apply(y_array, 2, sd)) expect_equal(variance(y), apply(y_array, 2, var)) expect_equal(var(y), apply(y_array, 2, var)) expect_equal(mad(y), apply(y_array, 2, mad)) }) # range ------------------------------------------------------------------- test_that("range works", { x_array <- array(1:24, dim = c(4,2,3), dimnames = list(NULL, a = c("a1", "a2"), b = c("b1", "b2", "b3"))) x <- new_rvar(x_array) expect_equal(range(x), apply(x_array, c(2,3), range)) y_array <- array(1:24, dim = c(4,6), dimnames = list(NULL, paste0("a", 1:6))) y <- new_rvar(y_array) expect_equal(range(y), apply(y_array, 2, range)) # range over a scalar should return a vector z_array <- array(1:6, dim = c(6,1), dimnames = list(NULL, "a")) z <- new_rvar(z_array) expect_equal(range(z), range(z_array)) }) # logical summaries ------------------------------------------------------- test_that("logical summaries work", { x_array <- array(1:24, dim = c(4,2,3), dimnames = list(NULL, a = c("a1", "a2"), b = c("b1", "b2", "b3"))) x <- new_rvar(x_array) expect_equal(all(x > 10), apply(x_array > 10, c(2,3), all)) expect_equal(any(x > 10), apply(x_array > 10, c(2,3), any)) y_array <- array(1:24, dim = c(4,6), dimnames = list(NULL, paste0("a", 1:6))) y <- new_rvar(y_array) expect_equal(all(y > 10), apply(y_array > 10, 2, all)) expect_equal(any(y > 10), apply(y_array > 10, 2, any)) }) # special value predicates ------------------------------------------------ test_that("special value predicates work", { x_array <- array(c(1,NA,3:4, 5:6,Inf,8, 9,-Inf,11:12, NaN,14:24), dim = c(4,2,3), dimnames = list(NULL, a = c("a1", "a2"), b = c("b1", "b2", "b3")) ) x <- new_rvar(x_array) .dimnames = list(a = c("a1", "a2"), b = c("b1", "b2", "b3")) expect_equal(is.finite(x), array(c(rep(FALSE, 4), rep(TRUE, 2)), dim = c(2,3), dimnames = .dimnames)) expect_equal(is.infinite(x), array(c(FALSE, TRUE, TRUE, FALSE, FALSE, FALSE), dim = c(2,3), dimnames = .dimnames)) expect_equal(is.nan(x), array(c(FALSE, FALSE, FALSE, TRUE, FALSE, FALSE), dim = c(2,3), dimnames = .dimnames)) expect_equal(is.na(x), array(c(TRUE, FALSE, FALSE, TRUE, FALSE, FALSE), dim = c(2,3), dimnames = .dimnames)) y_array <- array(x_array, dim = c(4,6), dimnames = list(NULL, paste0("a", 1:6))) y <- new_rvar(y_array) expect_equal(is.finite(y), matrixStats::colAlls(apply(y_array, 2, is.finite), useNames = TRUE)) expect_equal(is.infinite(y), matrixStats::colAnys(apply(y_array, 2, is.infinite), useNames = TRUE)) expect_equal(is.nan(y), matrixStats::colAnys(apply(y_array, 2, is.nan), useNames = TRUE)) expect_equal(is.na(y), matrixStats::colAnys(apply(y_array, 2, is.na), useNames = TRUE)) }) # anyNA ------------------------------------------------------------------- test_that("anyNA works", { x_array <- array(1:24, dim = c(4,2,3), dimnames = list(NULL, a = c("a1", "a2"), b = c("b1", "b2", "b3"))) x <- new_rvar(x_array) expect_equal(anyNA(x), FALSE) x_with_na <- x x_with_na[2,1] <- NA expect_equal(anyNA(x_with_na), TRUE) }) posterior/tests/testthat/test-as_draws.R0000644000175000017500000002670614165314655020364 0ustar nileshnileshtest_that("transformations to and from draws_matrix objects work", { draws_matrix <- as_draws_matrix(example_draws()) draws_array <- as_draws_array(draws_matrix) draws_matrix2 <- as_draws_matrix(draws_array) expect_equal(draws_matrix, draws_matrix2) draws_df <- as_draws_df(draws_matrix) draws_matrix2 <- as_draws_matrix(draws_df) expect_equal(draws_matrix, draws_matrix2) draws_list <- as_draws_list(draws_matrix) draws_matrix2 <- as_draws_matrix(draws_list) expect_equal(draws_matrix, draws_matrix2) draws_rvars <- as_draws_rvars(draws_matrix) draws_matrix2 <- as_draws_matrix(draws_rvars) expect_equal(draws_matrix, draws_matrix2) }) test_that("transformations to and from draws_array objects work", { draws_array <- as_draws_array(example_draws()) draws_matrix <- as_draws_matrix(draws_array) draws_array2 <- as_draws_array(draws_matrix) expect_equal(draws_array, draws_array2) draws_df <- as_draws_df(draws_array) draws_array2 <- as_draws_array(draws_df) expect_equal(draws_array, draws_array2) draws_list <- as_draws_list(draws_array) draws_array2 <- as_draws_array(draws_list) expect_equal(draws_array, draws_array2) draws_rvars <- as_draws_rvars(draws_array) draws_array2 <- as_draws_array(draws_rvars) expect_equal(draws_array, draws_array2) }) test_that("transformations to and from draws_df objects work", { draws_df <- as_draws_df(example_draws()) draws_matrix <- as_draws_matrix(draws_df) draws_df2 <- as_draws_df(draws_matrix) expect_equal(draws_df, draws_df2) draws_array <- as_draws_array(draws_df) draws_df2 <- as_draws_df(draws_array) expect_equal(draws_df, draws_df2) draws_list <- as_draws_list(draws_df) draws_df2 <- as_draws_df(draws_list) expect_equal(draws_df, draws_df2) draws_rvars <- as_draws_rvars(draws_df) draws_df2 <- as_draws_df(draws_rvars) expect_equal(draws_df, draws_df2) # test that a single draw does not lead to a drop of dimensions draws_rvars2 <- subset_draws(draws_rvars, draw = 1) draws_df2 <- as_draws_df(draws_rvars2) expect_equal(subset_draws(draws_df, draw = 1), draws_df2) }) test_that("transformations to and from draws_list objects work", { draws_list <- as_draws_list(example_draws()) draws_matrix <- as_draws_matrix(draws_list) draws_list2 <- as_draws_list(draws_matrix) expect_equal(draws_list, draws_list2) draws_array <- as_draws_array(draws_list) draws_list2 <- as_draws_list(draws_array) expect_equal(draws_list, draws_list2) draws_df <- as_draws_df(draws_list) draws_list2 <- as_draws_list(draws_df) expect_equal(draws_list, draws_list2) draws_rvars <- as_draws_rvars(draws_list) draws_list2 <- as_draws_list(draws_rvars) expect_equal(draws_list, draws_list2) }) test_that("transformations to and from draws_rvars objects work", { draws_rvars <- as_draws_rvars(example_draws()) draws_matrix <- as_draws_matrix(draws_rvars) draws_rvars2 <- as_draws_rvars(draws_matrix) expect_equal(draws_rvars, draws_rvars2) draws_array <- as_draws_array(draws_rvars) draws_rvars2 <- as_draws_rvars(draws_array) expect_equal(draws_rvars, draws_rvars2) draws_df <- as_draws_df(draws_rvars) draws_rvars2 <- as_draws_rvars(draws_df) expect_equal(draws_rvars, draws_rvars2) draws_list <- as_draws_list(draws_rvars) draws_rvars2 <- as_draws_rvars(draws_list) expect_equal(draws_rvars, draws_rvars2) }) test_that("matrices can be transformed to draws_matrix objects", { x <- round(rnorm(200), 2) x <- array(x, dim = c(40, 5)) dimnames(x) <- list(NULL, paste0("theta", 1:5)) y <- as_draws(x) expect_is(y, "draws_matrix") expect_equal(variables(y), colnames(x)) expect_equal(niterations(y), 40) expect_equal(nchains(y), 1) }) test_that("arrays can be transformed to draws_array objects", { x <- round(rnorm(200), 2) x <- array(x, dim = c(10, 4, 5)) dimnames(x) <- list(NULL, NULL, paste0("theta", 1:5)) y <- as_draws(x) expect_is(y, "draws_array") expect_equal(variables(y), dimnames(x)[[3]]) expect_equal(niterations(y), 10) expect_equal(nchains(y), 4) }) test_that("data.frames can be transformed to draws_df objects", { x <- data.frame( v1 = rnorm(100), v2 = rnorm(100) ) y <- as_draws(x) expect_is(y, "draws_df") expect_equal(variables(y), names(x)) expect_equal(niterations(y), 100) expect_equal(nchains(y), 1) # are .iteration and .chain automatically used? x2 <- x x2$.iteration <- 1:100 x2$.chain <- rep(1:4, each = 25) y2 <- as_draws(x2) expect_is(y2, "draws_df") expect_equal(variables(y2), names(x)) expect_equal(niterations(y2), 25) expect_equal(nchains(y2), 4) }) test_that("lists can be transformed to draws_list objects", { x <- list( list( v1 = rnorm(50), v2 = rnorm(50) ), list( v1 = rnorm(50), v2 = rnorm(50) ) ) y <- as_draws(x) expect_is(y, "draws_list") expect_equal(variables(y), names(x[[1]])) expect_equal(ndraws(y), 100) expect_equal(nchains(y), 2) }) test_that("numeric vectors can be transformed to draws_matrix objects", { draws_matrix <- draws_matrix(a = 1:10, b = 11:20, c = 1) draws_matrix2 <- as_draws_matrix(cbind(1:10, 11:20, 1)) expect_equivalent(draws_matrix, draws_matrix2) }) test_that("numeric vectors can be transformed to draws_array objects", { draws_array <- draws_array(a = 1:10, b = 11:20, c = 1, .nchains = 2) draws_array2 <- array(c(1:10, 11:20, rep(1, 10)), c(5, 2, 3)) dimnames(draws_array2)[[3]] <- c("a", "b", "c") draws_array2 <- as_draws_array(draws_array2) expect_equal(draws_array, draws_array2) }) test_that("numeric vectors can be transformed to draws_df objects", { draws_df <- draws_df(a = 1:10, b = 11:20, c = 1, .nchains = 2) draws_array <- array(c(1:10, 11:20, rep(1, 10)), c(5, 2, 3)) dimnames(draws_array)[[3]] <- c("a", "b", "c") draws_df2 <- as_draws_df(draws_array) expect_equal(draws_df, draws_df2) }) test_that("numeric vectors can be transformed to draws_list objects", { draws_list <- draws_list(a = 1:10, b = 11:20, c = 1, .nchains = 2) draws_array <- array(c(1:10, 11:20, rep(1, 10)), c(5, 2, 3)) dimnames(draws_array)[[3]] <- c("a", "b", "c") draws_list2 <- as_draws_list(draws_array) expect_equal(draws_list, draws_list2) }) test_that("numeric vectors can be transformed to draws_rvars objects", { draws_rvars <- draws_rvars(a = 1:10, b = 11:20, c = 1, .nchains = 2) draws_array <- array(c(1:10, 11:20, rep(1, 10)), c(5, 2, 3)) dimnames(draws_array)[[3]] <- c("a", "b", "c") draws_rvars2 <- as_draws_rvars(draws_array) expect_equal(draws_rvars, draws_rvars2) }) test_that("rvars can be transformed to draws objects", { rv_array <- array(c(1:10, 11:20, rep(1, 10)), c(5, 2, 3)) rv <- rvar(rv_array) draws_rvars <- draws_rvars(x = rv) expect_equal(as_draws(rv), draws_rvars) expect_equal(as_draws_rvars(rv), draws_rvars) expect_equal(as_draws_matrix(rv), as_draws_matrix(draws_rvars)) expect_equal(as_draws_array(rv), as_draws_array(draws_rvars)) expect_equal(as_draws_df(rv), as_draws_df(draws_rvars)) expect_equal(as_draws_list(rv), as_draws_list(draws_rvars)) }) test_that("mcmc and mcmc.list objects can be transformed to draws objects", { # don't want to add coda as dependency so construct equivalent of # mcmc and mcmc.list objects x1 <- matrix(1:20, 10, 2) x2 <- matrix(21:40, 10, 2) dimnames(x1) <- dimnames(x2) <- list(1:10, c("A", "B")) attr(x1, "mcpar") <- attr(x2, "mcpar") <- c(1, 10, 1) class(x1) <- class(x2) <- "mcmc" xlist <- structure(list(x1 = x1, x2 = x2), class = "mcmc.list") mcmc_draws <- list( as_draws(x1), as_draws_matrix(x1), as_draws_array(x1), as_draws_df(x1), as_draws_list(x1), as_draws_rvars(x1) ) mcmc_list_draws <- list( as_draws(xlist), as_draws_matrix(xlist), as_draws_array(xlist), as_draws_df(xlist), as_draws_list(xlist), as_draws_rvars(xlist) ) for (j in seq_along(mcmc_draws)) { xj <- mcmc_draws[[j]] expect_equal(ndraws(xj), 10) expect_equal(nvariables(xj), 2) expect_equal(nchains(xj), 1) expect_equal(variables(xj), c("A", "B")) xj <- mcmc_list_draws[[j]] expect_equal(ndraws(xj), 20) expect_equal(nchains(xj), 2) expect_equal(nvariables(xj), 2) expect_equal(variables(xj), c("A", "B")) } }) test_that("empty draws objects can be converted", { empty_draws <- list( empty_draws_matrix(), empty_draws_array(), empty_draws_list(), empty_draws_df(), empty_draws_rvars() ) for (j in seq_along(empty_draws)) { # basically just check they don't error and preserve 0 draws empty_j <- empty_draws[[j]] expect_equal(ndraws(as_draws_matrix(empty_j)), 0) expect_equal(ndraws(as_draws_array(empty_j)), 0) expect_equal(ndraws(as_draws_df(empty_j)), 0) expect_equal(ndraws(as_draws_list(empty_j)), 0) expect_equal(ndraws(as_draws_rvars(empty_j)), 0) } }) test_that("as_draws throws appropriate error if no close format", { expect_error( as_draws("A"), "Don't know how to transform an object of class 'character'" ) expect_error( as_draws(TRUE), "Don't know how to transform an object of class 'logical'" ) }) test_that("draws_* constructors throw correct errors", { expect_error(draws_array(a = 1, .nchains = 0), "Number of chains must be positive") expect_error(draws_df(a = 1, .nchains = 0), "Number of chains must be positive") expect_error(draws_list(a = 1, .nchains = 0), "Number of chains must be positive") expect_error(draws_array(a = 1, .nchains = 2), "Number of chains does not divide the number of draws") expect_error(draws_df(a = 1, .nchains = 2), "Number of chains does not divide the number of draws") expect_error(draws_list(a = 1, .nchains = 2), "Number of chains does not divide the number of draws") }) test_that("as_draws_rvars correctly reshapes missing, out-of-order, and string array indices", { x_array <- as_draws_array(example_draws()) variables(x_array) <- paste0("var[", rep(1:2, each = 5), ",", rep(1:5, 2), "]") x_rvars <- as_draws_rvars(x_array) x_array2 <- remove_variables(x_array, "var[2,3]") x_rvars2 <- x_rvars x_rvars2$var[2,3] <- NA expect_equal(as_draws_rvars(x_array2), x_rvars2) x_array2 <- subset_draws(x_array, variable = c("var[1,4]", "var[2,3]")) x_rvars2 <- x_rvars x_rvars2$var <- x_rvars2$var[1:2,1:4] x_rvars2$var[1,1:3] <- NA x_rvars2$var[2,c(1:2,4)] <- NA expect_equal(as_draws_rvars(x_array2), x_rvars2) x_rvars2 <- x_rvars rownames(x_rvars2$var) <- letters[1:2] colnames(x_rvars2$var) <- rev(letters[1:5]) expect_equal(as_draws_rvars(as_draws_array(x_rvars2)), x_rvars2) }) test_that("as_draws_rvars can accept lists of lists as input", { # for https://github.com/stan-dev/posterior/issues/192 draws_list <- as_draws_list(example_draws()) list_of_lists <- unclass(draws_list) expect_equal(as_draws_rvars(example_draws()), as_draws_rvars(list_of_lists)) }) test_that("draws_df does not munge variable names", { draws_df <- draws_df(`x[1]` = 1:2, `x[2]` = 3:4) expect_equal(variables(draws_df), c("x[1]", "x[2]")) }) test_that("draws_df can roundtrip through data.frame", { draws_df <- draws_df(`x[1]` = 1:2, `x[2]` = 3:4) expect_equal(as_draws_df(as.data.frame(draws_df)), draws_df) expect_equal(as_draws_df(tibble::as_tibble(draws_df)), draws_df) draws_dataframe <- as.data.frame(draws_df) draws_dataframe$.draw <- NULL expect_equal(as_draws_df(draws_dataframe), draws_df) }) test_that("draws_df drops the draws class when metadata is removed", { draws_df <- as_draws_df(example_draws()) expect_equal(dplyr::count(draws_df, .chain), tibble::tibble(.chain = 1:4, n = 100L)) }) posterior/tests/testthat/test-print.R0000644000175000017500000000662714165314655017715 0ustar nileshnileshtest_that("print.draws_matrix runs without errors", { x <- as_draws_matrix(example_draws()) expect_output(print(x), "A draws_matrix: 100 iterations, 4 chains, and 10 variables" ) x <- weight_draws(x, rep(1, ndraws(x))) expect_output(print(x), "hidden reserved variables \\{'\\.log_weight'\\}") }) test_that("print.draws_array runs without errors", { x <- as_draws_array(example_draws()) expect_output(print(x), "A draws_array: 100 iterations, 4 chains, and 10 variables" ) x <- weight_draws(x, rep(1, ndraws(x))) expect_output(print(x), "hidden reserved variables \\{'\\.log_weight'\\}") }) test_that("print.draws_df runs without errors", { x <- as_draws_df(example_draws()) expect_output(print(x), "A draws_df: 100 iterations, 4 chains, and 10 variables" ) x <- weight_draws(x, rep(1, ndraws(x))) expect_output(print(x), "'\\.log_weight'") x <- subset(x, variable = c("mu", "tau")) x <- mutate_variables(x, tau2 = tau^2) expect_output(print(x), "tau2") }) test_that("print.draws_list runs without errors", { x <- as_draws_list(example_draws()) expect_output(print(x), "A draws_list: 100 iterations, 4 chains, and 10 variables" ) x <- weight_draws(x, rep(1, ndraws(x))) expect_output(print(x), "hidden reserved variables \\{'\\.log_weight'\\}") }) test_that("print.draws_rvars runs without errors", { x <- as_draws_rvars(example_draws()) expect_output(print(x), "A draws_rvars: 100 iterations, 4 chains, and 3 variables" ) x <- weight_draws(x, rep(1, ndraws(x))) expect_output(print(x), "hidden reserved variables \\{'\\.log_weight'\\}") }) test_that("print.draws_array handles reserved variables correctly", { x <- as_draws_array(example_draws()) variables(x)[1] <- ".log_weight" # reserved name expect_output(print(x, max_variables = 1), "variable = tau") expect_output( print(x), "hidden reserved variables {'.log_weight'}", fixed = TRUE ) }) test_that("print.draws_matrix handles reserved variables correctly", { x <- as_draws_matrix(example_draws()) variables(x)[1] <- ".log_weight" # reserved name expect_output(print(x, max_variables = 1), "tau") expect_output( print(x), "hidden reserved variables {'.log_weight'}", fixed = TRUE ) }) test_that("print.draws_df handles reserved variables correctly", { x <- as_draws_df(example_draws()) variables(x)[1] <- ".log_weight" # reserved name expect_output(print(x, max_variables = 1), "tau") expect_output( print(x), "hidden reserved variables {'.log_weight', '.chain', '.iteration', '.draw'}", fixed = TRUE ) }) test_that("print.draws_list handles reserved variables correctly", { x <- as_draws_list(example_draws()) variables(x)[1] <- ".log_weight" # reserved name expect_output(print(x, max_variables = 1), "tau") expect_output( print(x), "hidden reserved variables {'.log_weight'}", fixed = TRUE ) }) test_that("print.draws_rvars handles reserved variables correctly", { x <- as_draws_rvars(example_draws()) variables(x)[1] <- ".log_weight" # reserved name expect_output(print(x, max_variables = 1), "tau") expect_output( print(x), "hidden reserved variables {'.log_weight'}", fixed = TRUE ) }) test_that("print.draws_df correctly handles data frames with unrepaired draws", { x <- as_draws_df(list(x = 1:10, y = 2:11)) x_slice <- x[c(1,3,5),] expect_output( print(x_slice), "x +y 1 +1 +2 2 +3 +4 3 +5 +6" ) }) posterior/tests/testthat/test-rvar-math.R0000755000175000017500000001665114165314652020460 0ustar nileshnilesh# basic operators --------------------------------------------------------- test_that("math operators works", { x_array = array(1:24, dim = c(4,2,3), dimnames = list(NULL,letters[1:2],letters[3:5])) x = new_rvar(x_array) y_array = array(c(2:13,12:1), dim = c(4,2,3)) y = new_rvar(y_array) expect_equal(log(x), new_rvar(log(x_array))) expect_equal(-x, new_rvar(-x_array)) expect_equal(x + 2, new_rvar(x_array + 2)) expect_equal(2 + x, new_rvar(x_array + 2)) expect_equal(x + y, new_rvar(x_array + y_array)) expect_equal(x - 2, new_rvar(x_array - 2)) expect_equal(2 - x, new_rvar(2 - x_array)) expect_equal(x - y, new_rvar(x_array - y_array)) expect_equal(x * 2, new_rvar(x_array * 2)) expect_equal(2 * x, new_rvar(x_array * 2)) expect_equal(x * y, new_rvar(x_array * y_array)) expect_equal(x / 2, new_rvar(x_array / 2)) expect_equal(2 / x, new_rvar(2 / x_array)) expect_equal(x / y, new_rvar(x_array / y_array)) expect_equal(x ^ 2, new_rvar((x_array) ^ 2)) expect_equal(2 ^ x, new_rvar(2 ^ (x_array))) expect_equal(x ^ y, new_rvar(x_array ^ y_array)) # ensure broadcasting of constants retains shape z2 <- new_rvar(array(1, dim = c(1,1))) z4 <- new_rvar(array(2, dim = c(1,1,1,1))) expect_equal(z2 + z4, new_rvar(array(3, dim = c(1,1,1,1)))) }) test_that("logical operators work", { x_array = c(TRUE,TRUE,FALSE,FALSE) y_array = c(TRUE,FALSE,TRUE,FALSE) x = as_rvar(x_array) y = as_rvar(y_array) expect_equal(x | y_array, as_rvar(x_array | y_array)) expect_equal(y_array | x, as_rvar(x_array | y_array)) expect_equal(x | y, as_rvar(x_array | y_array)) expect_equal(x & y_array, as_rvar(x_array & y_array)) expect_equal(y_array & x, as_rvar(x_array & y_array)) expect_equal(x & y, as_rvar(x_array & y_array)) }) test_that("comparison operators work", { x_array = array(1:24, dim = c(4,2,3)) x = new_rvar(x_array) y_array = array(c(2:13,12:1), dim = c(4,2,3)) y = new_rvar(y_array) expect_equal(x < 5, new_rvar(x_array < 5)) expect_equal(5 < x, new_rvar(5 < x_array)) expect_equal(x < y, new_rvar(x_array < y_array)) expect_equal(x <= 5, new_rvar(x_array <= 5)) expect_equal(5 <= x, new_rvar(5 <= x_array)) expect_equal(x <= y, new_rvar(x_array <= y_array)) expect_equal(x > 5, new_rvar(x_array > 5)) expect_equal(5 > x, new_rvar(5 > x_array)) expect_equal(x > y, new_rvar(x_array > y_array)) expect_equal(x >= 5, new_rvar(x_array >= 5)) expect_equal(5 >= x, new_rvar(5 >= x_array)) expect_equal(x >= y, new_rvar(x_array >= y_array)) expect_equal(x == 5, new_rvar(x_array == 5)) expect_equal(5 == x, new_rvar(5 == x_array)) expect_equal(x == y, new_rvar(x_array == y_array)) expect_equal(x != 5, new_rvar(x_array != 5)) expect_equal(5 != x, new_rvar(5 != x_array)) expect_equal(x != y, new_rvar(x_array != y_array)) }) test_that("functions in the Math generic with extra arguments work", { expect_equal(round(rvar(11), -1), rvar(10)) expect_equal(signif(rvar(11), 1), rvar(10)) expect_equal(log(rvar(c(2,4,8)), base = 2), rvar(1:3)) }) test_that("cumulative functions work", { x_array = array(1:12, dim = c(2,2,3)) x = new_rvar(x_array) cumsum_ref = new_rvar(rbind( cumsum(draws_of(x)[1,,]), cumsum(draws_of(x)[2,,]) )) expect_equal(cumsum(x), cumsum_ref) cumprod_ref = new_rvar(rbind( cumprod(draws_of(x)[1,,]), cumprod(draws_of(x)[2,,]) )) expect_equal(cumprod(x), cumprod_ref) cummax_ref = new_rvar(rbind( cummax(draws_of(x)[1,,]), cummax(draws_of(x)[2,,]) )) expect_equal(cummax(x), cummax_ref) cummin_ref = new_rvar(rbind( cummin(draws_of(x)[1,,]), cummin(draws_of(x)[2,,]) )) expect_equal(cummin(x), cummin_ref) }) # matrix stuff ------------------------------------------------------------ test_that("matrix multiplication works", { x_array = array(1:24, dim = c(4,2,3)) x = new_rvar(x_array) y_array = array(c(2:13,12:1), dim = c(4,3,2)) y = new_rvar(y_array) xy_ref = new_rvar(abind::abind(along = 0, x_array[1,,] %*% y_array[1,,], x_array[2,,] %*% y_array[2,,], x_array[3,,] %*% y_array[3,,], x_array[4,,] %*% y_array[4,,] )) expect_equal(x %**% y, xy_ref) x_array = array(1:6, dim = c(2,3)) x = new_rvar(x_array) y_array = array(7:12, dim = c(2,3)) y = new_rvar(y_array) xy_ref = new_rvar(abind::abind(along = 0, x_array[1,] %*% y_array[1,], x_array[2,] %*% y_array[2,] )) expect_equal(x %**% y, xy_ref) # automatic promotion to row/col vector of numeric vectors x_meany_ref = new_rvar(abind::abind(along = 0, x_array[1,] %*% colMeans(y_array), x_array[2,] %*% colMeans(y_array) )) expect_equal(x %**% colMeans(y_array), x_meany_ref) meanx_y_ref = new_rvar(abind::abind(along = 0, colMeans(x_array) %*% y_array[1,], colMeans(x_array) %*% y_array[2,] )) expect_equal(colMeans(x_array) %**% y, meanx_y_ref) # dimension name preservation m1 <- as_rvar(diag(1:3)) dimnames(m1) <- list(a = paste0("a", 1:3), b = paste0("b", 1:3)) m2 <- as_rvar(diag(1:3)[,1:2]) dimnames(m2) <- list(c = paste0("c", 1:3), d = paste0("d", 1:2)) expect_equal(dimnames(m1 %**% m2), list(a = paste0("a", 1:3), d = paste0("d", 1:2))) # errors x_array = array(1:24, dim = c(4,1,2,3)) x = new_rvar(x_array) expect_error(x %**% 1, "not a vector or matrix") expect_error(1 %**% x, "not a vector or matrix") }) test_that("diag works", { Sigma <- as_draws_rvars(example_draws("multi_normal"))$Sigma expect_equal(diag(Sigma), c(Sigma[1,1], Sigma[2,2], Sigma[3,3])) Sigma_ref <- Sigma Sigma_ref[1,1] <- 2 Sigma_ref[2,2] <- 3 Sigma_ref[3,3] <- 4 Sigma_test <- Sigma diag(Sigma_test) <- 2:4 expect_equal(Sigma_test, Sigma_ref) }) test_that("Cholesky decomposition works", { Sigma <- as_draws_rvars(example_draws("multi_normal"))$Sigma # adding dimensions because we should expect these to be dropped dimnames(Sigma) <- list( a = paste0("a", 1:3), b = paste0("b", 1:3) ) expect_equal(chol(Sigma), rdo(chol(Sigma))) }) # array transpose and permutation ----------------------------------------- test_that("vector transpose works", { x_array = array(1:6, dim = c(2,3), dimnames = list(NULL, c("a","b","c"))) x = new_rvar(x_array) x_array_t = array(1:6, dim = c(2,1,3), dimnames = list(NULL, NULL, c("a","b","c"))) x_t = new_rvar(x_array_t) x_array_t_t = array(1:6, dim = c(2,3,1), dimnames = list(NULL, c("a","b","c"), NULL)) x_t_t = new_rvar(x_array_t_t) # ensure it works with dimnames... expect_equal(t(x), x_t) expect_equal(t(t(x)), x_t_t) # ... and without dimnames dimnames(x) = NULL dimnames(x_t) = NULL dimnames(x_t_t) = NULL expect_equal(t(x), x_t) expect_equal(t(t(x)), x_t_t) }) test_that("matrix transpose works", { x_array = array(1:24, dim = c(4,3,2)) x = new_rvar(x_array) x_t = new_rvar(aperm(x_array, c(1,3,2))) expect_error(t(rvar())) expect_equal(t(x), x_t) expect_equal(t(new_rvar(array(1:10, c(1,10)))), new_rvar(array(1:10, c(1,1,10)))) expect_equal(t(new_rvar(array(1:10, c(2,1,5)))), new_rvar(array(1:10, c(2,5,1)))) expect_equal(t(new_rvar(array(1:10, c(2,1,5)))), new_rvar(array(1:10, c(2,5,1)))) expect_equal(t(new_rvar(array(1:10, c(2,5)))), new_rvar(array(1:10, c(2,1,5)))) }) test_that("array permutation works", { x_array = array( 1:24, dim = c(2,2,3,2), dimnames = list(NULL, A = paste0("a", 1:2), B = paste0("b", 1:3), C = paste0("c", 1:2)) ) x = new_rvar(x_array) x_perm = new_rvar(aperm(x_array, c(1,2,4,3))) expect_equal(aperm(x, c(1,3,2)), x_perm) }) posterior/tests/testthat/test-draws-index.R0000644000175000017500000000731514165314652020776 0ustar nileshnileshtest_that("indices work for NULL", { x <- NULL expect_equal(iteration_ids(NULL), NULL) expect_equal(chain_ids(NULL), NULL) expect_equal(draw_ids(NULL), NULL) expect_equal(niterations(NULL), 0) expect_equal(nchains(NULL), 0) expect_equal(ndraws(NULL), 0) }) test_that("indices of draws_matrix objects are correct", { x <- as_draws_matrix(example_draws()) expect_equal(iteration_ids(x), 1:100) expect_equal(chain_ids(x), 1:4) expect_equal(draw_ids(x), 1:NROW(x)) expect_equal(niterations(x), NROW(x) / 4) expect_equal(nchains(x), 4) expect_equal(ndraws(x), NROW(x)) rownames(x) <- NULL expect_equal(draw_ids(x), 1:NROW(x)) }) test_that("indices of draws_array objects are correct", { x <- as_draws_array(example_draws()) expect_equal(iteration_ids(x), 1:NROW(x)) expect_equal(chain_ids(x), 1:NCOL(x)) expect_equal(draw_ids(x), 1:(NROW(x) * NCOL(x))) expect_equal(niterations(x), NROW(x)) expect_equal(nchains(x), NCOL(x)) expect_equal(ndraws(x), NROW(x) * NCOL(x)) colnames(x) <- NULL rownames(x) <- NULL expect_equal(iteration_ids(x), 1:NROW(x)) expect_equal(chain_ids(x), 1:NCOL(x)) }) test_that("indices of draws_df objects are correct", { x <- as_draws_df(example_draws()) expect_equal(iteration_ids(x), unique(x$.iteration)) expect_equal(chain_ids(x), unique(x$.chain)) expect_equal(draw_ids(x), unique(x$.draw)) expect_equal(niterations(x), length(unique(x$.iteration))) expect_equal(nchains(x), length(unique(x$.chain))) expect_equal(ndraws(x), length(unique(x$.draw))) }) test_that("indices of draws_list objects are correct", { x <- as_draws_list(example_draws()) expect_equal(iteration_ids(x), 1:length(x[[1]][[1]])) expect_equal(chain_ids(x), 1:length(x)) expect_equal(draw_ids(x), 1:(length(x[[1]][[1]]) * length(x))) expect_equal(niterations(x), length(x[[1]][[1]])) expect_equal(nchains(x), length(x)) expect_equal(ndraws(x), length(x[[1]][[1]]) * length(x)) names(x) <- NULL expect_equal(chain_ids(x), 1:length(x)) }) test_that("indices of draws_rvars objects are correct", { x <- as_draws_rvars(example_draws()) expect_equal(iteration_ids(x), 1:(length(draws_of(x[[1]]))/4)) expect_equal(chain_ids(x), 1:4) expect_equal(draw_ids(x), 1:length(draws_of(x[[1]]))) expect_equal(niterations(x), length(draws_of(x[[1]]))/4) expect_equal(nchains(x), 4) expect_equal(ndraws(x), length(draws_of(x[[1]]))) }) test_that("indexing draws_array with [ and drop works correctly", { x <- example_draws() x1 <- x[,,1] x2 <- x[,,1, drop=TRUE] expect_s3_class(x1, "draws_array") if (R.version$major >= "4") { expect_equal(class(x2), c("matrix", "array")) } else { expect_equal(class(x2), "matrix") } expect_length(dim(x1), 3) expect_length(dim(x2), 2) expect_equal(x2, extract_variable_matrix(x, "mu")) # drop=TRUE shouldn't do anything if multiple parameters selected x3 <- x[,,1:2, drop=TRUE] expect_s3_class(x3, "draws_array") }) test_that("indexing draws_matrix with [ and drop works correctly", { x <- as_draws_matrix(example_draws()) x1 <- x[,1] x2 <- x[,1, drop=TRUE] expect_s3_class(x1, "draws_matrix") expect_equal(class(x2), "numeric") expect_length(dim(x1), 2) expect_null(dim(x2)) # drop=TRUE shouldn't do anything if multiple parameters selected x3 <- x[,1:2, drop=TRUE] expect_s3_class(x3, "draws_matrix") }) test_that("indexing draws dimension draws_matrix triggers a warning", { options(posterior.warn_on_merge_chains = TRUE) x <- as_draws_matrix(example_draws()) expect_warning( x1 <- x[1:3, ], "Chains were dropped due to manually indexing draws" ) x <- merge_chains(x) x2 <- x[1:3, ] expect_equal(x1, x2) options(posterior.warn_on_merge_chains = FALSE) }) posterior/tests/testthat/test-rvar-bind.R0000755000175000017500000001063314165314655020440 0ustar nileshnileshtest_that("c works on rvar", { x <- rvar(array(1:9, dim = c(3,3))) y <- rvar(array(2:10, dim = c(3,3), dimnames = list(NULL, c("a","b","c")))) x_y <- rvar(array(c(1:9, 2:10), dim = c(3,6), dimnames = list(NULL, c("","","","a","b","c")))) expect_equal(c(x), x) expect_equal(c(x, NULL), x) expect_equal(c(x, y), x_y) expect_equal(c(x, NULL, y), x_y) expect_equal(c(x, x), rvar(array(c(1:9, 1:9), dim = c(3,6)))) expect_equal(c(z = c(x, y)), rvar(array(c(1:9, 2:10), dim = c(3,6), dimnames = list(NULL, c("z1","z2","z3","z.a","z.b","z.c")))) ) expect_equal(c(x, 5), rvar(array(c(1:9, 5, 5, 5), dim = c(3,4)))) x_col <- x dim(x_col) <- c(3,1) expect_equal(c(x_col), x) expect_equal(c(x_col, y), x_y) }) test_that("cbind works on rvar", { x = rvar(array(1:9, dim = c(3,3))) y = rvar(array(2:10, dim = c(3,3))) expect_equal(cbind(rvar(array(1:9, dim = c(3,3)))), rvar(array(1:9, dim = c(3,3,1)))) expect_equal(cbind(x), rvar(array(1:9, dim = c(3,3,1), dimnames = list(NULL, NULL, "x")))) expect_equal(cbind(x, y, deparse.level = 0), rvar(array(c(1:9, 2:10), dim = c(3,3,2)))) expect_equal(cbind(a = x, y, deparse.level = 0), rvar(array(c(1:9, 2:10), dim = c(3,3,2), dimnames = list(NULL, NULL, c("a", "")))) ) expect_equal(cbind(a = x, y), rvar(array(c(1:9, 2:10), dim = c(3,3,2), dimnames = list(NULL, NULL, c("a", "y")))) ) expect_equal(cbind(x, b = y, deparse.level = 0), rvar(array(c(1:9, 2:10), dim = c(3,3,2), dimnames = list(NULL, NULL, c("", "b")))) ) expect_equal(cbind(x, y + 1, deparse.level = 2), rvar(array(c(1:9, 2:10 + 1), dim = c(3,3,2), dimnames = list(NULL, NULL, c("x", "y + 1")))) ) expect_equal(cbind(x, y, y + 1, deparse.level = 2), rvar(array(c(1:9, 2:10, 2:10 + 1), dim = c(3,3,3), dimnames = list(NULL, NULL, c("x", "y", "y + 1")))) ) expect_equal(cbind(x, y, y + 1, deparse.level = 2), cbind(cbind(x, y), y + 1, deparse.level = 2)) x_col <- x dim(x_col) <- c(3,1) expect_equal(cbind(x_col, y, deparse.level = 0), rvar(array(c(1:9, 2:10), dim = c(3,3,2)))) expect_equal(cbind(a = x_col, y), rvar(array(c(1:9, 2:10), dim = c(3,3,2), dimnames = list(NULL, NULL, c("", "y")))) ) dimnames(x_col)[[2]] = "b" expect_equal(cbind(a = x_col, y), rvar(array(c(1:9, 2:10), dim = c(3,3,2), dimnames = list(NULL, NULL, c("b", "y")))) ) expect_equal(cbind(NULL, x), cbind(x)) expect_equal(cbind(x, NULL, y), cbind(x, y)) }) test_that("cbind works on rvar with data frames", { # these do not work on R < 4 for some reason related to how data frames # handle binding (so, not much we can do about it?) skip_if_not(R.version$major >= 4) x = rvar(array(1:9, dim = c(3,3))) y = rvar(array(2:10, dim = c(3,3))) expect_equal(cbind(data.frame(x), y + 1), data.frame(x = x, `y + 1` = y + 1, check.names = FALSE)) expect_equal(cbind(x + 1, data.frame(y)), data.frame(`x + 1` = x + 1, y = y, check.names = FALSE)) }) test_that("rbind works on rvar", { x <- rvar(array(1:9, dim = c(3,3))) y <- rvar(array(2:10, dim = c(3,3))) x_y_array <- abind( array(1:9, dim = c(3,1,3)), array(2:10, dim = c(3,1,3)), along = 2 ) x_yp1_array <- abind( array(1:9, dim = c(3,1,3)), array(2:10 + 1, dim = c(3,1,3)), along = 2 ) expect_equal(rbind(rvar(array(1:9, dim = c(3,3)))), rvar(array(1:9, dim = c(3,1,3)))) expect_equal(rbind(x), rvar(array(1:9, dim = c(3,1,3), dimnames = list(NULL, "x", NULL)))) expect_equal(rbind(x, y, deparse.level = 0), rvar(x_y_array)) expect_equal(rbind(a = x, y, deparse.level = 0), rvar(x_y_array, dimnames = list(c("a",""), NULL))) expect_equal(rbind(a = x, y), rvar(x_y_array, dimnames = list(c("a","y"), NULL))) expect_equal(rbind(x, b = y, deparse.level = 0), rvar(x_y_array, dimnames = list(c("","b"), NULL))) expect_equal(rbind(x, y + 1, deparse.level = 2), rvar(x_yp1_array, dimnames = list(c("x","y + 1"), NULL))) expect_equal(rbind(x, y, y + 1, deparse.level = 2), rbind(rbind(x, y), y + 1, deparse.level = 2)) x_row <- x dim(x_row) <- c(1,3) expect_equal(rbind(x_row, y, deparse.level = 0), rvar(x_y_array)) expect_equal(rbind(a = x_row, y), rvar(x_y_array, dimnames = list(c("","y"), NULL))) dimnames(x_row)[[1]] = "b" expect_equal(rbind(a = x_row, y), rvar(x_y_array, dimnames = list(c("b","y"), NULL))) expect_equal(rbind(NULL, x), rbind(x)) expect_equal(rbind(x, NULL, y), rbind(x, y)) expect_equal(rbind(data.frame(x), data.frame(x = y)), data.frame(x = c(x, y))) }) posterior/tests/testthat/test-rvar-rfun.R0000755000175000017500000000416514165314652020476 0ustar nileshnileshtest_that("rdo works", { x_array <- array(1:24, dim = c(4,2,3)) x <- new_rvar(x_array) y_array <- array(c(2:13,12:1), dim = c(4,3,2)) y <- new_rvar(y_array) xy_ref <- new_rvar(abind::abind(along = 0, x_array[1,,] %*% y_array[1,,], x_array[2,,] %*% y_array[2,,], x_array[3,,] %*% y_array[3,,], x_array[4,,] %*% y_array[4,,] )) expect_equal(rdo(x %*% y), xy_ref) }) test_that("rfun works", { x_array <- array(1:24, dim = c(4,2,3)) x <- new_rvar(x_array) y_array <- array(c(2:13,12:1), dim = c(4,3,2)) y <- new_rvar(y_array) xy_ref <- new_rvar(abind::abind(along = 0, x_array[1,,] %*% y_array[1,,], x_array[2,,] %*% y_array[2,,], x_array[3,,] %*% y_array[3,,], x_array[4,,] %*% y_array[4,,] )) expect_equal(rfun(function(a,b) a %*% b)(x, y), xy_ref) }) test_that("rvar_rng works", { set.seed(1234) mu <- rvar_rng(rnorm, 10, mean = 1:10, sd = 1) sigma <- rvar_rng(rgamma, 1, shape = 1, rate = 1) x <- rvar_rng(rnorm, 10, mu, sigma) expect_equal(mean(x), 1:10, tolerance = 0.1) expect_equal(apply(draws_of(x), 2, sd), rep(1.7, 10), tolerance = 0.1) }) test_that("rvar_rng recycling works with numeric and rvar arguments", { # a fake random number generator that we can use to ensure draws are being # correctly reshaped and lined up rfake = function(n, tens, ones) { rep_len(tens * 10 + ones, length.out = n) } # numeric arguments ref <- rvar(array(c(11, 11, 22, 22, 13, 13, 24, 24), dim = c(2,4))) expect_equal(rvar_rng(rfake, 4, 1:2, 1:4, ndraws = 2), ref) # mixed numeric and rvar arguments ones <- rvar(array(1:8, dim = c(2,4))) ref <- rvar(array(c(11, 12, 23, 24, 15, 16, 27, 28), dim = c(2,4))) expect_equal(rvar_rng(rfake, 4, 1:2, ones), ref) # rvar arguments x <- c(15, 26, 37, 48) expect_equal(rvar_rng(rfake, 1, rvar(1:4), rvar(5:8)), rvar(x)) expect_equal(rvar_rng(rfake, 2, rvar(1:4), rvar(5:8)), rvar(array(c(x, x), dim = c(4, 2)))) tens <- rvar(array(1:4, dim = c(2,2))) ones <- rvar(array(1:8, dim = c(2,4))) ref <- rvar(array(c(11, 22, 33, 44, 15, 26, 37, 48), dim = c(2,4))) expect_equal(rvar_rng(rfake, 4, tens, ones), ref) }) posterior/tests/testthat/test-bind_draws.R0000644000175000017500000001571214165314652020665 0ustar nileshnileshtest_that("bind_draws works for draws_matrix objects", { draws1 <- as_draws_matrix(example_draws()) draws2 <- subset_draws(draws1, chain = 2) draws3 <- subset_draws(draws1, iteration = 10:20) draws4 <- as_draws_df(data.frame( nu = rnorm(ndraws(draws1)), .chain = rep(chain_ids(draws1), each = niterations(draws1)) )) draws_new <- bind_draws(draws1, draws4, along = "variable") expect_equal( variables(draws_new), c(variables(draws1), variables(draws4)) ) expect_equal(ndraws(draws_new), ndraws(draws1)) expect_error(bind_draws(draws1, draws3, along = "iteration"), "Cannot bind 'draws_matrix' objects along 'iteration'") draws_new <- bind_draws(draws1, draws2, along = "chain") expect_equal( nchains(draws_new), nchains(draws1) + nchains(draws2) ) expect_equal(variables(draws_new), variables(draws1)) draws_new <- bind_draws(draws1, draws3, along = "draw") expect_equal( ndraws(draws_new), ndraws(draws1) + ndraws(draws3) ) expect_equal(variables(draws_new), variables(draws1)) }) test_that("bind_draws works for draws_array objects", { draws1 <- as_draws_array(example_draws()) draws2 <- subset_draws(draws1, chain = 2) draws3 <- subset_draws(draws1, iteration = 10:20) draws4 <- as_draws_df(data.frame( nu = rnorm(ndraws(draws1)), .chain = rep(chain_ids(draws1), each = niterations(draws1)) )) draws_new <- bind_draws(draws1, draws4, along = "variable") expect_equal( variables(draws_new), c(variables(draws1), variables(draws4)) ) expect_equal(ndraws(draws_new), ndraws(draws1)) draws_new <- bind_draws(draws1, draws2, along = "chain") expect_equal(nchains(draws_new), nchains(draws1) + nchains(draws2)) expect_equal(variables(draws_new), variables(draws1)) draws_new <- bind_draws(draws1, draws3, along = "iteration") expect_equal( niterations(draws_new), niterations(draws1) + niterations(draws3) ) expect_equal(variables(draws_new), variables(draws1)) expect_error(bind_draws(draws1, draws3, along = "draw"), "Cannot bind 'draws_array' objects along 'draw'") }) test_that("bind_draws works for draws_df objects", { draws1 <- as_draws_df(example_draws()) draws2 <- subset_draws(draws1, chain = 2) draws3 <- subset_draws(draws1, iteration = 10:20) draws4 <- as_draws_list(data.frame( nu = rnorm(ndraws(draws1)), .chain = rep(chain_ids(draws1), each = niterations(draws1)) )) draws_new <- bind_draws(draws1, draws4, along = "variable") expect_equal( variables(draws_new), c(variables(draws1), variables(draws4)) ) expect_equal(ndraws(draws_new), ndraws(draws1)) draws_new <- bind_draws(draws1, draws2, along = "chain") expect_equal(nchains(draws_new), nchains(draws1) + nchains(draws2)) expect_equal(variables(draws_new), variables(draws1)) draws_new <- bind_draws(draws1, draws3, along = "iteration") expect_equal( niterations(draws_new), niterations(draws1) + niterations(draws3) ) expect_equal(variables(draws_new), variables(draws1)) draws_new <- bind_draws(draws1, draws3, along = "draw") expect_equal(ndraws(draws_new), ndraws(draws1) + ndraws(draws3)) expect_equal(nchains(draws_new), 1L) draws_new <- bind_draws(NULL, draws1) expect_equal(draws_new, draws1) }) test_that("bind_draws works for multiple draws_df objects", { draws1 <- as_draws_df(example_draws()) draws2 <- subset_draws(draws1, chain = 2) draws3 <- subset_draws(draws1, chain = 3) draws12 <- bind_draws(draws1, draws2, along = "chain") draws123 <- bind_draws(draws12, draws3, along = "chain") draws_all <- bind_draws(draws1, draws2, draws3, along = "chain") expect_equal(draws123, draws_all) expect_equal(nchains(draws_all), nchains(draws1) + nchains(draws2) + nchains(draws3)) expect_equal(ndraws(draws_all), ndraws(draws1) + ndraws(draws2) + ndraws(draws3)) expect_equal(niterations(draws_all), niterations(draws1)) expect_equal(variables(draws_all), variables(draws1)) draws4 <- subset_draws(draws1, chain = 4) draws23 <- bind_draws(draws2, draws3, along = "iteration") draws234 <- bind_draws(draws23, draws4, along = "iteration") draws_all <- bind_draws(draws2, draws3, draws4, along = "iteration") expect_equal(draws234, draws_all) expect_equal(nchains(draws_all), 1L) expect_equal(niterations(draws_all), niterations(draws2) + niterations(draws3) + niterations(draws4)) expect_equal(niterations(draws_all), ndraws(draws_all)) expect_equal(variables(draws_all), variables(draws2)) }) test_that("bind_draws works for draws_list objects", { draws1 <- as_draws_list(example_draws()) draws2 <- subset_draws(draws1, chain = 2) draws3 <- subset_draws(draws1, iteration = 10:20) draws4 <- as_draws_df(data.frame( nu = rnorm(ndraws(draws1)), .chain = rep(chain_ids(draws1), each = niterations(draws1)) )) draws_new <- bind_draws(draws1, draws4, along = "variable") expect_equal( variables(draws_new), c(variables(draws1), variables(draws4)) ) expect_equal(ndraws(draws_new), ndraws(draws1)) draws_new <- bind_draws(draws1, draws2, along = "chain") expect_equal(nchains(draws_new), nchains(draws1) + nchains(draws2)) expect_equal(variables(draws_new), variables(draws1)) draws_new <- bind_draws(draws1, draws3, along = "iteration") expect_equal( niterations(draws_new), niterations(draws1) + niterations(draws3) ) expect_equal(variables(draws_new), variables(draws1)) expect_error(bind_draws(draws1, draws3, along = "draw"), "Cannot bind 'draws_list' objects along 'draw'") }) test_that("bind_draws works for draws_rvars objects", { draws1 <- as_draws_rvars(example_draws()) draws2 <- subset_draws(draws1, chain = 2) draws3 <- subset_draws(draws1, iteration = 10:20) draws4 <- as_draws_list(data.frame( nu = rnorm(ndraws(draws1)), .chain = rep(chain_ids(draws1), each = niterations(draws1)) )) draws_new <- bind_draws(draws1, draws4, along = "variable") expect_equal( variables(draws_new), c(variables(draws1), variables(draws4)) ) expect_equal(ndraws(draws_new), ndraws(draws1)) draws_new <- bind_draws(draws1, draws2, along = "chain") expect_equal(nchains(draws_new), nchains(draws1) + nchains(draws2)) expect_equal(variables(draws_new), variables(draws1)) expect_error(bind_draws(draws1, draws3, along = "iteration"), "Cannot bind 'draws_rvars' objects along 'iteration'") draws_new <- bind_draws(draws1, draws3, along = "draw") expect_equal(ndraws(draws_new), ndraws(draws1) + ndraws(draws3)) expect_equal(nchains(draws_new), 1L) draws_new <- bind_draws(NULL, draws1) expect_equal(draws_new, draws1) }) test_that("bind_draws errors if all NULL", { expect_error(bind_draws(NULL, NULL), "All objects passed to 'bind_draws' are NULL") }) test_that("bind_draws errors for inputs with incompatible variables", { x1 <- x2 <- example_draws() variables(x1) <- gsub("theta", "beta", variables(x1)) expect_error(bind_draws(x1, x2, along = "chain"), "'variables' of bound objects do not match") }) posterior/tests/testthat/test-rvar-print.R0000755000175000017500000000550114165314655020656 0ustar nileshnileshtest_that("basic print.rvar works", { x <- rvar(array(1:12, dim = c(2,2,3))) x_with_chains <- rvar(array(1:12, dim = c(2,2,3)), nchains = 2) expect_output(print(rvar(), color = FALSE), "rvar<1>[0] mean ± sd: NULL", fixed = TRUE ) expect_output(print(x, color = FALSE), "rvar<2>[2,3] mean ± sd:\ [,1] [,2] [,3] \ [1,] 1.5 ± 0.71 5.5 ± 0.71 9.5 ± 0.71 \ [2,] 3.5 ± 0.71 7.5 ± 0.71 11.5 ± 0.71 ", fixed = TRUE ) expect_output(print(x_with_chains, color = FALSE), "rvar<1,2>[2,3] mean ± sd:\ [,1] [,2] [,3] \ [1,] 1.5 ± 0.71 5.5 ± 0.71 9.5 ± 0.71 \ [2,] 3.5 ± 0.71 7.5 ± 0.71 11.5 ± 0.71 ", fixed = TRUE ) }) test_that("basic str.rvar works", { x <- rvar(array(1:24, dim = c(2,3,4))) x_with_chains <- rvar(array(1:24, dim = c(2,3,4)), nchains = 2) expect_output(str(rvar()), " rvar<1>[0] ", fixed = TRUE ) expect_output(str(rvar(1:3)), " rvar<3>[1] 2 ± 1", fixed = TRUE ) expect_output(str(x, vec.len = 5), " rvar<2>[3,4] 1.5 ± 0.71 3.5 ± 0.71 5.5 ± 0.71 7.5 ± 0.71 9.5 ± 0.71 ...", fixed = TRUE ) expect_output(str(x_with_chains, vec.len = 5), " rvar<1,2>[3,4] 1.5 ± 0.71 3.5 ± 0.71 5.5 ± 0.71 7.5 ± 0.71 9.5 ± 0.71 ...", fixed = TRUE ) x_with_attrs <- x dimnames(x_with_attrs)[1] = list(c("a","b","c")) attr(draws_of(x_with_attrs), "foo") = list(1,2) attr(x_with_attrs, "bar") = list(1,2) expect_output(str(x_with_attrs, vec.len = 5), ' rvar<2>[3,4] 1.5 ± 0.71 3.5 ± 0.71 5.5 ± 0.71 7.5 ± 0.71 9.5 ± 0.71 ... - dimnames(*)=List of 2 ..$ : chr [1:3] "a" "b" "c" ..$ : NULL - attr(draws_of(*), "foo")=List of 2 ..$ : num 1 ..$ : num 2 - attr(*, "bar")=List of 2 ..$ : num 1 ..$ : num 2', fixed = TRUE ) }) test_that("glimpse on rvar works", { x_vec <- rvar(array(1:24, dim = c(6,4))) x_matrix <- rvar(array(1:24, dim = c(2,3,4))) expect_equal(format_glimpse(rvar()), NULL) expect_equal( format_glimpse(x_vec), c("3.5 ± 1.9", "9.5 ± 1.9", "15.5 ± 1.9", "21.5 ± 1.9"), check.attributes = FALSE ) expect_equal(format_glimpse(x_matrix), "") }) test_that("format summary arg works", { x = rvar(c(1,9,10)) expect_equal(as.vector(format(x, summary = "mean_sd")), "6.7 \u00b1 4.9") expect_equal(as.vector(format(x, summary = "median_mad")), "9 \u00b1 1.5") expect_error(format(x, summary = "foo")) }) test_that("vec_ptype_abbr and vec_ptype_full work", { x <- rvar(array(1:24, dim = c(2,3,4))) x_with_chains <- rvar(array(1:24, dim = c(2,3,4)), nchains = 2) expect_equal(vec_ptype_abbr(x, suffix_shape = FALSE), "rvar") expect_equal(vec_ptype_full(rvar(1:3)), "rvar<3>") expect_equal(vec_ptype_full(x), "rvar<2>[,4]") expect_equal(vec_ptype_full(x_with_chains), "rvar<1,2>[,4]") }) posterior/tests/testthat/test-convergence.R0000644000175000017500000001053414165320262021036 0ustar nileshnileshtest_that("rhat diagnostics return reasonable values", { tau <- extract_variable_matrix(example_draws(), "tau") rhat <- rhat_basic(tau) expect_true(rhat > 0.99 & rhat < 1.05) rhat <- rhat(tau) expect_true(rhat > 0.99 & rhat < 1.05) }) test_that("ess diagnostics return reasonable values", { tau <- extract_variable_matrix(example_draws(), "tau") mu <- extract_variable_matrix(example_draws("multi_normal"), "mu[1]") ess <- ess_basic(tau) expect_true(ess > 250 & ess < 310) ess <- ess_mean(tau) expect_true(ess > 250 & ess < 310) ess <- ess_sd(tau) expect_true(ess > 250 & ess < 310) ess <- ess_bulk(tau) expect_true(ess > 230 & ess < 280) # some chains are constant for the computed tail quantiles ess <- ess_tail(tau) expect_true(ess > 180 & ess < 220) # use a different example to obtain non-NA value ess <- ess_tail(mu) expect_true(ess > 330 & ess < 380) ess <- ess_quantile(tau, probs = c(0.2, 0.8)) expect_equal(names(ess), c("ess_q20", "ess_q80")) expect_true(ess[1] > 150 & ess[1] < 210) expect_true(ess[2] > 350 & ess[2] < 420) ess <- ess_median(tau) expect_true(ess > 350 & ess < 420) }) test_that("negative ess estimates are avoided with a warning", { x <- stats::arima.sim(list(ar=-0.9), 1000) expect_warning(ess <- ess_basic(x), "The ESS has been capped") expect_equal(ess, 3000) }) test_that("mcse diagnostics return reasonable values", { tau <- extract_variable_matrix(example_draws(), "tau") mcse <- mcse_mean(tau) expect_true(mcse > 0.15 & mcse < 0.25) mcse <- mcse_sd(tau) expect_true(mcse > 0.15 & mcse < 0.25) mcse <- mcse_quantile(tau, probs = c(0.2, 0.8)) expect_equal(names(mcse), c("mcse_q20", "mcse_q80")) expect_true(mcse[1] > 0.16 & mcse[1] < 0.21) # due to right skewness of tau the 90%ile is way more uncertain expect_true(mcse[2] > 0.3 & mcse[2] < 0.7) mcse <- mcse_median(tau) expect_true(mcse > 0.2 & mcse < 0.3) }) test_that("convergence diagnostics accept vectors as input", { set.seed(1234) x <- rnorm(1000) rhat <- rhat(x) expect_true(rhat > 0.99 & rhat < 1.01) ess <- ess_bulk(x) expect_true(ess > 900 & ess < 1100) ess <- ess_tail(x) expect_true(ess > 750 & ess < 850) mcse <- mcse_mean(x) expect_true(mcse > 0.02 & mcse < 0.04) }) test_that("convergence diagnostics handle special cases correctly", { set.seed(1234) x <- c(rnorm(10), NA) expect_true(is.na(rhat_basic(x))) expect_true(is.na(ess_basic(x))) x <- c(rnorm(10), Inf) expect_true(is.na(rhat_basic(x))) expect_true(is.na(ess_basic(x))) x <- rep(1, 10) expect_true(is.na(rhat_basic(x))) expect_true(is.na(ess_basic(x))) # constant-per-chain checks deactivated for now # x <- cbind(1, rnorm(10)) # expect_true(is.na(rhat_basic(x))) # expect_true(is.na(ess_basic(x))) }) test_that("convergence diagnostics throw correct errors", { mu <- extract_variable_matrix(example_draws(), "mu") expect_error(ess_quantile(mu, probs = 1.2), "'probs' must contain values between 0 and 1") expect_error(mcse_quantile(mu, probs = 1.2), "'probs' must contain values between 0 and 1") }) test_that("convergence functions work with rvars", { tau <- extract_variable_matrix(example_draws(), "tau") tau_rvar <- rvar(tau, with_chains = TRUE) expect_equal(ess_basic(tau_rvar), ess_basic(tau)) expect_equal(ess_bulk(tau_rvar), ess_bulk(tau)) expect_equal(ess_tail(tau_rvar), ess_tail(tau)) # convergence functions with multiple return values on rvars returns a column # vector; should be equal to the NULL-dimension vector format when transposed expect_equal(t(ess_quantile(tau_rvar, probs = c(.1, .9))), t(ess_quantile(tau, probs = c(.1, .9)))) expect_equal(ess_sd(tau_rvar), ess_sd(tau)) expect_equal(mcse_mean(tau_rvar), mcse_mean(tau)) expect_equal(t(mcse_quantile(tau_rvar, probs = c(.1, .9))), t(mcse_quantile(tau, probs = c(.1, .9)))) expect_equal(mcse_sd(tau_rvar), mcse_sd(tau)) expect_equal(rhat_basic(tau_rvar), rhat_basic(tau)) expect_equal(rhat(tau_rvar), rhat(tau)) }) test_that("autocovariance returns correct results", { x <- rnorm(100) ac1 <- autocovariance(x) ac2 <- acf(x, type = "covariance", lag.max = length(x), plot = FALSE)$acf[, 1, 1] expect_equal(ac1, ac2) x <- arima.sim(list(ar = c(0.5, -0.3)), 100) ac1 <- autocovariance(x) ac2 <- acf(x, type = "covariance", lag.max = length(x), plot = FALSE)$acf[, 1, 1] expect_equal(ac1, ac2) }) posterior/tests/testthat/test-rvar-summaries-within-draws.R0000755000175000017500000001072014165314652024141 0ustar nileshnilesh# numeric summaries ------------------------------------------------------- test_that("numeric summary functions work", { x_array <- array(1:24, dim = c(4,2,3)) x <- new_rvar(x_array) expect_equal(draws_of(rvar_mean(x)), apply(x_array, 1, mean), check.attributes = FALSE) expect_equal(draws_of(rvar_median(x)), apply(x_array, 1, median), check.attributes = FALSE) expect_equal(draws_of(rvar_sum(x)), apply(x_array, 1, sum), check.attributes = FALSE) expect_equal(draws_of(rvar_prod(x)), apply(x_array, 1, prod), check.attributes = FALSE) expect_equal(draws_of(rvar_min(x)), apply(x_array, 1, min), check.attributes = FALSE) expect_equal(draws_of(rvar_max(x)), apply(x_array, 1, max), check.attributes = FALSE) # default values on empty input expect_equal(rvar_mean(), as_rvar(NA_real_)) expect_equal(rvar_median(), as_rvar(NA_real_)) expect_equal(rvar_sum(), as_rvar(0)) expect_equal(rvar_prod(), as_rvar(1)) expect_equal(rvar_min(), as_rvar(Inf)) expect_equal(rvar_max(), as_rvar(-Inf)) # test argument passing x[1,2] <- NA expect_equal( draws_of(rvar_mean(x, na.rm = TRUE)), apply(draws_of(x), 1, function(x) mean(x, na.rm = TRUE)), check.attributes = FALSE ) }) # spread ------------------------------------------------------------------ test_that("spread summary functions work", { x_array <- array(1:24, dim = c(4,2,3)) x <- new_rvar(x_array) expect_equal(draws_of(rvar_sd(x)), apply(x_array, 1, sd), check.attributes = FALSE) expect_equal(draws_of(rvar_var(x)), apply(x_array, 1, function(x) var(as.vector(x))), check.attributes = FALSE) expect_equal(draws_of(rvar_mad(x)), apply(x_array, 1, mad), check.attributes = FALSE) expect_equal(draws_of(rvar_mad(x, constant = 1)), apply(x_array, 1, mad, constant = 1), check.attributes = FALSE) # default values on empty input expect_equal(rvar_sd(), as_rvar(NA_real_)) expect_equal(rvar_var(), as_rvar(NA_real_)) expect_equal(rvar_mad(), as_rvar(NA_real_)) # test argument passing on var since it requires some finagling x[1,2] <- NA expect_equal( draws_of(rvar_var(x, na.rm = TRUE)), apply(draws_of(x), 1, function(x) var(as.vector(x), na.rm = TRUE)), check.attributes = FALSE ) }) # range ------------------------------------------------------------------- test_that("rvar_range works", { x_array <- array(1:24, dim = c(4,2,3)) x <- new_rvar(x_array) expect_equal(draws_of(rvar_range(x)), t(apply(x_array, 1, range)), check.attributes = FALSE) # default values on empty input expect_equal(rvar_range(), as_rvar(c(Inf, -Inf))) }) # quantiles --------------------------------------------------------------- test_that("rvar_quantile works", { x_array <- array(1:24, dim = c(4,2,3)) x <- new_rvar(x_array) p <- c(0.25, 0.5, 0.75) quantiles <- t(apply(x_array, 1, quantile, probs = p, names = TRUE)) dimnames(quantiles)[1] <- list(1:4) expect_equal(draws_of(rvar_quantile(x, probs = p, names = TRUE)), quantiles) dimnames(quantiles)[2] <- NULL expect_equal(draws_of(rvar_quantile(x, probs = p, names = FALSE)), quantiles) q50 <- array(apply(x_array, 1, quantile, probs = 0.5), dim = c(4, 1), dimnames = list(1:4, "50%")) expect_equal(draws_of(rvar_quantile(x, probs = 0.5, names = TRUE)), q50) # passing NULL should still result in a vector with length = length(probs) expect_equal(rvar_quantile(NULL, probs = c(0.25, 0.75)), as_rvar(c(NA_real_, NA_real_))) }) # logical summaries ------------------------------------------------------- test_that("logical summaries work", { x_array <- array(1:24, dim = c(4,2,3)) x <- new_rvar(x_array) expect_equal(draws_of(rvar_all(x > 6)), as.matrix(apply(x_array > 6, 1, all)), check.attributes = FALSE) expect_equal(draws_of(rvar_any(x > 6)), as.matrix(apply(x_array > 6, 1, any)), check.attributes = FALSE) # default values on empty input expect_equal(rvar_all(), as_rvar(TRUE)) expect_equal(rvar_any(), as_rvar(FALSE)) }) # special value predicates ------------------------------------------------ test_that("special value predicates work", { x_array <- c(1, Inf, -Inf, NaN, NA) x <- new_rvar(x_array) expect_equal(draws_of(rvar_is_finite(x)), as.matrix(is.finite(x_array)), check.attributes = FALSE) expect_equal(draws_of(rvar_is_infinite(x)), as.matrix(is.infinite(x_array)), check.attributes = FALSE) expect_equal(draws_of(rvar_is_nan(x)), as.matrix(is.nan(x_array)), check.attributes = FALSE) expect_equal(draws_of(rvar_is_na(x)), as.matrix(is.na(x_array)), check.attributes = FALSE) }) posterior/tests/testthat/test-extract_variable_matrix.R0000644000175000017500000000307314165314652023451 0ustar nileshnileshtest_that("extract_variable_matrix works the same for different formats", { draws_array <- as_draws_array(example_draws()) mu_array <- extract_variable_matrix(draws_array, "mu") draws_df <- as_draws_df(example_draws()) mu_df <- extract_variable_matrix(draws_df, "mu") expect_equal(mu_df, mu_array) draws_list <- as_draws_list(example_draws()) mu_list <- extract_variable_matrix(draws_list, "mu") expect_equal(mu_list, mu_array) draws_matrix <- as_draws_matrix(example_draws()) mu_matrix <- extract_variable_matrix(draws_matrix, "mu") expect_equal(as.vector(mu_matrix), as.vector(mu_array)) draws_rvars <- as_draws_rvars(example_draws()) mu_matrix <- extract_variable_matrix(draws_rvars, "mu") expect_equal(as.vector(mu_matrix), as.vector(mu_array)) }) test_that("extract_variable_matrix works for draws_rvars on an indexed variable", { draws_array <- as_draws_array(example_draws()) theta1_array <- extract_variable_matrix(draws_array, "theta[1]") draws_rvars <- as_draws_rvars(example_draws()) theta1_matrix <- extract_variable_matrix(draws_rvars, "theta[1]") expect_equal(as.vector(theta1_matrix), as.vector(theta1_array)) expect_error(extract_variable_matrix(draws_rvars, "theta"), "Cannot extract non-scalar value") }) test_that("extract_variable_matrix default method works", { # it should convert matrix to draws object x <- matrix(1:20, nrow = 10, ncol = 2) colnames(x) <- c("A", "B") expect_equivalent(extract_variable_matrix(x, "A"), x[, 1, drop=FALSE]) expect_equivalent(extract_variable_matrix(x, "B"), x[, 2, drop=FALSE]) }) posterior/tests/testthat/test-extract_variable.R0000644000175000017500000000267314165314652022072 0ustar nileshnileshtest_that("extract_variable works the same for different formats", { draws_array <- as_draws_array(example_draws()) mu_array <- extract_variable(draws_array, "mu") draws_df <- as_draws_df(example_draws()) mu_df <- extract_variable(draws_df, "mu") expect_equal(mu_df, mu_array) draws_list <- as_draws_list(example_draws()) mu_list <- extract_variable(draws_list, "mu") expect_equal(mu_list, mu_array) draws_matrix <- as_draws_matrix(example_draws()) mu_matrix <- extract_variable(draws_matrix, "mu") expect_equal(as.vector(mu_matrix), as.vector(mu_array)) draws_rvars <- as_draws_rvars(example_draws()) mu_matrix <- extract_variable(draws_rvars, "mu") expect_equal(as.vector(mu_matrix), as.vector(mu_array)) }) test_that("extract_variable works for draws_rvars on an indexed variable", { draws_array <- as_draws_array(example_draws()) theta1_array <- extract_variable(draws_array, "theta[1]") draws_rvars <- as_draws_rvars(example_draws()) theta1_matrix <- extract_variable(draws_rvars, "theta[1]") expect_equal(as.vector(theta1_matrix), as.vector(theta1_array)) expect_error(extract_variable(draws_rvars, "theta"), "Cannot extract non-scalar value") }) test_that("extract_variable default method works", { # it should convert matrix to draws object x <- matrix(1:20, nrow = 10, ncol = 2) colnames(x) <- c("A", "B") expect_equal(extract_variable(x, "A"), 1:10) expect_equal(extract_variable(x, "B"), 11:20) }) posterior/tests/testthat/test-rvar-dist.R0000755000175000017500000000247714165314652020473 0ustar nileshnileshtest_that("distributional functions work on a scalar rvar", { x_values <- c(2,4,3,5) x <- rvar(x_values) x_density <- density(x_values, cut = 0) expect_equal(density(x, at = x_density$x), x_density$y) x_cdf <- ecdf(x_values)(x_values) expect_equal(cdf(x, x_values), x_cdf) expect_equal(quantile(x, 1:4/4), quantile(x_values, 1:4/4, names = FALSE)) }) test_that("distributional functions work on an rvar array", { x <- rvar(array(1:12, dim = c(3,2,2))) d11 <- c(density(1:3, n = 3, from = 1, to = 3)$y, rep(0, 9)) d21 <- c(rep(0, 3), density(4:6, n = 3, from = 4, to = 6)$y, rep(0, 6)) d12 <- c(rep(0, 6), density(7:9, n = 3, from = 7, to = 9)$y, rep(0, 3)) d22 <- c(rep(0, 9), density(10:12, n = 3, from = 10, to = 12)$y) x_density <- array(c(d11, d21, d12, d22), dim = c(12, 2, 2)) expect_equal(density(x, at = 1:12), x_density) cdf11 <- ecdf(1:3)(1:12) cdf21 <- ecdf(4:6)(1:12) cdf12 <- ecdf(7:9)(1:12) cdf22 <- ecdf(10:12)(1:12) x_cdf <- array(c(cdf11, cdf21, cdf12, cdf22), dim = c(12, 2, 2)) expect_equal(cdf(x, 1:12), x_cdf) p <- ppoints(9, a = 1) q11 <- quantile(1:3, p) q21 <- quantile(4:6, p) q12 <- quantile(7:9, p) q22 <- quantile(10:12, p) x_quantiles <- array(c(q11, q21, q12, q22), dim = c(9, 2, 2), dimnames = list(NULL)) expect_equal(quantile(x, p), x_quantiles) }) posterior/tests/testthat/test-resample_draws.R0000644000175000017500000000423414165314652021556 0ustar nileshnileshtest_that("resample_draws returns expected format", { x <- example_draws() w <- runif(ndraws(x), 0, 10) x <- as_draws_matrix(x) x_rs <- resample_draws(x, weights = w, method = "stratified") expect_true(is_draws_matrix(x_rs)) expect_equal(ndraws(x_rs), ndraws(x)) x <- as_draws_array(x) x_rs <- resample_draws(x, weights = w, method = "deterministic", ndraws = 200) expect_true(is_draws_array(x_rs)) expect_equal(ndraws(x_rs), 200) x <- as_draws_df(x) x_rs <- resample_draws(x, weights = w, method = "simple") expect_true(is_draws_df(x_rs)) expect_equal(ndraws(x_rs), ndraws(x)) x <- as_draws_list(x) x_rs <- resample_draws(x, w, method = "simple_no_replace", ndraws = 100) expect_true(is_draws_list(x_rs)) expect_equal(ndraws(x_rs), 100) expect_error( resample_draws(x, w, method = "simple_no_replace"), "Argument 'ndraws' is required" ) x <- as_draws_rvars(x) x_rs <- resample_draws(x, weights = w, method = "simple") expect_true(is_draws_rvars(x_rs)) expect_equal(ndraws(x_rs), ndraws(x)) }) test_that("Resampling algorithms return the correct result in expectation", { set.seed(1234) x <- as_draws_df(cbind(mu = 1:10000)) w <- 1:10000 / 777 expected_mean <- sum(x$mu * (w / sum(w))) x_rs <- resample_draws(x, w, method = "stratified") mean_rs <- mean(x_rs$mu) expect_true(mean_rs > 6660 && mean_rs < 6670) x_rs <- resample_draws(x, w, method = "deterministic") mean_rs <- mean(x_rs$mu) expect_true(mean_rs > 6660 && mean_rs < 6670) x_rs <- resample_draws(x, w, method = "simple") mean_rs <- mean(x_rs$mu) expect_true(mean_rs > 6650 && mean_rs < 6690) # method 'simple_no_replace' will be biased for weights with large variance }) test_that("resample_draws uses stored weights when available", { x <- example_draws() expect_error(resample_draws(x), "No weights are provided and none can be found within the draws object" ) w <- runif(ndraws(x), 0, 10) x <- weight_draws(x, w) x_rs <- resample_draws(x) expect_true(is_draws_array(x_rs)) expect_equal(ndraws(x_rs), ndraws(x)) # .log_weight variable has been dropped expect_true(!".log_weight" %in% variables(x_rs, reserved = TRUE)) }) posterior/tests/testthat/test-remove_variables.R0000644000175000017500000000256214165314652022075 0ustar nileshnileshtest_that("remove_variables works correctly for draws_matrix objects", { x <- as_draws_matrix(example_draws()) expect_equal(posterior:::remove_variables(x, NULL), x) x <- posterior:::remove_variables(x, c("mu", "tau")) expect_equal(variables(x), paste0("theta[", 1:8, "]")) }) test_that("remove_variables works correctly for draws_array objects", { x <- as_draws_array(example_draws()) expect_equal(posterior:::remove_variables(x, NULL), x) x <- posterior:::remove_variables(x, c("mu", "tau")) expect_equal(variables(x), paste0("theta[", 1:8, "]")) }) test_that("remove_variables works correctly for draws_df objects", { x <- as_draws_df(example_draws()) expect_equal(posterior:::remove_variables(x, NULL), x) x <- posterior:::remove_variables(x, c("mu", "tau")) expect_equal(variables(x), paste0("theta[", 1:8, "]")) }) test_that("remove_variables works correctly for draws_list objects", { x <- as_draws_list(example_draws()) expect_equal(posterior:::remove_variables(x, NULL), x) x <- posterior:::remove_variables(x, c("mu", "tau")) expect_equal(variables(x), paste0("theta[", 1:8, "]")) }) test_that("remove_variables works correctly for draws_rvars objects", { x <- as_draws_rvars(example_draws()) expect_equal(posterior:::remove_variables(x, NULL), x) x <- posterior:::remove_variables(x, c("mu", "tau")) expect_equal(variables(x), "theta") }) posterior/tests/testthat/test-rvar-apply.R0000755000175000017500000000377114165314652020653 0ustar nileshnilesh# base apply functions --------------------------------------------------------- test_that("base apply family functions work", { x_array = array(1:24, dim = c(2,3,4)) x = rvar(x_array) expect_equal(lapply(x, function(x) sum(draws_of(x))), as.list(apply(draws_of(x), 2, sum))) expect_equal(sapply(x, function(x) sum(draws_of(x))), apply(draws_of(x), 2, sum)) expect_equal(vapply(x, function(x) sum(draws_of(x)), numeric(1)), apply(draws_of(x), 2, sum)) expect_equal(apply(x, 1, function(x) sum(draws_of(x))), apply(draws_of(x), 2, sum)) expect_equal(apply(x, 1:2, function(x) sum(draws_of(x))), apply(draws_of(x), 2:3, sum)) }) # rvar_apply -------------------------------------------------------------- test_that("rvar_apply works", { x_array = array(1:36, dim = c(2,2,3,3), dimnames = list(NULL, A = paste0("a", 1:2), B = paste0("b", 1:3), C = paste0("c", 1:3)) ) x = rvar(x_array) expect_equal(rvar_apply(x, 1, rvar_mean), rvar(apply(draws_of(x), 1:2, mean))) expect_equal(rvar_apply(x, 2, rvar_mean), rvar(apply(draws_of(x), c(1,3), mean))) expect_equal(rvar_apply(x, 3, rvar_mean), rvar(apply(draws_of(x), c(1,4), mean))) expect_equal(rvar_apply(x, c(1,2), rvar_mean), rvar(apply(draws_of(x), c(1,2,3), mean))) expect_equal(rvar_apply(x, c(1,3), rvar_mean), rvar(apply(draws_of(x), c(1,2,4), mean))) expect_error(rvar_apply(x, c(1,3), function(x) 0)) expect_equal(length(rvar_apply(x, c(1,3), function(x) rvar())), 0) # test that if the cell values are multidimensional everything is bound back # together properly (though with dimnames dropped) x1 <- x + 1 dimnames(x1)[3] <- list(NULL) names(dimnames(x1))[[3]] <- "" expect_equal(rvar_apply(x, c(1,2), function(x) x + 1), x1) # test that binding results together does broadcasting: x["a1",] has a mean # < 18 and ref["a2",] has mean > 18 and will be replaced with 0 with this ref <- x ref["a1",,] <- ref["a1",,] + 1 ref["a2",,] <- 0 rvar_apply(x, 1, function(x) if(mean(draws_of(x)) > 18) rvar(0) else x + 1) }) posterior/tests/testthat/test-merge_chains.R0000644000175000017500000000175614065630477021205 0ustar nileshnileshtest_that("merge_chains works correctly", { x <- example_draws() xm <- merge_chains(as_draws_matrix(x)) expect_equal(nchains(xm), 1) expect_equal(ndraws(xm), ndraws(x)) expect_equal(variables(xm), variables(x)) xm <- merge_chains(as_draws_array(x)) expect_equal(nchains(xm), 1) expect_equal(ndraws(xm), ndraws(x)) expect_equal(variables(xm), variables(x)) xm <- merge_chains(as_draws_df(x)) expect_equal(nchains(xm), 1) expect_equal(ndraws(xm), ndraws(x)) expect_equal(variables(xm), variables(x)) xm <- merge_chains(as_draws_list(x)) expect_equal(nchains(xm), 1) expect_equal(ndraws(xm), ndraws(x)) expect_equal(variables(xm), variables(x)) # need to keep x_rvar around for this test because draws_rvars counts # variables differently from the other formats x_rvar <- as_draws_rvars(x) xm <- merge_chains(x_rvar) expect_equal(nchains(xm), 1) expect_equal(ndraws(xm), ndraws(x)) expect_equal(variables(xm), variables(x_rvar)) }) posterior/tests/testthat/test-variables.R0000755000175000017500000000545414165314652020526 0ustar nileshnileshtest_that('duplicate variable names are not allowed', { x = matrix(11:20, ncol = 2, dimnames = list(NULL, c("a", "a"))) err = "Duplicate variable names are not allowed" expect_error(as_draws_matrix(x), err) expect_error(as_draws_df(x), err) expect_error(as_draws_list(x), err) expect_error(as_draws_array(x), err) }) test_that("variables() work with NULL", { expect_equal(variables(NULL), NULL) }) test_that("variables() and variables<-() work on draws_matrix", { x <- as_draws_matrix(matrix(11:20, ncol = 2, dimnames = list(NULL, c("a", "b")))) ref <- as_draws_matrix(matrix(11:20, ncol = 2, dimnames = list(NULL, c("x", "y[1]")))) expect_equal(variables(x), c("a", "b")) expect_equal(variables(ref), c("x", "y[1]")) variables(x) <- c("x", "y[1]") expect_equal(x, ref) }) test_that("variables() and variables<-() work on draws_array", { x <- as_draws_array(matrix(11:20, ncol = 2, dimnames = list(NULL, c("a", "b")))) ref <- as_draws_array(matrix(11:20, ncol = 2, dimnames = list(NULL, c("x", "y[1]")))) expect_equal(variables(x), c("a", "b")) expect_equal(variables(ref), c("x", "y[1]")) variables(x) <- c("x", "y[1]") expect_equal(x, ref) }) test_that("variables() and variables<-() work on draws_list", { x <- as_draws_list(matrix(11:20, ncol = 2, dimnames = list(NULL, c("a", "b")))) ref <- as_draws_list(matrix(11:20, ncol = 2, dimnames = list(NULL, c("x", "y[1]")))) expect_equal(variables(x), c("a", "b")) expect_equal(variables(ref), c("x", "y[1]")) variables(x) <- c("x", "y[1]") expect_equal(x, ref) }) test_that("variables() and variables<-() work on draws_df", { x <- as_draws_df(matrix(11:20, ncol = 2, dimnames = list(NULL, c("a", "b")))) ref <- as_draws_df(matrix(11:20, ncol = 2, dimnames = list(NULL, c("x", "y[1]")))) expect_equal(variables(x), c("a", "b")) expect_equal(variables(ref), c("x", "y[1]")) variables(x) <- c("x", "y[1]") expect_equal(x, ref) }) test_that("variables() and variables<-() work on draws_rvars", { x <- as_draws_rvars(matrix(11:20, ncol = 2, dimnames = list(NULL, c("a", "b")))) ref <- as_draws_rvars(matrix(11:20, ncol = 2, dimnames = list(NULL, c("x", "y[1]")))) # variables works a bit differently for draws_rvars expect_equal(variables(x), c("a", "b")) expect_equal(variables(ref), c("x", "y")) variables(x) <- c("x", "y") expect_equal(x, ref) }) test_that("variables() works on draws_df with duplicate columns", { # in the annoying case where someone manually changes a draws_df to have duplicate columns, # make sure that variables() returns the correct result... x <- as_draws_df(matrix(11:20, ncol = 2, dimnames = list(NULL, c("a", "b")))) names(x)[names(x) == "b"] = "a" expect_equal(variables(x), c("a", "a")) }) test_that("variables() works on NULL", { expect_equal(variables(NULL), NULL) }) posterior/tests/testthat/test-mutate_variables.R0000644000175000017500000000405414165314652022075 0ustar nileshnileshtest_that("mutate_variables works correctly for draws_df objects", { x <- as_draws_df(example_draws()) x <- mutate_variables(x, tau2 = tau^2) expect_equal(x$tau2, x$tau^2) x <- mutate_variables(x, scale = 1.96 * tau, lower = mu - scale) expect_equal(x$lower, x$mu - 1.96 * x$tau) x <- mutate_variables(x, mean = mean(mu)) expect_equal(x$mean, rep(mean(x$mu), NROW(x))) expect_error( mutate_variables(x, mu = as.character(mu)), "does not evaluate to a numeric vector" ) expect_error( mutate_variables(x, mu = mu[1:2]), "does not evaluate to a vector of length 1 or 400" ) }) test_that("mutate_variables works correctly for draws_list objects", { x <- as_draws_list(example_draws()) x <- mutate_variables(x, tau2 = tau^2) expect_equal(x[[1]]$tau2, x[[1]]$tau^2) expect_equal(x[[2]]$tau2, x[[2]]$tau^2) x <- mutate_variables(x, scale = 1.96 * tau, lower = mu - scale) expect_equal(x[[2]]$lower, x[[2]]$mu - 1.96 * x[[2]]$tau) x <- mutate_variables(x, mean = mean(mu)) expect_equal(x[[1]]$mean, rep(mean(x[[1]]$mu), niterations(x))) expect_error( mutate_variables(x, mu = as.character(mu)), "does not evaluate to a numeric vector" ) expect_error( mutate_variables(x, mu = mu[1:2]), "does not evaluate to a vector of length 1 or 100" ) }) test_that("mutate_variables works correctly for draws_matrix objects", { x <- as_draws_matrix(example_draws()) x <- mutate_variables(x, tau2 = tau^2) expect_equal(x[, "tau2"], x[, "tau"]^2, check.attributes = FALSE) }) test_that("mutate_variables works correctly for draws_array objects", { x <- as_draws_array(example_draws()) x <- mutate_variables(x, tau2 = tau^2) expect_equal(x[, , "tau2"], x[, , "tau"]^2, check.attributes = FALSE) }) test_that("mutate_variables works correctly for draws_rvars objects", { x <- as_draws_rvars(example_draws()) x <- mutate_variables(x, tau_sq = tau^2, theta_2_sq = theta[[2]]^2) expect_equal(x$tau_sq, x$tau^2, check.attributes = FALSE) expect_equal(x$theta_2_sq, x$theta[[2]]^2, check.attributes = FALSE) }) posterior/tests/testthat/test-subset_draws.R0000644000175000017500000001526714165314652021263 0ustar nileshnileshtest_that("subset_draws works correctly for draws_matrix objects", { x <- as_draws_matrix(example_draws()) x_sub <- subset_draws(x, variable = c("mu", "tau"), iteration = 5:10) x_sub2 <- x[c(5:10, 105:110, 205:210, 305:310), c("mu", "tau")] expect_equal(x_sub, x_sub2, check.attributes = FALSE) expect_equal(iteration_ids(x_sub), 1:6) x_sub <- subset_draws(x, draw = c(2, 2, 4, 4), unique = FALSE) expect_equal(niterations(x_sub), 4) expect_equivalent(x_sub[1, ], x_sub[2, ]) x <- weight_draws(x, rep(1, ndraws(x))) x_sub <- subset_draws(x, variable = "mu") expect_equal(variables(x_sub, reserved = TRUE), c("mu", ".log_weight")) }) test_that("subset_draws works correctly for draws_array objects", { x <- as_draws_array(example_draws()) x_sub <- subset_draws(x, variable = c("mu", "tau"), iteration = 5:10, chain = 3:4) expect_equal(x[5:10, 3:4, c("mu", "tau")], x_sub, check.attributes = FALSE) expect_equal(iteration_ids(x_sub), 1:6) expect_equal(chain_ids(x_sub), 1:2) x_sub <- subset_draws(x, chain = c(1, 1), unique = FALSE) expect_equal(nchains(x_sub), 2) expect_equivalent(x_sub[, 1, ], x_sub[, 2, ]) expect_message( x_sub <- subset_draws(x, draw = c(1, 200, 10)), "Merging chains in order to subset via 'draw'" ) expect_equal(niterations(x_sub), 3) x <- weight_draws(x, rep(1, ndraws(x))) x_sub <- subset_draws(x, variable = "mu") expect_equal(variables(x_sub, reserved = TRUE), c("mu", ".log_weight")) }) test_that("subset_draws works correctly for draws_df objects", { x <- as_draws_df(example_draws()) x_sub <- subset_draws(x, variable = c("mu", "tau"), iteration = 5:10, chain = 3:4) expect_equal(x$mu[x$.iteration %in% 5:10 & x$.chain %in% 3:4], x_sub$mu) expect_equal(iteration_ids(x_sub), 1:6) expect_equal(chain_ids(x_sub), 1:2) x_sub <- subset_draws(x, draw = c(5, 5, 6), unique = FALSE) expect_equal(ndraws(x_sub), 3) expect_equal(x_sub$mu[1], x_sub$mu[2]) x <- weight_draws(x, rep(1, ndraws(x))) x_sub <- subset_draws(x, variable = "mu") expect_equal(names(x_sub), c("mu", ".log_weight", ".chain", ".iteration", ".draw")) }) test_that("subset_draws works correctly for draws_list objects", { x <- as_draws_list(example_draws()) x_sub <- subset_draws(x, variable = c("theta[1]"), iteration = 5:10, chain = 3:4) expect_equal(variables(x_sub), "theta[1]") expect_equal(iteration_ids(x_sub), 1:6) expect_equal(chain_ids(x_sub), 1:2) x_sub <- subset_draws(x, iteration = c(1, 1, 2), unique = FALSE) expect_equal(niterations(x_sub), 3) expect_equal(x_sub[[1]]$mu[1], x_sub[[1]]$mu[2]) expect_message( x_sub <- subset_draws(x, draw = c(1, 200, 10)), "Merging chains in order to subset via 'draw'" ) expect_equal(niterations(x_sub), 3) x <- weight_draws(x, rep(1, ndraws(x))) x_sub <- subset_draws(x, variable = "mu") expect_equal(variables(x_sub, reserved = TRUE), c("mu", ".log_weight")) }) test_that("subset_draws works correctly for draws_rvars objects", { x <- as_draws_rvars(example_draws()) x_sub <- subset_draws(x, variable = c("mu"), iteration = 5:10, chain = 3:4) expect_equal(variables(x_sub), "mu") expect_equal(iteration_ids(x_sub), 1:6) expect_equal(chain_ids(x_sub), 1:2) x_sub <- subset_draws(x, iteration = c(1, 1, 2), unique = FALSE) expect_equal(niterations(x_sub), 3) expect_equal(draws_of(x_sub[[1]]$mu)[1], draws_of(x_sub[[1]]$mu)[2]) expect_message( x_sub <- subset_draws(x, draw = c(1, 200, 10)), "Merging chains in order to subset via 'draw'" ) expect_equal(niterations(x_sub), 3) x <- weight_draws(x, rep(1, ndraws(x))) x_sub <- subset_draws(x, variable = "mu") expect_equal(variables(x_sub, reserved = TRUE), c("mu", ".log_weight")) }) test_that("variables can be subsetted via regular expressions", { x <- as_draws_df(example_draws()) x_sub <- subset_draws(x, variable = c("theta\\[", "m"), regex = TRUE) expect_equal(variables(x_sub), c(paste0("theta[", 1:8, "]"), "mu")) # do the same thing using the 'subset' alias x_sub <- subset(x, variable = c("theta\\[", "m"), regex = TRUE) expect_equal(variables(x_sub), c(paste0("theta[", 1:8, "]"), "mu")) }) test_that("variables can be subsetted via non-scalar selection", { x <- as_draws_df(example_draws()) x_sub <- subset_draws(x, variable = "theta") expect_equal(variables(x_sub), c(paste0("theta[", 1:8, "]"))) }) test_that("subset_draws speed is tolerable with many variables", { # some machines will be slower and so this test is unreliable on CRAN skip_on_cran() x <- as_draws_matrix(matrix(rnorm(10 * 300000), nrow = 10)) tt <- system.time(x2 <- subset_draws(x, colnames(x))) expect_equal(x, x2) expect_lt(tt[["elapsed"]], 1) }) test_that("subset_draws errors if selecting missing variables", { x <- as_draws_matrix(example_draws()) expect_error( subset_draws(x, variable = c("theta[2]", "X", "theta[3]", "Y")), "The following variables are missing in the draws object: {'X', 'Y'}", fixed = TRUE ) }) test_that("subset_draws preserves variable order", { x <- as_draws_matrix(example_draws()) x <- subset_draws(x, variable = c("theta[2]", "theta[1]")) expect_equal(variables(x), c("theta[2]", "theta[1]")) }) test_that("subset_draws preserves variable order with vectors", { x <- as_draws_matrix(example_draws()) theta_names <- paste0("theta[", 1:8, "]") # Expect variables to be returned in the order listed: v1 <- variables(subset_draws(x, variable = c("theta", "mu"))) expect_equal(v1, c(theta_names, "mu")) v2 <- variables(subset_draws(x, variable = c("mu", "theta"))) expect_equal(v2, c("mu", theta_names)) v3 <- variables(subset_draws(x, variable = c("mu", "theta", "tau"))) expect_equal(v3, c("mu", theta_names, "tau")) # No duplication: v4 <- variables(subset_draws(x, variable = c("mu", "mu", "theta"))) expect_equal(v4, c("mu", theta_names)) v5 <- variables(subset_draws(x, variable = c("mu", "theta", "theta"))) expect_equal(v5, c("mu", theta_names)) v6 <- variables(subset_draws(x, variable = c("theta", "mu", "theta"))) expect_equal(v6, c(theta_names, "mu")) # Output is sorted numerically, not alphabetically x2 <- as_draws_matrix(matrix(rep.int(1, 11 * 3), ncol = 11)) colnames(x2) <- paste0("a[",1:11,"]") v7 <- variables(subset_draws(x2, variable = "a")) expect_equal(v7, colnames(x2)) }) test_that("non-unique subsetting for draws_df same as doing it with draws_list", { x_df <- as_draws_df(example_draws()) x_list <- as_draws_list(example_draws()) x_df_sub <- subset_draws(x_df, chain = c(1,1,2), iteration = c(1:2, 1:50), unique = FALSE) x_list_sub <- subset_draws(x_list, chain = c(1,1,2), iteration = c(1:2, 1:50), unique = FALSE) expect_equal(x_df_sub, as_draws_df(x_list_sub)) }) posterior/tests/testthat/test-thin_draws.R0000644000175000017500000000051513564461025020705 0ustar nileshnileshtest_that("thin_draws works correctly", { x <- as_draws_array(example_draws()) expect_equal(niterations(thin_draws(x, 5L)), niterations(x) / 5) expect_equal(x, thin_draws(x, thin = 1L)) expect_error(thin_draws(x, -1), "'thin' must be a positive integer") expect_error(thin_draws(x, 1000), "'thin' must be smaller than") }) posterior/tests/testthat/test-rvar-cast.R0000755000175000017500000001222514165314655020455 0ustar nileshnilesh# as_rvar ----------------------------------------------------------------- test_that("as_rvar works", { expect_equal(draws_of(as_rvar(1L)), matrix(1L, dimnames = list("1", NULL))) expect_equal(draws_of(as_rvar(c(TRUE, FALSE))), matrix(c(TRUE, FALSE), nrow = 1, dimnames = list("1", NULL))) expect_equal(draws_of(as_rvar(1:3L)), matrix(1:3L, nrow = 1, dimnames = list("1", NULL))) expect_equal(draws_of(as_rvar(1:3L)), matrix(1:3L, nrow = 1, dimnames = list("1", NULL))) expect_equal(nchains(as_rvar(1, nchains = 2)), 2) expect_equal(draws_of(as_rvar(1:6, dim = c(2,3))), array(1:6, dim = c(1,2,3), dimnames = list("1", NULL, NULL))) expect_equal( draws_of(as_rvar(1:6, dim = c(2,3), dimnames = list(letters[1:2], letters[1:3]))), array(1:6, dim = c(1,2,3), dimnames = list("1", letters[1:2], letters[1:3])) ) }) test_that("as_rvar preserves dimension names", { m <- diag(1:3) dimnames(m) <- list(a = paste0("a", 1:3), b = paste0("b", 1:3)) m_rvar <- as_rvar(m) expect_equal(dimnames(m_rvar), dimnames(m)) x <- 1:3 names(x) <- c("a","b","c") x_rvar <- as_rvar(x) expect_equal(names(x_rvar), names(x)) }) # casting to/from rvar/distribution --------------------------------------- test_that("casting to/from rvar/distribution objects works", { x_dist <- distributional::dist_sample(list(a = c(1,1), b = 3:4)) null_dist <- vctrs::vec_ptype(x_dist) x_rvar <- rvar(matrix(c(1,1,3:4), ncol = 2, dimnames = list(NULL, c("a","b")))) # casting to rvar expect_equal(vctrs::vec_cast(x_dist, rvar()), x_rvar) expect_equal(as_rvar(x_dist), x_rvar) # casting to rvar with a broadcast x_dist_bc <- distributional::dist_sample(list(a = 1, b = 3:4)) expect_equal(vctrs::vec_cast(x_dist_bc, rvar()), x_rvar) # can't cast non-sample distributions to rvar expect_error(vctrs::vec_cast(distributional::dist_normal(), rvar())) # can't cast samples of incompatible sizes to rvar expect_error(vctrs::vec_cast(distributional::dist_sample(list(1:3, 1:2)), rvar())) # casting to distribution expect_equal(vctrs::vec_cast(x_rvar, null_dist), x_dist) # can't cast multivariate rvars to distributions x_mv <- rvar(array(1:8, dim = c(2,2,2))) expect_error(vctrs::vec_cast(x_mv, null_dist)) }) # type predicates --------------------------------------------------------- test_that("is.matrix/array on rvar works", { x_mat <- rvar(array(1:24, dim = c(2,2,6))) x_arr <- rvar(array(1:24, dim = c(2,2,3,2))) expect_true(is.matrix(x_mat)) expect_true(is.array(x_mat)) expect_false(is.matrix(x_arr)) expect_true(is.array(x_arr)) }) # type conversion ----------------------------------------------------------- test_that("as.list works", { x_array = array( 1:24, dim = c(2,4,3), dimnames = list(NULL, A = paste0("a", 1:4), B = paste0("b", 1:3)) ) x = new_rvar(x_array) expect_equal(as.list(x), list( a1 = new_rvar(x_array[,1,]), a2 = new_rvar(x_array[,2,]), a3 = new_rvar(x_array[,3,]), a4 = new_rvar(x_array[,4,]) ) ) }) test_that("as.vector works", { x = rvar(array(1:12, dim = c(2, 2, 3))) dimnames(x) <- list(c("a","b"), c("c","d","e")) expect_equal(as.vector(x), rvar(array(1:12, dim = c(2, 6)))) }) test_that("as.data.frame and as_tibble work on rvars", { x1 = rvar(array(1:9, dim = c(3,3)), dimnames = list(A = paste0("a", 1:3)) ) x2 = rvar(array(1:12, dim = c(2,2,3)), dimnames = list(A = paste0("a", 1:2), B = paste0("b", 1:3)) ) x3 = rvar(array(1:24, dim = c(2,2,2,4)), dimnames = list(A = paste0("a", 1:2), B = paste0("b", 1:2), C = paste0("c", 1:4)) ) # constructing reference data frames with rvars in them without having that # code call as.data.frame() (defeating the purpose of the test) requires # bypassing the data.frame() constructor being called on an rvar, as it would # call as.data.frame.rvar(). Hence the twisty code below. # nulls df0 <- data.frame() df0[["rvar()"]] <- rvar() row.names(df0) <- numeric() expect_equal(as.data.frame(rvar()), df0) tibble0 <- as_tibble(df0) names(tibble0) <- "value" expect_equal(as_tibble(rvar()), tibble0) # 1-dim arrays df1 <- as.data.frame(mean(x1)) names(df1) <- "x1" df1$x1 <- x1 dimnames(df1$x1)["A"] <- list(NULL) expect_equal(as.data.frame(x1), df1) tibble1 <- as_tibble(df1) names(tibble1) <- "value" expect_equal(as_tibble(x1), tibble1) # 2-dim arrays df2 <- as.data.frame(mean(x2)) for (i in 1:3) { col <- x2[,i,drop = TRUE] dimnames(col) <- list(NULL) df2[[i]] <- col } expect_equal(as.data.frame(x2), df2) expect_equal(dimnames(as.data.frame(unname(x2))), dimnames(as.data.frame(mean(unname(x2))))) tibble2 <- as_tibble(df2) expect_equal(as_tibble(x2), tibble2) # 3-dim arrays df3 <- as.data.frame(mean(x3)) for (c_i in 1:4) for (b_i in 1:2) { col <- x3[,b_i,c_i,drop = TRUE] dimnames(col) <- list(NULL) df3[[b_i + (c_i - 1) * 2]] <- col } expect_equal(as.data.frame(x3), df3) expect_equal(dimnames(as.data.frame(unname(x3))), dimnames(as.data.frame(mean(unname(x3))))) tibble3 <- as_tibble(df3) expect_equal(as_tibble(x3), tibble3) }) test_that("as.character works", { x <- rvar(c(1,1)) expect_equal(as.character(x), format(x)) }) posterior/tests/testthat/test-rvar-.R0000755000175000017500000002067414165314655017611 0ustar nileshnilesh# function for making rvars from arrays that expects last index to be # draws (for testing so that when array structure changes tests don't have to) rvar_from_array = function(x) { .dim = dim(x) last_dim = length(.dim) new_rvar(aperm(x, c(last_dim, seq_len(last_dim - 1)))) } # creating rvars ---------------------------------------------------------- test_that("rvar creation with custom dim works", { x_matrix <- array(1:24, dim = c(2,12)) x_array <- array(1:24, dim = c(2,3,4)) expect_equal(rvar(x_matrix, dim = c(3,4)), rvar(x_array)) }) test_that("rvar can be created with specified number of chains", { x_array <- array(1:20, dim = c(4,5)) expect_error(rvar(x_array, nchains = 0)) expect_equal(rvar(x_array, nchains = 1), rvar(x_array)) expect_equal(nchains(rvar(x_array, nchains = 2)), 2) expect_error(rvar(x_array, nchains = 3), "Number of chains does not divide the number of draws") }) test_that("rvar constructor using with_chains works", { # multidimensional rvar with chains x_array_nochains <- array(1:24, dim = c(6,2,2), dimnames = list( NULL, A = c("a1", "a2"), B = c("b1", "b2") )) x_array_chains <- array(1:24, dim = c(3,2,2,2), dimnames = list( NULL, NULL, A = c("a1", "a2"), B = c("b1", "b2") )) x_nochains <- rvar(x_array_nochains, nchains = 2) x_chains <- rvar(x_array_chains, with_chains = TRUE) expect_equal(x_chains, x_nochains) # scalar rvar with chains x2_array_nochains <- 1:24 x2_array_chains <- array(1:24, dim = c(6,4)) x2_nochains <- rvar(x2_array_nochains, nchains = 4) x2_chains <- rvar(x2_array_chains, with_chains = TRUE) expect_equal(x2_chains, x2_nochains) # NULL rvar expect_equal(rvar(with_chains = TRUE), rvar()) # can't use with_chains when no chain dimension information provided expect_error(rvar(1, with_chains = TRUE)) }) # draws_of ---------------------------------------------------------------- test_that("draws_of using with_chains works", { # retrieving a multidimensional rvar with draws_of using with_chains x_array_nochains <- array(1:24, dim = c(6,2,2), dimnames = list( NULL, A = c("a1", "a2"), B = c("b1", "b2") )) x_array_chains <- array(1:24, dim = c(3,2,2,2), dimnames = list( NULL, NULL, A = c("a1", "a2"), B = c("b1", "b2") )) x <- rvar(x_array_nochains, nchains = 2) expect_equal(draws_of(x, with_chains = TRUE), x_array_chains) # setting a multidimensional rvar with draws_of using with_chains x2_array_nochains <- x_array_nochains + 2 x2_array_chains <- array(1:24 + 2, dim = c(2,3,2,2), dimnames = list( NULL, NULL, A = c("a1", "a2"), B = c("b1", "b2") )) x2 <- x draws_of(x2, with_chains = TRUE) <- x2_array_chains expect_equal(x2, rvar(x2_array_nochains, nchains = 3)) # retrieving a scalar rvar with draws_of using with_chains x2_array_nochains <- 1:24 x2_array_chains <- array(1:24, dim = c(6,4,1), dimnames = list(NULL)) x2 <- rvar(x2_array_nochains, nchains = 4) expect_equal(draws_of(x2, with_chains = TRUE), x2_array_chains) # setting a scalar rvar with draws_of using with_chains x3_array_nochains <- 1:24 + 2 x3_array_chains <- array(1:24 + 2, dim = c(12,2), dimnames = list(NULL)) x3 <- x2 draws_of(x3, with_chains = TRUE) <- x3_array_chains expect_equal(x3, rvar(x3_array_nochains, nchains = 2)) # NULL rvar expect_equal(draws_of(rvar(), with_chains = TRUE), array(numeric(), dim = c(1,1,0), dimnames = list(NULL))) x_null <- x draws_of(x_null, with_chains = TRUE) = numeric() expect_equal(x_null, rvar()) # can't use with_chains when no chain dimension information provided expect_error(draws_of(x, with_chains = TRUE) <- 1) }) # unique, duplicated, etc ------------------------------------------------- test_that("unique.rvar and duplicated.rvar work", { x <- rvar_from_array(matrix(c(1,2,1, 1,2,1, 3,3,3), nrow = 3)) unique_x <- rvar_from_array(matrix(c(1,2, 1,2, 3,3), nrow = 2)) expect_equal(unique(x), unique_x) expect_equal(as.vector(duplicated(x)), c(FALSE, FALSE, TRUE)) expect_equal(anyDuplicated(x), 3) x <- rvar(array(c(1,2, 2,3, 1,2, 3,3, 1,2, 2,3), dim = c(2, 2, 3))) unique_x <- x unique_x_2 <- rvar(array(c(1,2, 2,3, 1,2, 3,3), dim = c(2, 2, 2))) expect_equal(unique(x), unique_x) expect_equal(unique(x, MARGIN = 2), unique_x_2) }) # tibbles ----------------------------------------------------------------- test_that("rvars work in tibbles", { skip_if_not_installed("dplyr") skip_if_not_installed("tidyr") x_array = array(1:20, dim = c(4,5)) x = rvar_from_array(x_array) df = tibble::tibble(x, y = x + 1) expect_equal(df$x, x) expect_equal(df$y, rvar_from_array(x_array + 1)) expect_equal(dplyr::mutate(df, z = x)$z, x) expect_equal(dplyr::mutate(df, z = x * 2)$z, rvar_from_array(x_array * 2)) expect_equal( dplyr::mutate(dplyr::group_by(df, 1:4), z = x * 2)$z, rvar_from_array(x_array * 2) ) df = tibble::tibble(g = letters[1:4], x) ref = tibble::tibble( a = rvar_from_array(x_array[1,, drop = FALSE]), b = rvar_from_array(x_array[2,, drop = FALSE]), c = rvar_from_array(x_array[3,, drop = FALSE]), d = rvar_from_array(x_array[4,, drop = FALSE]) ) expect_equal(tidyr::pivot_wider(df, names_from = g, values_from = x), ref) expect_equal(tidyr::pivot_longer(ref, a:d, names_to = "g", values_to = "x"), df) df$y = df$x + 1 ref2 = tibble::tibble( y = df$y, a = c(df$x[[1]], NA, NA, NA), b = c(rvar(NA), df$x[[2]], NA, NA), c = c(rvar(NA), NA, df$x[[3]], NA), d = c(rvar(NA), NA, NA, df$x[[4]]), ) expect_equal(tidyr::pivot_wider(df, names_from = g, values_from = x), ref2) }) # broadcasting ------------------------------------------------------------ test_that("broadcast_array works", { expect_equal(broadcast_array(5, c(1,2,3,1)), array(rep(5, 6), dim = c(1,2,3,1))) expect_equal( broadcast_array(array(1:4, c(1,4), dimnames = list("x", letters[1:4])), c(2,4)), array(rep(1:4, each = 2), c(2,4), dimnames = list(NULL, letters[1:4])) ) expect_equal( broadcast_array(array(1:4, c(4,1)), c(4,2)), array(c(1:4, 1:4), c(4,2)) ) expect_equal( broadcast_array(array(1:2, dimnames = list(c("a","b"))), c(2,1,1,1)), array(1:2, c(2,1,1,1), dimnames = list(c("a","b"), NULL, NULL, NULL)) ) expect_error(broadcast_array(array(1:9, dim = c(3,3)), c(1,9))) expect_error(broadcast_array(array(1:9, dim = c(3,3)), c(9))) }) # conforming chains / draws ----------------------------------------------- test_that("warnings for unequal draws/chains are correct", { options(posterior.warn_on_merge_chains = TRUE) expect_warning( expect_equal(rvar(1:10) + rvar(1:10, nchains = 2), rvar(1:10 + 1:10)), "Chains were dropped due to chain information not matching" ) options(posterior.warn_on_merge_chains = FALSE) expect_error( draws_rvars(x = rvar(1:10), y = rvar(1:11)), "variables have different number of draws" ) expect_error( rvar(1:10, nchains = 0), "chains must be >= 1" ) }) # rep --------------------------------------------------------------------- test_that("rep works", { x_array = array(1:10, dim = c(5,2)) x = rvar(x_array) expect_equal(rep(x, times = 3), new_rvar(cbind(x_array, x_array, x_array))) expect_equal(rep.int(x, 3), new_rvar(cbind(x_array, x_array, x_array))) each_twice = cbind(x_array[,1], x_array[,1], x_array[,2], x_array[,2]) expect_equal(rep(x, each = 2), new_rvar(each_twice)) expect_equal(rep(x, each = 2, times = 3), new_rvar(cbind(each_twice, each_twice, each_twice))) expect_equal(rep(x, length.out = 3), new_rvar(cbind(x_array, x_array[,1]))) expect_equal(rep_len(x, 3), new_rvar(cbind(x_array, x_array[,1]))) }) # all.equal --------------------------------------------------------------------- test_that("all.equal works", { x_array = array(1:10, dim = c(5,2)) x = rvar(x_array) expect_true(all.equal(x, x)) expect_true(!isTRUE(all.equal(x, x + 1))) expect_true(!isTRUE(all.equal(x, "a"))) }) # apply functions --------------------------------------------------------- test_that("apply family functions work", { x_array = array(1:24, dim = c(2,3,4)) x = rvar(x_array) expect_equal(lapply(x, function(x) sum(draws_of(x))), as.list(apply(draws_of(x), 2, sum))) expect_equal(sapply(x, function(x) sum(draws_of(x))), apply(draws_of(x), 2, sum)) expect_equal(vapply(x, function(x) sum(draws_of(x)), numeric(1)), apply(draws_of(x), 2, sum)) expect_equal(apply(x, 1, function(x) sum(draws_of(x))), apply(draws_of(x), 2, sum)) expect_equal(apply(x, 1:2, function(x) sum(draws_of(x))), apply(draws_of(x), 2:3, sum)) }) posterior/tests/testthat/test-weight_draws.R0000644000175000017500000000340114165314652021230 0ustar nileshnileshtest_that("weight_draws works on draws_matrix", { x <- as_draws_matrix(example_draws()) weights <- rexp(ndraws(x)) x1 <- weight_draws(x, weights) weights1 <- weights(x1, normalize = FALSE) expect_equal(weights1, weights) x2 <- weight_draws(x, log(weights), log = TRUE) weights2 <- weights(x2) expect_equal(weights2, weights / sum(weights)) }) test_that("weight_draws works on draws_array", { x <- as_draws_array(example_draws()) weights <- rexp(ndraws(x)) x1 <- weight_draws(x, weights) weights1 <- weights(x1) expect_equal(weights1, weights / sum(weights)) x2 <- weight_draws(x, log(weights), log = TRUE) weights2 <- weights(x2, normalize = FALSE) expect_equal(weights2, weights) }) test_that("weight_draws works on draws_df", { x <- as_draws_df(example_draws()) weights <- rexp(ndraws(x)) x1 <- weight_draws(x, weights) weights1 <- weights(x1, normalize = FALSE) expect_equal(weights1, weights) x2 <- weight_draws(x, log(weights), log = TRUE) weights2 <- weights(x2) expect_equal(weights2, weights / sum(weights)) }) test_that("weight_draws works on draws_list", { x <- as_draws_list(example_draws()) weights <- rexp(ndraws(x)) x1 <- weight_draws(x, weights) weights1 <- weights(x1) expect_equal(weights1, weights / sum(weights)) x2 <- weight_draws(x, log(weights), log = TRUE) weights2 <- weights(x2, normalize = FALSE) expect_equal(weights2, weights) }) test_that("weight_draws works on draws_rvars", { x <- as_draws_rvars(example_draws()) weights <- rexp(ndraws(x)) x1 <- weight_draws(x, weights) weights1 <- weights(x1) expect_equal(weights1, weights / sum(weights)) x2 <- weight_draws(x, log(weights), log = TRUE) weights2 <- weights(x2, normalize = FALSE) expect_equal(weights2, weights) }) posterior/tests/testthat/test-rvar-dim.R0000755000175000017500000000070214165314652020266 0ustar nileshnileshtest_that("assigning NULL dim to rvar works", { x <- rvar(array(1:20, dim = c(2,2,5))) dim(x) <- NULL expect_equal(x, rvar(array(1:20, dim = c(2,10)))) }) # names ------------------------------------------------------------------- test_that("unname() works", { x_array = array(1:24, dim = c(2,3,4), dimnames = list(NULL, A = paste0("a", 1:3), B = paste0("b", 1:4))) x = rvar(x_array) expect_equal(unname(x), rvar(unname(x_array))) }) posterior/tests/testthat/test-rstar.R0000644000175000017500000000706414165314655017710 0ustar nileshnilesh test_that("rstar returns reasonable values", { skip_if_not_installed("caret") x <- example_draws() val <- rstar(x) expect_true(val > 0.8 & val < 10) }) test_that("rstar works with 1d example", { skip_if_not_installed("caret") x <- example_draws() x <- as_draws_df(x) # remove all bar one variable x <- x[, c(variables(x)[1], ".chain", ".iteration", ".draw")] val <- rstar(x) expect_true(val > 0.5 & val < 10) }) test_that("rstar works with draws_df example", { skip_if_not_installed("caret") x <- example_draws() x <- as_draws_df(x) val <- rstar(x) expect_true(val > 0.5 & val < 10) }) test_that("rstar with uncertainty returns vectors of correct length", { skip_if_not_installed("caret") x <- example_draws() val <- rstar(x, method = "gbm", uncertainty = T, verbose = F) expect_equal(length(val), 1000) val <- rstar(x, method = "knn", uncertainty = T, nsimulations = 10) expect_equal(length(val), 10) }) test_that("incorrect nsimulations values throws error", { skip_if_not_installed("caret") x <- example_draws() expect_error(rstar(x, method = "knn", nsimulations = 0), "'nsimulations' must be greater than or equal to 1.") }) test_that("rstar with uncertainty returns reasonable values", { skip_if_not_installed("caret") x <- example_draws() val <- rstar(x, method = "gbm", uncertainty = T, verbose = F) expect_true(max(val) > 0.3 & min(val) < 10) }) test_that("rstar accepts different classifiers", { skip_if_not_installed("caret") x <- example_draws() val <- rstar(x, method = "gbm", verbose=F) expect_true(is.numeric(val)) val <- rstar(x, method = "knn") expect_true(is.numeric(val)) }) test_that("rstar accepts different hyperparameters", { skip_if_not_installed("caret") x <- example_draws() # use fast hyperparameters caret_grid <- data.frame(interaction.depth=c(3), n.trees = 1, shrinkage=c(0.1), n.minobsinnode=10) start <- Sys.time() val <- rstar(x, method = "gbm", verbose=F, hyperparameters = caret_grid) end <- Sys.time() dif1 <- end - start # use slower hyperparameters caret_grid <- data.frame(interaction.depth=c(3), n.trees = 1000, shrinkage=c(0.1), n.minobsinnode=10) start <- Sys.time() val <- rstar(x, method = "gbm", verbose=F, hyperparameters = caret_grid) end <- Sys.time() dif2 <- end - start expect_true(dif1 < dif2) }) test_that("rstar accepts different training proportion", { skip_if_not_installed("caret") x <- example_draws() val1 <- rstar(x, method = "knn") val2 <- rstar(x, method = "knn", training_proportion = 0.1) expect_true(val1 > val2) }) test_that("rstar throws error when passed invalid training_proportion", { skip_if_not_installed("caret") x <- example_draws() expect_error(rstar(x, method = "knn", training_proportion = 0), "'training_proportion' must be greater than 0 and less than 1") expect_error(rstar(x, method = "knn", training_proportion = 1), "'training_proportion' must be greater than 0 and less than 1") }) test_that("split-chain R* returns generally higher values", { skip_if_not_installed("caret") skip_on_cran() # reduces test time x <- example_draws() n <- 10 vals_split <- vector(length = n) vals_unsplit <- vector(length = n) for(i in 1:n) { vals_split[i] <- rstar(x, method = "knn") vals_unsplit[i] <- rstar(x, method = "knn", split = FALSE) } expect_true(median(vals_split) > median(vals_unsplit)) }) posterior/tests/testthat/test-repair_draws.R0000644000175000017500000000564614065624365021244 0ustar nileshnileshtest_that("repair_draws works correctly on draws_matrix objects", { x <- as_draws_matrix(example_draws()) x <- x[10:6, ] x_rep <- repair_draws(x, order = TRUE) expect_equal(x[5:1, ], x_rep, check.attributes = FALSE) expect_equal(rownames(x_rep), as.character(1:5)) x_rep <- repair_draws(x, order = FALSE) expect_equal(x, x_rep, check.attributes = FALSE) expect_equal(rownames(x_rep), as.character(1:5)) }) test_that("repair_draws works correctly on draws_array objects", { x <- as_draws_array(example_draws()) x <- x[10:6, c(4, 1), ] x_rep <- repair_draws(x, order = TRUE) expect_equal(x[5:1, 2:1, ], x_rep, check.attributes = FALSE) expect_equal(rownames(x_rep), as.character(1:5)) expect_equal(colnames(x_rep), as.character(1:2)) x_rep <- repair_draws(x, order = FALSE) expect_equal(x, x_rep, check.attributes = FALSE) expect_equal(rownames(x_rep), as.character(1:5)) expect_equal(colnames(x_rep), as.character(1:2)) }) test_that("repair_draws works correctly on draws_df objects", { x <- as_draws_df(example_draws()) x <- subset(x, iteration = 1:5) x <- x[c(16, 11, 8, 2), ] x_rep <- repair_draws(x, order = TRUE) expect_equal(x$mu[order(x$.chain, x$.iteration)], x_rep$mu) expect_equal(x_rep$.iteration, rep(1, 4)) expect_equal(x_rep$.chain, 1:4) x_rep <- repair_draws(x, order = FALSE) expect_equal(x$mu, x_rep$mu, check.attributes = FALSE) expect_equal(x_rep$.iteration, rep(1, 4)) expect_equal(x_rep$.chain, 4:1) }) test_that("repair_draws works correctly on draws_list objects", { x <- as_draws_list(example_draws()) x <- x[c(4, 2)] x_rep <- repair_draws(x, order = TRUE) expect_equal(x[2], x_rep[1], check.attributes = FALSE) expect_equal(names(x_rep), as.character(1:2)) x_rep <- repair_draws(x, order = FALSE) expect_equal(x, x_rep, check.attributes = FALSE) expect_equal(names(x_rep), as.character(1:2)) }) test_that("repair_draws works correctly on draws_rvars objects", { x <- as_draws_rvars(example_draws()) draws_of(x$mu) <- draws_of(x$mu)[c(16, 11, 8, 2),, drop = FALSE] draws_of(x$tau) <- draws_of(x$tau)[c(16, 11, 8, 2),, drop = FALSE] draws_of(x$theta) <- draws_of(x$theta)[c(16, 11, 8, 2),, drop = FALSE] x_rep <- repair_draws(x, order = TRUE) expect_equal( draws_of(x_rep$mu), draws_of(x$mu)[order(as.integer(rownames(draws_of(x$mu)))),], check.attributes = FALSE ) expect_equal(niterations(x_rep), 4) expect_equal(nchains(x_rep), 1) x_rep <- repair_draws(x, order = FALSE) expect_equal(draws_of(x$mu), draws_of(x_rep$mu), check.attributes = FALSE) expect_equal(niterations(x_rep), 4) expect_equal(nchains(x_rep), 1) x_ord <- order_draws(x) expect_equal( draws_of(x_ord$mu), draws_of(x$mu)[order(as.integer(rownames(draws_of(x$mu)))),], check.attributes = FALSE ) expect_equal( draws_of(x_ord$theta), draws_of(x$theta)[order(as.integer(rownames(draws_of(x$theta)))),], check.attributes = FALSE ) }) posterior/tests/testthat/test-rename_variables.R0000644000175000017500000000412713667472425022057 0ustar nileshnilesh# since rename_variables is just a wrapper around variables() this only # tests it on draws_matrix for now. See the tests for variables() for # format-specific tests. test_that("rename_variables works on draws_matrix", { x = as_draws_matrix(matrix(11:20, ncol = 2, dimnames = list(NULL, c("a", "b[1]")))) ref = as_draws_matrix(matrix(11:20, ncol = 2, dimnames = list(NULL, c("mu", "b[1]")))) expect_equal(rename_variables(x, mu = a), ref) expect_equal(rename_variables(x, mu = "a"), ref) ref = as_draws_matrix(matrix(11:20, ncol = 2, dimnames = list(NULL, c("c", "d")))) expect_equal(rename_variables(x, c = a, d = `b[1]`), ref) expect_equal(rename_variables(x, c = a, d = "b[1]"), ref) # renaming can be chained expect_equal(rename_variables(x, e = a, d = `b[1]`, c = e), ref) # no renaming expect_equal(rename_variables(x), x) }) test_that("rename_variables works for non-scalar variables", { x <- example_draws() x <- rename_variables(x, alpha = theta) vars <- c("mu", "tau", paste0("alpha[", 1:8, "]")) expect_equal(variables(x), vars) }) test_that("cannot rename a variable to a reserved word", { x = as_draws_matrix(matrix(11:20, ncol = 2, dimnames = list(NULL, c("a", "b[1]")))) err = "Variable names.*are reserved" expect_error(rename_variables(x, .chain = a), err) expect_error(rename_variables(x, .iteration = a), err) expect_error(rename_variables(x, .draw = a), err) }) test_that("cannot rename a variable to an existing variable name", { x = as_draws_matrix(matrix(11:20, ncol = 2, dimnames = list(NULL, c("a", "b[1]")))) expect_error(rename_variables(x, a = "b[1]"), "Duplicate variable names are not allowed") }) test_that("cannot rename a variable to an empty name", { x = as_draws_matrix(matrix(11:20, ncol = 2, dimnames = list(NULL, c("a", "b[1]")))) expect_error(rename_variables(x, a), "Cannot rename a variable to an empty name") }) test_that("cannot rename a non-existent variable", { x = as_draws_matrix(matrix(11:20, ncol = 2, dimnames = list(NULL, c("a", "b[1]")))) expect_error(rename_variables(x, a = c), "The following variables are missing") }) posterior/tests/testthat/test-summarise_draws.R0000644000175000017500000001204214165314655021752 0ustar nileshnileshtest_that("summarise_draws works correctly", { x <- as_draws_df(example_draws()) sum_x <- summarise_draws(x) expect_true(all(default_convergence_measures() %in% names(sum_x))) expect_true(all(c("q5", "q95") %in% names(sum_x))) expect_equal(sum_x$variable, variables(x)) expect_equal(mean(x$mu), sum_x$mean[sum_x$variable == "mu"]) sum_x <- summarise_draws(x, mean, median) expect_true(all(c("mean", "median") %in% names(sum_x))) sum_x <- summarise_draws(x, default_mcse_measures()) expect_true(all(c("mcse_q5", "mcse_q95") %in% names(sum_x))) sum_x <- summarise_draws(x, ~quantile(.x, probs = c(0.4, 0.6))) expect_true(all(c("40%", "60%") %in% names(sum_x))) x[1, 1] <- NA sum_x <- summarise_draws(x) expect_true(is.na(sum_x[1, "q5"])) expect_true(all(c("q5", "q95") %in% names(sum_x))) }) test_that("aliases of summarise_draws work", { x <- as_draws_array(example_draws()) sum_x <- summarise_draws(x) sum_x2 <- summarize_draws(x) expect_equal(sum_x, sum_x2) sum_x3 <- summary(x) expect_equal(sum_x, sum_x3) }) test_that("summarise_draws errors if name 'variable' is used", { x <- example_draws() variable <- function(x) mean(x) expect_error( summarise_draws(x, "variable"), "Name 'variable' is reserved in 'summarise_draws'" ) }) test_that("summarise_draws default method works", { expect_identical( summarise_draws(matrix(1:20, 10, 2)), summarise_draws(as_draws_matrix(matrix(1:20, 10, 2))) ) }) test_that("summarise_draws doesn't error for empty draws", { expect_identical( summarise_draws(empty_draws_array()), empty_draws_summary() ) }) test_that("summarise_draws and summary work for rvars", { d <- as_draws_rvars(example_draws()) d_theta <- draws_rvars(x = d$theta) names(d_theta) <- "d$theta" ref <- summarise_draws(d_theta) expect_identical(summarise_draws(d$theta), ref) expect_identical(summary(d$theta), ref) }) test_that("summarise_draws warns if all variable names are reserved", { x <- subset_draws(as_draws_df(example_draws()), variable = "mu") variables(x) <- ".log_weight" expect_warning(summarize_draws(x), "no variables with unreserved names") }) test_that(paste( "multicore summarise_draws is identical to single-core summarise_draws", "including if some chunks contain no variables" ), { set.seed(1) cores <- 2 nc <- 4 n <- 20 test_array <- array(data = rnorm(1000*nc*n), dim = c(1000,nc,n)) x <- as_draws_array(test_array) sum_x <- summarise_draws(x) parsum_x <- summarise_draws(x, .cores = cores) expect_equal(sum_x, parsum_x) dimnames(x)$variable[2] <- reserved_variables()[1] sum_x <- summarise_draws(x) parsum_x <- summarise_draws(x, .cores = cores) expect_equal(sum_x, parsum_x) # test that externally defined summary functions can be found mean2 <- function(x) sum(x) / length(x) sum_x <- summarise_draws(x, mean2) parsum_x <- summarise_draws(x, mean2, .cores = cores) expect_identical(sum_x, parsum_x) n <- 2 test_array <- array(data = rnorm(1000*nc*n), dim = c(1000,nc,n)) x <- as_draws_array(test_array) sum_x <- summarise_draws(x) parsum_x <- summarise_draws(x, .cores = cores) expect_identical(sum_x, parsum_x) dimnames(x)$variable[2] <- reserved_variables()[1] sum_x <- summarise_draws(x) parsum_x <- summarise_draws(x, .cores = cores) expect_identical(sum_x, parsum_x) n <- 1 test_array <- array(data = rnorm(1000*nc*n), dim = c(1000,nc,n)) x <- as_draws_array(test_array) sum_x <- summarise_draws(x) parsum_x <- summarise_draws(x, .cores = cores) expect_identical(sum_x, parsum_x) dimnames(x)$variable[1] <- reserved_variables()[1] suppressWarnings(sum_x <- summarise_draws(x)) suppressWarnings(parsum_x <- summarise_draws(x, .cores = cores)) expect_identical(sum_x, parsum_x) }) test_that("summarise_draws errors for invalid cores specification", { x <- example_draws() expect_error( summarise_draws(x, .cores = -1), "'.cores' must be a positive integer" ) expect_error( summarise_draws(x, .cores = NULL), "Cannot coerce '.cores' to a single integer value" ) }) test_that("summarise_draws works with variance()", { draws_array <- as_draws_array(example_draws()) draws_matrix <- as_draws_matrix(draws_array) draws_df <- as_draws_df(draws_array) draws_list <- as_draws_list(draws_array) draws_rvars <- as_draws_rvars(draws_array) ref <- data.frame( variable = variables(draws_array), variance = as.vector(apply(draws_array, 3, function(x) var(as.vector(x)))), stringsAsFactors = FALSE ) class(ref) <- class_draws_summary() expect_equal(summarise_draws(draws_array, variance), ref) expect_equal(summarise_draws(draws_matrix, variance), ref) expect_equal(summarise_draws(draws_df, variance), ref) expect_equal(summarise_draws(draws_list, variance), ref) expect_equal(summarise_draws(draws_rvars, variance), ref) # for consistency, draws_matrix and draws_array # have the same implementation of variance() expect_equal(variance(draws_array), var(as.vector(draws_array))) expect_equal(variance(draws_matrix), var(as.vector(draws_matrix))) }) posterior/tests/testthat/test-rvar-slice.R0000755000175000017500000002330114165314652020614 0ustar nileshnilesh# function for making rvars from arrays that expects last index to be # draws (for testing so that when array structure changes tests don't have to) rvar_from_array = function(x) { .dim = dim(x) last_dim = length(.dim) new_rvar(aperm(x, c(last_dim, seq_len(last_dim - 1)))) } test_that("indexing with [[ works on a vector", { x_array <- array(1:20, dim = c(5,4), dimnames = list(NULL, A = paste0("a", 1:4))) x = new_rvar(x_array) # [[ indexing should drop names (but not indices) x_array_ref = x_array dimnames(x_array_ref) <- NULL expect_equal(x[[3]], new_rvar(x_array_ref[,3, drop = FALSE])) expect_equal(x[["a2"]], new_rvar(x_array_ref[,2, drop = FALSE])) expect_error(x[[]]) expect_error(x[[NA]]) expect_error(x[[NA_integer_]]) expect_error(x[[6]]) expect_error(x[[1,1]]) expect_error(x[[1,1,1]]) expect_error(x[[NULL]]) expect_error(x[[-1]]) # different behavior from base vectors # base vectors convert these to numeric expect_error(x[[TRUE]]) expect_error(x[[FALSE]]) }) test_that("indexing with [[ works on a matrix", { x_array = array( 1:24, dim = c(2,4,3), dimnames = list(NULL, A = paste0("a", 1:4), B = paste0("b", 1:3)) ) x = new_rvar(x_array) x_array_ref = x_array dim(x_array_ref) <- c(2,12) expect_equal(x[[2]], new_rvar(x_array_ref[,2, drop = TRUE])) expect_equal(x[[12]], new_rvar(x_array_ref[,12, drop = TRUE])) expect_equal(x[[2,3]], new_rvar(x_array[,2,3, drop = TRUE])) # invalid indexing should result in errors expect_error(x[[1,]]) expect_error(x[[1,1,1]]) expect_error(x[[13]]) # different from base vectors # don't allow name-based [[ indexing on 2+D arrays expect_error(x[["a2"]]) # extending a NULL rvar should work... x_null = rvar() x_null[[1]] <- 5 expect_equal(x_null, rvar(5)) }) test_that("assignment with [[ works", { x_array = array( 1:24, dim = c(2,4,3), dimnames = list(NULL, A = paste0("a", 1:4), B = paste0("b", 1:3)) ) x = new_rvar(x_array) expect_equal( {x2 <- x; x2[[2]] <- 1; x2}, new_rvar({xr <- x_array; xr[,2,1] <- 1; xr}) ) expect_equal( {x2 <- x; x2[[12]] <- 1; x2}, new_rvar({xr <- x_array; xr[,4,3] <- 1; xr}) ) expect_equal( {x2 <- x; x2[[12]] <- new_rvar(c(1,2)); x2}, new_rvar({xr <- x_array; xr[,4,3] <- c(1,2); xr}) ) expect_equal( {x2 <- x; x2[["a2","b3"]] <- new_rvar(c(1,2)); x2}, new_rvar({xr <- x_array; xr[,2,3] <- c(1,2); xr}) ) # constant should have ndraws increased to value when assigned to x = new_rvar(array(1:2, dim = c(1,2))) expect_equal( {x[[1]] <- new_rvar(array(1:2, dim = c(2,1))); x}, new_rvar(array(c(1,2,2,2), dim = c(2,2))) ) expect_error({x2 <- x; x2[[-1]] <- 1}) expect_error({x2 <- rvar(1:10); x2[[2]] <- c(4,5,6)}) }) test_that("indexing with [ works on a vector", { x_array = array(1:20, dim = c(4,5), dimnames = list(A = paste0("a", 1:4), NULL)) x = rvar_from_array(x_array) expect_equal(x[], x) expect_equal(x[3], rvar_from_array(x_array[3,, drop = FALSE])) expect_equal(x["a2"], rvar_from_array(x_array["a2",, drop = FALSE])) expect_equal(x[c(1,3)], rvar_from_array(x_array[c(1,3),, drop = FALSE])) expect_equal(x[c("a2","a4")], rvar_from_array(x_array[c("a2","a4"),, drop = FALSE])) expect_equal(x[c(-1,-3)], rvar_from_array(x_array[c(-1,-3),, drop = FALSE])) expect_equal(x[TRUE], rvar_from_array(x_array[TRUE,, drop = FALSE])) expect_equal(x[c(TRUE,FALSE)], rvar_from_array(x_array[c(TRUE,FALSE),, drop = FALSE])) expect_equal(x[c(TRUE,FALSE,TRUE)], rvar_from_array(x_array[c(TRUE,FALSE,TRUE),, drop = FALSE])) expect_equal(x[c(TRUE,FALSE,FALSE,TRUE)], rvar_from_array(x_array[c(TRUE,FALSE,FALSE,TRUE),, drop = FALSE])) # dropping should preserve names (hence the drop = FALSE on x_array for this test) expect_equal(x["a1", drop = TRUE], rvar_from_array(x_array["a1",, drop = FALSE])) expect_equal(x[1:2, drop = TRUE], rvar_from_array(x_array[1:2,, drop = FALSE])) # indexing beyond the end of the array should result in NAs, to mimic normal vector indexing expect_equal(x[c(4,5)], rvar_from_array(x_array[c(4,NA_integer_),, drop = FALSE])) expect_equal(x[c(8,9)], rvar_from_array(x_array[c(NA_integer_,NA_integer_),, drop = FALSE])) expect_equal(x[NA], rvar_from_array(x_array[NA,, drop = FALSE])) expect_equal(x[NA_integer_], rvar_from_array(x_array[NA_integer_,, drop = FALSE])) expect_equal(x[rep(NA_integer_,7)], rvar_from_array(x_array[rep(NA_integer_,7),, drop = FALSE])) expect_equal(x[NULL], new_rvar()) expect_error(x[1,1]) # extending a NULL rvar should work... x_null = rvar() x_null[1] <- 5 expect_equal(x_null, rvar(5)) }) test_that("indexing with [ works on an array", { x_array = array( 1:24, dim = c(4,3,2), dimnames = list(A = paste0("a", 1:4), B = paste0("b", 1:3)) ) x = rvar_from_array(x_array) expect_equal(x[], x) expect_equal(x[2], rvar_from_array(array(x_array[2,1,], dim = c(1,2)))) expect_equal(x[2,], rvar_from_array(x_array[2,,, drop = FALSE])) expect_equal(x["a2",], rvar_from_array(x_array["a2",,, drop = FALSE])) expect_equal(x[c(1,2)], rvar_from_array(array(x_array[c(1,2),1,], dim = c(2,2)))) expect_equal(x[c(1,2),], rvar_from_array(x_array[c(1,2),,, drop = FALSE])) expect_equal(x[,c(1,3)], rvar_from_array(x_array[,c(1,3),, drop = FALSE])) expect_equal(x[,c("b2","b3")], rvar_from_array(x_array[,c("b2","b3"),, drop = FALSE])) expect_equal(x[,c(-1,-3)], rvar_from_array(x_array[,c(-1,-3),, drop = FALSE])) expect_equal(x[TRUE], rvar_from_array(array(x_array, dim = c(12,2)))) expect_equal(x[c(TRUE,FALSE)], rvar_from_array(array(x_array, dim = c(12,2))[c(TRUE,FALSE),])) expect_equal(x[c(TRUE,FALSE,TRUE)], rvar_from_array(array(x_array, dim = c(12,2))[c(TRUE,FALSE,TRUE),])) expect_equal(x[c(TRUE,FALSE,FALSE,TRUE)], rvar_from_array(array(x_array, dim = c(12,2))[c(TRUE,FALSE,FALSE,TRUE),])) expect_equal(x[TRUE,], rvar_from_array(x_array[TRUE,,, drop = FALSE])) expect_equal(x[c(TRUE,FALSE),], rvar_from_array(x_array[c(TRUE,FALSE),,, drop = FALSE])) expect_equal(x[c(TRUE,FALSE,TRUE),], rvar_from_array(x_array[c(TRUE,FALSE,TRUE),,, drop = FALSE])) expect_equal(x[c(TRUE,FALSE,FALSE,TRUE),], rvar_from_array(x_array[c(TRUE,FALSE,FALSE,TRUE),,, drop = FALSE])) # dropping works expect_equal(x["a1",, drop = TRUE], rvar_from_array(x_array["a1",,, drop = TRUE])) expect_equal(x[1:2,, drop = TRUE], rvar_from_array(x_array[1:2,,, drop = TRUE])) expect_equal(x[1,2, drop = TRUE], rvar_from_array(array(x_array[1,2,], dim = c(1,2)))) expect_equal(x[1,1:2, drop = TRUE], rvar_from_array(x_array[1,1:2,, drop = TRUE])) # indexing beyond the end of the array should result in NAs, to mimic normal vector indexing expect_equal(x[c(4,25)], rvar_from_array(array(x_array[c(4,NA_integer_),1,], dim = c(2,2)))) expect_equal(x[c(4,5),], rvar_from_array(x_array[c(4,NA_integer_),,, drop = FALSE])) expect_equal(x[c(8,9),], rvar_from_array(x_array[c(NA_integer_,NA_integer_),,, drop = FALSE])) expect_equal(x[NA], rvar_from_array(array(x_array[NA,,], dim = c(12,2)))) expect_equal(x[NA,], rvar_from_array(x_array[NA,,, drop = FALSE])) expect_equal(x[NA_integer_], rvar_from_array(array(c(NA_integer_,NA_integer_), dim = c(1,2)))) expect_equal(x[NA_integer_,], rvar_from_array(x_array[NA_integer_,,, drop = FALSE])) expect_equal(x[rep(NA_integer_,7)], rvar_from_array(array(rep(NA_integer_,14), dim = c(7,2)))) expect_equal(x[NULL], new_rvar()) # logical index the length of the array works flat_index <- c( TRUE,FALSE,FALSE, FALSE,TRUE,FALSE, TRUE,TRUE, FALSE, FALSE,TRUE,TRUE) x_array_flat <- x_array dim(x_array_flat) <- c(12,2) expect_equal(x[flat_index], rvar_from_array(x_array_flat[flat_index,])) expect_error(x[1,1,1]) # matrix indexing with an array x_array <- array(1:24, dim = c(2,2,3,2)) x <- rvar_from_array(x_array) expect_equal(x[rbind(c(1,2,3),c(2,2,3),c(2,1,1))], x[c(11,12,2)]) }) test_that("assignment with [ works", { x_array = array( 1:24, dim = c(2,4,3), dimnames = list(NULL, A = paste0("a", 1:4), B = paste0("b", 1:3)) ) x = new_rvar(x_array) expect_equal( {x2 <- x; x2[2,1] <- 1; x2}, new_rvar({xr <- x_array; xr[,2,1] <- 1; xr}) ) expect_equal( {x2 <- x; x2[2,] <- 1; x2}, new_rvar({xr <- x_array; xr[,2,] <- 1; xr}) ) expect_equal( {x2 <- x; x2[,2] <- new_rvar(c(1,2)); x2}, new_rvar({xr <- x_array; xr[,,2] <- c(1,2); xr}) ) expect_equal( {x2 <- x; x2["a2","b3"] <- new_rvar(c(1,2)); x2}, new_rvar({xr <- x_array; xr[,2,3] <- c(1,2); xr}) ) # constant should have ndraws increased to value when assigned to x2 = new_rvar(array(1:2, dim = c(1,2))) expect_equal( {x2[1] <- new_rvar(array(1:2, dim = c(2,1))); x2}, new_rvar(array(c(1,2,2,2), dim = c(2,2))) ) # logical index the length of the array works flat_index <- c( TRUE,FALSE,FALSE, FALSE,TRUE,FALSE, TRUE,TRUE, FALSE, FALSE,TRUE,TRUE) x_array_flat <- x_array dim(x_array_flat) <- c(2,12) x_array_flat[,flat_index] <- rep(1:6, each = 2) dim(x_array_flat) <- c(2,4,3) dimnames(x_array_flat) <- list(NULL, a = 1:4, b = 1:3) expect_equal( {x2 <- x; dimnames(x2) <- list(a = 1:4, b = 1:3); x2[flat_index] <- 1:6; x2}, new_rvar(x_array_flat) ) # matrix indexing assignment and unidimensional index assignment with an array works x_array <- array( 1:24, dim = c(2,2,3,2), dimnames = list(A = paste0("a", 1:2), B = paste0("b", 1:2), C = paste0("c", 1:3)) ) x_ref <- rvar_from_array(x_array) x_ref[1,2,3] <- rvar(1:2) x_ref[2,2,3] <- rvar(3:4) x_ref[2,1,1] <- rvar(5:6) x <- rvar_from_array(x_array) x[rbind(c(1,2,3),c(2,2,3),c(2,1,1))] <- rvar(matrix(1:6, nrow = 2)) expect_equal(x, x_ref) x <- rvar_from_array(x_array) x[c(11,12,2)] <- rvar(matrix(1:6, nrow = 2)) expect_equal(x, x_ref) }) posterior/tests/testthat.R0000755000175000017500000000007614165314652015574 0ustar nileshnileshlibrary(testthat) library(posterior) test_check("posterior") posterior/R/0000755000175000017500000000000014165314655012645 5ustar nileshnileshposterior/R/convergence.R0000644000175000017500000005332614165320304015263 0ustar nileshnilesh# Copyright (C) 2012, 2013, 2014, 2015, 2016, 2017, 2018 Trustees of Columbia University # Copyright (C) 2018, 2019 Aki Vehtari, Paul Bürkner # See LICENSE.md for more details #' List of available convergence diagnostics #' #' A list of available diagnostics and links to their individual help pages. #' #' @name diagnostics #' @aliases convergence #' #' @details #' #' |**Function**|**Description**| #' |:----------|:---------------| #' | [ess_basic()] | Basic version of effective sample size | #' | [ess_bulk()] | Bulk effective sample size | #' | [ess_tail()] | Tail effective sample size | #' | [ess_quantile()] | Effective sample sizes for quantiles | #' | [ess_sd()] | Effective sample sizes for standard deviations | #' | [mcse_mean()] | Monte Carlo standard error for the mean | #' | [mcse_quantile()] | Monte Carlo standard error for quantiles | #' | [mcse_sd()] | Monte Carlo standard error for standard deviations | #' | [rhat_basic()] | Basic version of Rhat | #' | [rhat()] | Improved, rank-based version of Rhat | #' | [rstar()] | R* diagnostic | #' #' @return #' See individual functions for a description of return types. #' NULL #' Basic version of the Rhat convergence diagnostic #' #' Compute the basic Rhat convergence diagnostic for a single variable as #' described in Gelman et al. (2013) with some changes according to Vehtari et #' al. (2021). For practical applications, we strongly recommend the improved #' Rhat convergence diagnostic implemented in [rhat()]. #' #' @family diagnostics #' @template args-conv #' @template args-conv-split #' @template args-methods-dots #' @template return-conv #' @template ref-gelman-bda-2013 #' @template ref-vehtari-rhat-2021 #' #' @examples #' mu <- extract_variable_matrix(example_draws(), "mu") #' rhat_basic(mu) #' #' d <- as_draws_rvars(example_draws("multi_normal")) #' rhat_basic(d$Sigma) #' #' @export rhat_basic <- function(x, ...) UseMethod("rhat_basic") #' @rdname rhat_basic #' @export rhat_basic.default <- function(x, split = TRUE, ...) { split <- as_one_logical(split) if (split) { x <- .split_chains(x) } .rhat(x) } #' @rdname rhat_basic #' @export rhat_basic.rvar <- function(x, split = TRUE, ...) { summarise_rvar_by_element_with_chains(x, rhat_basic, split, ...) } #' Basic version of the effective sample size #' #' Compute the basic effective sample size (ESS) estimate for a single variable #' as described in Gelman et al. (2013) with some changes according to Vehtari et #' al. (2021). For practical applications, we strongly #' recommend the improved ESS convergence diagnostics implemented in #' [ess_bulk()] and [ess_tail()]. See Vehtari (2021) for an in-depth #' comparison of different effective sample size estimators. #' #' @family diagnostics #' @template args-conv #' @template args-conv-split #' @template args-methods-dots #' @template return-conv #' @template ref-gelman-bda-2013 #' @template ref-vehtari-rhat-2021 #' @template ref-vehtari-ess-2021 #' #' @examples #' mu <- extract_variable_matrix(example_draws(), "mu") #' ess_basic(mu) #' #' d <- as_draws_rvars(example_draws("multi_normal")) #' ess_basic(d$Sigma) #' #' @export ess_basic <- function(x, ...) UseMethod("ess_basic") #' @rdname ess_basic #' @export ess_basic.default <- function(x, split = TRUE, ...) { split <- as_one_logical(split) if (split) { x <- .split_chains(x) } .ess(x) } #' @rdname ess_basic #' @export ess_basic.rvar <- function(x, split = TRUE, ...) { summarise_rvar_by_element_with_chains(x, ess_basic, split, ...) } #' Rhat convergence diagnostic #' #' Compute the Rhat convergence diagnostic for a single variable as the maximum #' of rank normalized split-Rhat and rank normalized folded-split-Rhat as #' proposed in Vehtari et al. (2021). #' #' @family diagnostics #' @template args-conv #' @template args-methods-dots #' @template return-conv #' @template ref-vehtari-rhat-2021 #' #' @examples #' mu <- extract_variable_matrix(example_draws(), "mu") #' rhat(mu) #' #' d <- as_draws_rvars(example_draws("multi_normal")) #' rhat(d$Sigma) #' #' @export rhat <- function(x, ...) UseMethod("rhat") #' @rdname rhat #' @export rhat.default <- function(x, ...) { rhat_bulk <- .rhat(z_scale(.split_chains(x))) rhat_tail <- .rhat(z_scale(.split_chains(fold_draws(x)))) max(rhat_bulk, rhat_tail) } #' @rdname rhat #' @export rhat.rvar <- function(x, ...) { summarise_rvar_by_element_with_chains(x, rhat, ...) } #' Bulk effective sample size (bulk-ESS) #' #' Compute a bulk effective sample size estimate (bulk-ESS) for a single #' variable. Bulk-ESS is useful as a diagnostic for the sampling efficiency in #' the bulk of the posterior. It is defined as the effective sample size for #' rank normalized values using split chains. For the tail effective sample size #' see [ess_tail()]. See Vehtari (2021) for an in-depth #' comparison of different effective sample size estimators. #' #' @family diagnostics #' @template args-conv #' @template args-methods-dots #' @template return-conv #' @template ref-vehtari-rhat-2021 #' @template ref-vehtari-ess-2021 #' #' @examples #' mu <- extract_variable_matrix(example_draws(), "mu") #' ess_bulk(mu) #' #' d <- as_draws_rvars(example_draws("multi_normal")) #' ess_bulk(d$Sigma) #' #' @export ess_bulk <- function(x, ...) UseMethod("ess_bulk") #' @rdname ess_bulk #' @export ess_bulk.default <- function(x, ...) { .ess(z_scale(.split_chains(x))) } #' @rdname ess_bulk #' @export ess_bulk.rvar <- function(x, ...) { summarise_rvar_by_element_with_chains(x, ess_bulk, ...) } #' Tail effective sample size (tail-ESS) #' #' Compute a tail effective sample size estimate (tail-ESS) for a single #' variable. Tail-ESS is useful as a diagnostic for the sampling efficiency in #' the tails of the posterior. It is defined as the minimum of the effective #' sample sizes for 5% and 95% quantiles. For the bulk effective sample #' size see [ess_bulk()]. See Vehtari (2021) for an in-depth #' comparison of different effective sample size estimators. #' #' @family diagnostics #' @template args-conv #' @template args-methods-dots #' @template return-conv #' @template ref-vehtari-rhat-2021 #' @template ref-vehtari-ess-2021 #' #' @examples #' mu <- extract_variable_matrix(example_draws(), "mu") #' ess_tail(mu) #' #' d <- as_draws_rvars(example_draws("multi_normal")) #' ess_tail(d$Sigma) #' #' @export ess_tail <- function(x, ...) UseMethod("ess_tail") #' @rdname ess_tail #' @export ess_tail.default <- function(x, ...) { q05_ess <- ess_quantile(x, 0.05) q95_ess <- ess_quantile(x, 0.95) min(q05_ess, q95_ess) } #' @rdname ess_tail #' @export ess_tail.rvar <- function(x, ...) { summarise_rvar_by_element_with_chains(x, ess_tail, ...) } #' Effective sample sizes for quantiles #' #' Compute effective sample size estimates for quantile estimates of a single #' variable. #' #' @family diagnostics #' @template args-conv #' @template args-conv-quantile #' @template args-methods-dots #' @template return-conv-quantile #' @template ref-vehtari-rhat-2021 #' #' @examples #' mu <- extract_variable_matrix(example_draws(), "mu") #' ess_quantile(mu, probs = c(0.1, 0.9)) #' #' d <- as_draws_rvars(example_draws("multi_normal")) #' ess_quantile(d$mu, probs = c(0.1, 0.9)) #' #' @export ess_quantile <- function(x, probs = c(0.05, 0.95), ...) { UseMethod("ess_quantile") } #' @rdname ess_quantile #' @export ess_quantile.default <- function(x, probs = c(0.05, 0.95), names = TRUE, ...) { probs <- as.numeric(probs) if (any(probs < 0 | probs > 1)) { stop_no_call("'probs' must contain values between 0 and 1.") } names <- as_one_logical(names) out <- ulapply(probs, .ess_quantile, x = x) if (names) { names(out) <- paste0("ess_q", probs * 100) } out } #' @rdname ess_quantile #' @export ess_quantile.rvar <- function(x, probs = c(0.05, 0.95), names = TRUE, ...) { summarise_rvar_by_element_with_chains(x, ess_quantile, probs, names, ...) } #' @rdname ess_quantile #' @export ess_median <- function(x, ...) { ess_quantile(x, probs = 0.5, names = FALSE, ...) } # ESS of a single quantile .ess_quantile <- function(x, prob) { if (should_return_NA(x)) { return(NA_real_) } x <- as.matrix(x) I <- x <= quantile(x, prob) .ess(.split_chains(I)) } #' Effective sample size for the mean #' #' Compute an effective sample size estimate for a mean (expectation) #' estimate of a single variable. #' #' @template args-conv #' @template args-methods-dots #' @template return-conv #' @template ref-gelman-bda-2013 #' #' @examples #' mu <- extract_variable_matrix(example_draws(), "mu") #' ess_mean(mu) #' #' d <- as_draws_rvars(example_draws("multi_normal")) #' ess_mean(d$Sigma) #' #' @export ess_mean <- function(x, ...) UseMethod("ess_mean") #' @rdname ess_quantile #' @export ess_mean.default <- function(x, ...) { .ess(.split_chains(x)) } #' @rdname ess_mean #' @export ess_mean.rvar <- function(x, ...) { summarise_rvar_by_element_with_chains(x, ess_mean, ...) } #' Effective sample size for the standard deviation #' #' Compute an effective sample size estimate for the standard deviation (SD) #' estimate of a single variable. This is defined as minimum of the effective #' sample size estimate for the mean and the the effective sample size estimate #' for the mean of the squared value. #' #' @family diagnostics #' @template args-conv #' @template args-methods-dots #' @template return-conv #' @template ref-vehtari-rhat-2021 #' #' @examples #' mu <- extract_variable_matrix(example_draws(), "mu") #' ess_sd(mu) #' #' d <- as_draws_rvars(example_draws("multi_normal")) #' ess_sd(d$Sigma) #' #' @export ess_sd <- function(x, ...) UseMethod("ess_sd") #' @rdname ess_sd #' @export ess_sd.default <- function(x, ...) { min(.ess(.split_chains(x)), .ess(.split_chains(x^2))) } #' @rdname ess_sd #' @export ess_sd.rvar <- function(x, ...) { summarise_rvar_by_element_with_chains(x, ess_sd, ...) } #' Monte Carlo standard error for quantiles #' #' Compute Monte Carlo standard errors for quantile estimates of a #' single variable. #' #' @family diagnostics #' @template args-conv #' @template args-conv-quantile #' @template args-methods-dots #' @template return-conv-quantile #' @template ref-vehtari-rhat-2021 #' #' @examples #' mu <- extract_variable_matrix(example_draws(), "mu") #' mcse_quantile(mu, probs = c(0.1, 0.9)) #' #' d <- as_draws_rvars(example_draws("multi_normal")) #' mcse_quantile(d$mu) #' #' @export mcse_quantile <- function(x, probs = c(0.05, 0.95), ...) { UseMethod("mcse_quantile") } #' @rdname mcse_quantile #' @export mcse_quantile.default <- function(x, probs = c(0.05, 0.95), names = TRUE, ...) { probs <- as.numeric(probs) if (any(probs < 0 | probs > 1)) { stop_no_call("'probs' must contain values between 0 and 1.") } names <- as_one_logical(names) out <- ulapply(probs, .mcse_quantile, x = x) if (names) { names(out) <- paste0("mcse_q", probs * 100) } out } #' @rdname mcse_quantile #' @export mcse_quantile.rvar <- function(x, probs = c(0.05, 0.95), names = TRUE, ...) { summarise_rvar_by_element_with_chains(x, mcse_quantile, probs, names, ...) } #' @rdname mcse_quantile #' @export mcse_median <- function(x, ...) { mcse_quantile(x, probs = 0.5, names = FALSE, ...) } # MCSE of a single quantile .mcse_quantile <- function(x, prob) { ess <- ess_quantile(x, prob) p <- c(0.1586553, 0.8413447) a <- qbeta(p, ess * prob + 1, ess * (1 - prob) + 1) ssims <- sort(x) S <- length(ssims) th1 <- ssims[max(floor(a[1] * S), 1)] th2 <- ssims[min(ceiling(a[2] * S), S)] as.vector((th2 - th1) / 2) } #' Monte Carlo standard error for the mean #' #' Compute the Monte Carlo standard error for the mean (expectation) of a #' single variable. #' #' @family diagnostics #' @template args-conv #' @template args-methods-dots #' @template return-conv #' @template ref-gelman-bda-2013 #' #' @examples #' mu <- extract_variable_matrix(example_draws(), "mu") #' mcse_mean(mu) #' #' d <- as_draws_rvars(example_draws("multi_normal")) #' mcse_mean(d$Sigma) #' #' @export mcse_mean <- function(x, ...) UseMethod("mcse_mean") #' @rdname mcse_mean #' @export mcse_mean.default <- function(x, ...) { sd(x) / sqrt(ess_mean(x)) } #' @rdname mcse_mean #' @export mcse_mean.rvar <- function(x, ...) { summarise_rvar_by_element_with_chains(x, mcse_mean, ...) } #' Monte Carlo standard error for the standard deviation #' #' Compute the Monte Carlo standard error for the standard deviation (SD) of a #' single variable using Stirling's approximation and assuming approximate #' normality. #' #' @family diagnostics #' @template args-conv #' @template args-methods-dots #' @template return-conv #' @template ref-vehtari-rhat-2021 #' #' @examples #' mu <- extract_variable_matrix(example_draws(), "mu") #' mcse_sd(mu) #' #' d <- as_draws_rvars(example_draws("multi_normal")) #' mcse_sd(d$Sigma) #' #' @export mcse_sd <- function(x, ...) UseMethod("mcse_sd") #' @rdname mcse_sd #' @export mcse_sd.default <- function(x, ...) { # assumes normality of x and uses Stirling's approximation ess_sd <- ess_sd(x) sd(x) * sqrt(exp(1) * (1 - 1 / ess_sd)^(ess_sd - 1) - 1) } #' @rdname mcse_sd #' @export mcse_sd.rvar <- function(x, ...) { summarise_rvar_by_element_with_chains(x, mcse_sd, ...) } #' Compute Quantiles #' #' Compute quantiles of a sample and return them in a format consistent #' with other summary functions in the \pkg{posterior} package. #' #' @template args-conv #' @template args-conv-quantile #' @param na.rm (logical) Should `NA` and `NaN` values be removed from `x` prior #' to computing quantiles? The default is `FALSE`. #' @param ... Arguments passed to individual methods (if applicable) and then #' on to [stats::quantile()]. #' #' @return #' A numeric vector of length `length(probs)`. If `names = TRUE`, it has a #' [names] attribute with names like `"q5"`, `"q95"`, etc, based on the values #' of `probs`. #' #' @examples #' mu <- extract_variable_matrix(example_draws(), "mu") #' quantile2(mu) #' #' @export quantile2 <- function(x, probs = c(0.05, 0.95), na.rm = FALSE, ...) { UseMethod("quantile2") } #' @rdname quantile2 #' @export quantile2.default <- function( x, probs = c(0.05, 0.95), na.rm = FALSE, names = TRUE, ... ) { names <- as_one_logical(names) na.rm <- as_one_logical(na.rm) if (!na.rm && anyNA(x)) { # quantile itself doesn't handle this case (#110) out <- rep(NA_real_, length(probs)) } else { out <- quantile(x, probs = probs, na.rm = na.rm, ...) } if (names) { names(out) <- paste0("q", probs * 100) } else { names(out) <- NULL } out } #' @rdname quantile2 #' @export quantile2.rvar <- function( x, probs = c(0.05, 0.95), na.rm = FALSE, names = TRUE, ... ) { summarise_rvar_by_element_with_chains(x, quantile2, probs, na.rm, names, ...) } # internal ---------------------------------------------------------------- #' Autocovariance estimates #' #' Compute autocovariance estimates for every lag for the specified #' input sequence using a fast Fourier transform approach. The estimate #' for lag t is scaled by N-t where N is the length of the sequence. #' #' @template args-conv-seq #' @return A numeric vector of autocovariances at every lag (scaled by N-lag). #' @keywords internal #' @export autocovariance <- function(x) { N <- length(x) varx <- var(x) if (varx==0) { # if variance is 0, then all autocovariances are 0 return(rep(0, N)) } # zero padding makes fft() much faster when N > 1000 M <- nextn(N) Mt2 <- 2 * M yc <- x - mean(x) yc <- c(yc, rep.int(0, Mt2 - N)) # FFT based unnormalized autocovariances ac <- Re(fft(abs(fft(yc))^2, inverse = TRUE)[1:N]) # use "biased" estimate as recommended by Geyer (1992) # direct scaling with var(x) avoids need to compute "mask effect" ac <- ac / ac[1] * varx * (N - 1) / N ac } #' Autocorrelation estimates #' #' Compute autocorrelation estimates for every lag for the specified #' input sequence using a fast Fourier transform approach. The estimate #' for lag t is scaled by N-t where N is the length of the sequence. #' #' @template args-conv-seq #' @return A numeric vector of autocorrelations at every lag (scaled by N-lag). #' @keywords internal #' @export autocorrelation <- function(x) { ac <- autocovariance(x) ac <- ac / ac[1] } #' Rank normalization #' #' Compute rank normalization for a numeric array. First replace each #' value by its rank. Average rank for ties are used to conserve the #' number of unique values of discrete quantities. Second, normalize #' ranks via the inverse normal transformation. #' #' @template args-scale #' @template args-frac-offset #' @return A numeric array of rank normalized values with the same size #' and dimension as the input. #' @keywords internal #' @export z_scale <- function(x, c = 3/8) { r <- rank(as.array(x), ties.method = 'average') z <- qnorm(backtransform_ranks(r, c = c)) z[is.na(x)] <- NA if (!is.null(dim(x))) { # output should have the input dimension z <- array(z, dim = dim(x), dimnames = dimnames(x)) } z } #' Rank uniformization #' #' Compute rank uniformization for a numeric array. First replace each value by #' its rank. Average rank for ties are used to conserve the number of unique #' values of discrete quantities. Second, uniformize ranks to the scale #' `[1/(2S), 1-1/(2S)]`, where `S` is the number of values. #' #' @template args-scale #' @template args-frac-offset #' @return A numeric array of uniformized values with the same size #' and dimension as the input. #' @keywords internal #' @export u_scale <- function(x, c = 3/8) { r <- rank(as.array(x), ties.method = 'average') u <- backtransform_ranks(r, c = c) u[is.na(x)] <- NA if (!is.null(dim(x))) { # output should have the input dimension u <- array(u, dim = dim(x), dimnames = dimnames(x)) } u } #' Rank values #' #' Compute ranks for a numeric array, that is, replace each #' value by its rank. Average rank for ties are used to conserve the #' number of unique values of discrete quantities. #' #' @template args-scale #' @return A numeric array of ranked values with the same size #' and dimension as the input. #' @keywords internal #' @export r_scale <- function(x) { r <- rank(as.array(x), ties.method = 'average') r[is.na(x)] <- NA if (!is.null(dim(x))) { # output should have the input dimension r <- array(r, dim = dim(x), dimnames = dimnames(x)) } r } #' Back-transformation of ranks #' #' @param r array of ranks #' @param c fractional offset; defaults to c = 3/8 as recommend by Blom (1958) #' @noRd backtransform_ranks <- function(r, c = 3/8) { c <- as_one_numeric(c) S <- length(r) (r - c) / (S - 2 * c + 1) } #' Fold draws around their median #' @template args-conv #' @return An array or vector of folded draws. #' @noRd fold_draws <- function(x) { abs(x - median(x)) } #' Compute the Rhat convergence diagnostic #' @template args-conv #' @template return-conv #' @noRd .rhat <- function(x) { x <- as.matrix(x) if (should_return_NA(x)) { return(NA_real_) } nchains <- NCOL(x) niterations <- NROW(x) chain_mean <- matrixStats::colMeans2(x) chain_var <- matrixStats::colVars(x, center=chain_mean) var_between <- niterations * var(chain_mean) var_within <- mean(chain_var) sqrt((var_between / var_within + niterations - 1) / niterations) } #' Compute the effective sample size #' @template args-conv #' @template return-conv #' @noRd .ess <- function(x) { x <- as.matrix(x) nchains <- NCOL(x) niterations <- NROW(x) if (niterations < 3L || should_return_NA(x)) { return(NA_real_) } acov <- apply(x, 2, autocovariance) acov_means <- matrixStats::rowMeans2(acov) mean_var <- acov_means[1] * niterations / (niterations - 1) var_plus <- mean_var * (niterations - 1) / niterations if (nchains > 1) { var_plus <- var_plus + var(matrixStats::colMeans2(x)) } # Geyer's initial positive sequence rho_hat_t <- rep.int(0, niterations) t <- 0 rho_hat_even <- 1 rho_hat_t[t + 1] <- rho_hat_even rho_hat_odd <- 1 - (mean_var - acov_means[t + 2]) / var_plus rho_hat_t[t + 2] <- rho_hat_odd while (t < NROW(acov) - 5 && !is.nan(rho_hat_even + rho_hat_odd) && (rho_hat_even + rho_hat_odd > 0)) { t <- t + 2 rho_hat_even = 1 - (mean_var - acov_means[t + 1]) / var_plus rho_hat_odd = 1 - (mean_var - acov_means[t + 2]) / var_plus if ((rho_hat_even + rho_hat_odd) >= 0) { rho_hat_t[t + 1] <- rho_hat_even rho_hat_t[t + 2] <- rho_hat_odd } } max_t <- t # this is used in the improved estimate if (rho_hat_even>0) rho_hat_t[max_t + 1] <- rho_hat_even # Geyer's initial monotone sequence t <- 0 while (t <= max_t - 4) { t <- t + 2 if (rho_hat_t[t + 1] + rho_hat_t[t + 2] > rho_hat_t[t - 1] + rho_hat_t[t]) { rho_hat_t[t + 1] = (rho_hat_t[t - 1] + rho_hat_t[t]) / 2; rho_hat_t[t + 2] = rho_hat_t[t + 1]; } } ess <- nchains * niterations # Geyer's truncated estimate # tau_hat <- -1 + 2 * sum(rho_hat_t[1:max_t]) # Improved estimate reduces variance in antithetic case tau_hat <- -1 + 2 * sum(rho_hat_t[1:max_t]) + rho_hat_t[max_t+1] # Safety check for negative values and with max ess equal to ess*log10(ess) tau_bound <- 1 / log10(ess) if (tau_hat < tau_bound) { warning_no_call("The ESS has been capped to avoid negative values.") tau_hat <- tau_bound } ess <- ess / tau_hat ess } # should NA be returned by a convergence diagnostic? should_return_NA <- function(x, tol = .Machine$double.eps) { if (anyNA(x) || checkmate::anyInfinite(x)) { return(TRUE) } # checking for constant input per chain is too conservative for ess_tail # so we don't check this for the time being until we find a better solution # if (is.matrix(x)) { # # is_constant() vectorized over x columns # if (is.logical(x)) { # return(any(matrixStats::colAnys(x) == matrixStats::colAlls(x))) # } else if (is.integer(x)) { # return(any(matrixStats::rowDiffs(matrixStats::colRanges(x)) == 0L)) # } else { # return(any(abs(matrixStats::rowDiffs(matrixStats::colRanges(x))) < tol)) # } # } is_constant(x, tol = tol) } posterior/R/posterior-package.R0000644000175000017500000000452614165314652016413 0ustar nileshnilesh#' Tools for working with posterior (and prior) distributions #' #' @docType package #' @name posterior-package #' @aliases posterior #' #' @import checkmate #' @import stats #' #' @description #' \if{html}{ #' \figure{stanlogo.png}{options: width="50"} #' \url{https://mc-stan.org/posterior/} #' } #' #' The \pkg{posterior} package is intended to provide useful tools #' for both users and developers of packages for fitting Bayesian models or #' working with output from Bayesian models. The primary goals of the package #' are to: #' * Efficiently convert between many different useful formats of #' draws (samples) from posterior or prior distributions. #' * Provide consistent methods for operations commonly performed on draws, #' for example, subsetting, binding, or mutating draws. #' * Provide various summaries of draws in convenient formats. #' * Provide lightweight implementations of state of the art posterior inference #' diagnostics. #' #' @section Package options: #' #' The following options are used to format and print [`draws`] objects, #' as in `print.draws_array()`, `print.draws_df()`, `print.draws_list()`, #' `print.draws_matrix()`, and `print.draws_rvars()`: #' #' * `posterior.max_draws`: Maximum number of draws to print. #' * `posterior.max_iterations`: Maximum number of iterations to print. #' * `posterior.max_chains`: Maximum number of chains to print. #' * `posterior.max_variables`: Maximum number of variables to print. #' #' The following option is used to format and print [`rvar`] objects, #' as in `print.rvar()` and `print.draws_rvars()`: #' #' * `posterior.rvar_summary`: What style of summary to display: #' `"mean_sd"` displays `mean±sd`, `"median_mad"` displays `median±mad`. #' #' The following option is used to construct new [`rvar`] objects, #' as in `rfun()` and `rdo()`: #' #' * `posterior.rvar_ndraws`: The number of draws used to construct #' new random variables when this number cannot be determined #' from existing arguments (e.g., other [`rvar`]s passed to a function). #' #' The following options are used to control warning messages: #' #' * `posterior.warn_on_merge_chains`: (logical) Some operations will #' trigger an automatic merging of chains, for example, because chains do not #' match between two objects involved in a binary operation. Whether this #' causes a warning can be controlled by this option. #' NULL posterior/R/rvar-summaries-over-draws.R0000755000175000017500000001646314165314652020046 0ustar nileshnilesh# Summaries within array elements, over draws -------------------------- #' Summaries of random variables within array elements, over draws #' #' Compute summaries within elements of an [`rvar`] and over draws of each element, #' producing an array of the same shape as the input random variable (except in #' the case of `range()`, see **Details**). #' #' @param x (rvar) An [`rvar`]. #' @param ... Further arguments passed to underlying functions (e.g., #' `base::mean()` or `base::median()`), such as `na.rm`. #' #' @details #' #' Summaries include expectations (`E()` or `mean()`), probabilities (`Pr()`), #' medians (`median()`), spread (`var()`, `variance()`, `sd()`, `mad()`), sums and #' products (`sum()`, `prod()`), extrema and ranges (`min()`, `max()`, `range()`), #' logical summaries (`all()`, `any()`), and special value predicates (`is.finite()`, #' `is.infinite()`, `is.nan()`, `is.na()`). #' #' Unless otherwise stated, these functions return a numeric array with the same shape #' (same dimensions) as the input [`rvar`], `x`. #' #' `range(x)` returns an array with dimensions `c(2, dim(x))`, where the last #' dimension contains the minimum and maximum values. #' #' `is.infinite(x)`, `is.nan(x)`, and `is.na(x)` return logical arrays, where each #' element is `TRUE` if **any** draws in its corresponding element in `x` match #' the predicate. Each elements in the result of `is.finite(x)` is `TRUE` if #' **all** draws in the corresponding element in `x` are finite. #' #' Both `E()`, `mean()`, and `Pr()` return the means of each element in the input. #' `Pr()` additionally checks that the provided [`rvar`] #' is a logical variable (hence, taking its expectation results in a probability). #' #' For consistency, `E()` and `Pr()` are also defined for base arrays so that #' they can be used as summary functions in `summarise_draws()`. #' #' @return #' A numeric or logical vector with the same dimensions as the given random variable, where #' each entry in the vector is the mean, median, or variance of the corresponding entry in `x`. #' #' @examples #' #' set.seed(5678) #' x = rvar_rng(rnorm, 4, mean = 1:4, sd = 2) #' #' # These should all be ~= c(1, 2, 3, 4) #' E(x) #' mean(x) #' median(x) #' #' # This ... #' Pr(x < 1.5) #' # ... should be about the same as this: #' pnorm(1.5, mean = 1:4, sd = 2) #' #' @name rvar-summaries-over-draws #' @seealso [rvar-summaries-within-draws] for summary functions within draws. #' [rvar-dist] for density, CDF, and quantile functions of random variables. #' @family rvar-summaries #' @export E <- function(x, ...) { mean(x, ...) } #' @rdname rvar-summaries-over-draws #' @export mean.rvar <- function(x, ...) { summarise_rvar_by_element_via_matrix(x, matrixStats::colMeans2, useNames = FALSE, ...) } #' @rdname rvar-summaries-over-draws #' @export Pr <- function(x, ...) UseMethod("Pr") #' @rdname rvar-summaries-over-draws #' @export Pr.default <- function(x, ...) { stop_no_call("Can only use `Pr()` on logical variables.") } #' @rdname rvar-summaries-over-draws #' @export Pr.logical <- function(x, ...) { mean(x, ...) } #' @rdname rvar-summaries-over-draws #' @export Pr.rvar <- function(x, ...) { if (!is.logical(draws_of(x))) { stop_no_call("Can only use `Pr()` on logical random variables.") } mean(x, ...) } # numeric summaries ------------------------------------------------------- #' @rdname rvar-summaries-over-draws #' @export median.rvar <- function(x, ...) { summarise_rvar_by_element_via_matrix(x, matrixStats::colMedians, useNames = FALSE, ...) } #' @rdname rvar-summaries-over-draws #' @export min.rvar <- function(x, ...) { summarise_rvar_by_element_via_matrix(x, matrixStats::colMins, useNames = FALSE, ...) } #' @rdname rvar-summaries-over-draws #' @export max.rvar <- function(x, ...) { summarise_rvar_by_element_via_matrix(x, matrixStats::colMaxs, useNames = FALSE, ...) } #' @rdname rvar-summaries-over-draws #' @export sum.rvar <- function(x, ...) { summarise_rvar_by_element_via_matrix(x, matrixStats::colSums2, useNames = FALSE, ...) } #' @rdname rvar-summaries-over-draws #' @export prod.rvar <- function(x, ...) { summarise_rvar_by_element_via_matrix(x, matrixStats::colProds, useNames = FALSE, ...) } #' @rdname rvar-summaries-over-draws #' @export all.rvar <- function(x, ...) { summarise_rvar_by_element_via_matrix(x, matrixStats::colAlls, useNames = FALSE, ...) } #' @rdname rvar-summaries-over-draws #' @export any.rvar <- function(x, ...) { summarise_rvar_by_element_via_matrix(x, matrixStats::colAnys, useNames = FALSE, ...) } #' @rdname rvar-summaries-over-draws #' @export Summary.rvar <- function(...) { # min, max, sum, prod, all, any, range --- these are all defined by more # specific functions to be faster, but I left the generic implementation here # on the off chance anything gets added to this group generic in the future f <- get(.Generic) summarise_rvar_by_element(.f = f, ...) } # spread ------------------------------------------------------------------ #' @importFrom distributional variance #' @export distributional::variance #' @rdname rvar-summaries-over-draws #' @export variance.rvar <- function(x, ...) { summarise_rvar_by_element_via_matrix(x, matrixStats::colVars, useNames = FALSE, ...) } #' @rdname rvar-summaries-over-draws #' @export var <- function(x, ...) UseMethod("var") #' @rdname rvar-summaries-over-draws #' @export var.default <- function(x, ...) stats::var(x, ...) #' @rdname rvar-summaries-over-draws #' @export var.rvar <- variance.rvar #' @rdname rvar-summaries-over-draws #' @export sd <- function(x, ...) UseMethod("sd") #' @rdname rvar-summaries-over-draws #' @export sd.default <- function(x, ...) stats::sd(x, ...) #' @rdname rvar-summaries-over-draws #' @export sd.rvar <- function(x, ...) { summarise_rvar_by_element_via_matrix(x, matrixStats::colSds, useNames = FALSE, ...) } #' @rdname rvar-summaries-over-draws #' @export mad <- function(x, ...) UseMethod("mad") #' @rdname rvar-summaries-over-draws #' @export mad.default <- function(x, ...) stats::mad(x, ...) #' @rdname rvar-summaries-over-draws #' @export mad.rvar <- function(x, ...) { summarise_rvar_by_element_via_matrix(x, matrixStats::colMads, useNames = FALSE, ...) } # range ------------------------------------------------------------------- #' @rdname rvar-summaries-over-draws #' @export range.rvar <- function(x, ...) { summarise_rvar_by_element_via_matrix(x, function(...) t(matrixStats::colRanges(...)), useNames = FALSE, .extra_dim = 2, .extra_dimnames = list(NULL), ... ) } # special value predicates --------------------------------------------------------------- #' @rdname rvar-summaries-over-draws #' @export is.finite.rvar <- function(x) { summarise_rvar_by_element_via_matrix(x, function(x) matrixStats::colAlls(is.finite(x), useNames = FALSE)) } #' @rdname rvar-summaries-over-draws #' @export is.infinite.rvar <- function(x) { summarise_rvar_by_element_via_matrix(x, function(x) matrixStats::colAnys(is.infinite(x), useNames = FALSE)) } #' @rdname rvar-summaries-over-draws #' @export is.nan.rvar <- function(x) { summarise_rvar_by_element_via_matrix(x, function(x) matrixStats::colAnys(is.nan(x), useNames = FALSE)) } #' @rdname rvar-summaries-over-draws #' @export is.na.rvar <- function(x) { summarise_rvar_by_element_via_matrix(x, matrixStats::colAnyNAs, useNames = FALSE) } #' @export anyNA.rvar <- function(x, ...) anyNA(draws_of(x), ...) posterior/R/rvar-rfun.R0000755000175000017500000002641314165314652014720 0ustar nileshnilesh#' Create functions of random variables #' #' Function that create functions that can accept and/or produce [`rvar`]s. #' #' @param .f (multiple options) A function to turn into a function that accepts #' and/or produces random variables: #' * A function #' * A one-sided formula that can be parsed by [rlang::as_function()] #' @param rvar_args (character vector) The names of the arguments of `.f` that #' should be allowed to accept [`rvar`]s as arguments. If `NULL` (the #' default), all arguments to `.f` are turned into arguments that accept #' [`rvar`]s. #' @param ndraws (positive integer). The number of draws used to construct new #' random variables if no [`rvar`]s are supplied as arguments to the #' returned function. If `NULL`, `getOption("posterior.rvar_ndraws")` is used #' (default `4000`). If any arguments to the returned function contain #' [`rvar`]s, the number of draws in the provided [`rvar`]s is used instead of #' the value of this argument. #' #' @details This function wraps an existing function (`.f`) such that it returns [`rvar`]s containing #' whatever type of data `.f` would normally return. #' #' The returned function, when called, executes `.f` possibly multiple times, once for each draw of #' the [`rvar`]s passed to it, then returns a new #' [`rvar`] representing the output of those function evaluations. If the arguments contain no [`rvar`]s, #' then `.f` will be executed `ndraws` times and an [`rvar`] with that many draws returned. #' #' Functions created by `rfun()` are not necessarily *fast* (in fact in some cases they may be very slow), but #' they have the advantage of allowing a nearly arbitrary R functions to be executed against [`rvar`]s #' simply by wrapping them with `rfun()`. This makes it especially useful as a prototyping #' tool. If you create code with `rfun()` and it is unacceptably slow for your application, #' consider rewriting it using math operations directly on [`rvar`]s (which should be fast), #' using [rvar_rng()], and/or using operations directly on the arrays that back the [`rvar`]s #' (via [draws_of()]). #' #' #' @return A function with the same argument specification as `.f`, but which can accept and return #' [`rvar`]s. #' #' @examples #' #' rvar_norm <- rfun(rnorm) #' rvar_gamma <- rfun(rgamma) #' #' mu <- rvar_norm(10, mean = 1:10, sd = 1) #' sigma <- rvar_gamma(1, shape = 1, rate = 1) #' x <- rvar_norm(10, mu, sigma) #' x #' #' @family rfun #' @export rfun <- function (.f, rvar_args = NULL, ndraws = NULL) { # based loosely on base::Vectorize ndraws <- ndraws %||% getOption("posterior.rvar_ndraws", 4000) .f <- rlang::as_function(.f) arg_names <- as.list(formals(.f)) arg_names[["..."]] <- NULL arg_names <- names(arg_names) rvar_args <- as.character(rvar_args %||% arg_names) if (!all(rvar_args %in% arg_names)) { stop_no_call("must specify names of formal arguments for 'rfun'") } collisions <- arg_names %in% c("FUN", "SIMPLIFY", "USE.NAMES") if (any(collisions)) { stop_no_call("'.f' may not have argument(s) named ", comma(arg_names[collisions])) } FUNV <- function() { args <- lapply(as.list(match.call())[-1L], eval, parent.frame()) arg_names <- if (is.null(names(args))) character(length(args)) else names(args) # convert arguments that are rvars into draws the function can be applied over is_rvar_arg <- (arg_names %in% rvar_args) & as.logical(lapply(args, is_rvar)) rvar_args <- conform_rvar_ndraws_nchains(args[is_rvar_arg]) .nchains <- if (length(rvar_args) < 1) { 1 } else { nchains(rvar_args[[1]]) } rvar_args <- lapply(rvar_args, list_of_draws) if (length(rvar_args) == 0) { # no rvar arguments, so just create a random variable by applying this function # ndraws times list_of_draws <- replicate(ndraws, do.call(.f, args), simplify = FALSE) } else { list_of_draws <- do.call(mapply, c(FUN = .f, rvar_args, MoreArgs = list(args[!is_rvar_arg]), SIMPLIFY = FALSE, USE.NAMES = FALSE )) } # Need to add a first dimension before unchopping (this will be the draws dimension) # Doing this + vec_unchop is faster than doing abind::abind(list_of_draws, along = 0) list_of_draws <- lapply(list_of_draws, function(x) { x <- as.array(x) dim(x) <- c(1, dim(x)) x }) new_rvar(vctrs::vec_unchop(list_of_draws), .nchains = .nchains) } formals(FUNV) <- formals(.f) FUNV } #' Execute expressions of random variables #' #' Execute (nearly) arbitrary \R expressions that may include [`rvar`]s, #' producing a new [`rvar`]. #' #' @param expr (expression) A bare expression that can (optionally) contain #' [`rvar`]s. The expression supports [quasiquotation]. #' @param ndraws (positive integer) The number of draws used to construct new #' random variables if no [`rvar`]s are supplied in `expr`. If `NULL`, #' `getOption("posterior.rvar_ndraws")` is used (default 4000). If `expr` #' contains [`rvar`]s, the number of draws in the provided [`rvar`]s is used #' instead of the value of this argument. #' @template args-rvar-dim #' #' @details This function evaluates `expr` possibly multiple times, once for each draw of #' the [`rvar`]s it contains, then returns a new [`rvar`] representing the output of those #' expressions. To identify [`rvar`]s, `rdo()` searches the calling environment for any variables #' named in `expr` for which [is_rvar()] evaluates to `TRUE`. If `expr` contains no [`rvar`]s, #' then it will be executed `ndraws` times and an [`rvar`] with that many draws returned. #' #' `rdo()` is not necessarily *fast* (in fact in some cases it may be very slow), but #' it has the advantage of allowing a nearly arbitrary R expression to be executed against [`rvar`]s #' simply by wrapping it with `rdo( ... )`. This makes it especially useful as a prototyping #' tool. If you create code with `rdo()` and it is unacceptably slow for your application, #' consider rewriting it using math operations directly on [`rvar`]s (which should be fast), #' using [rvar_rng()], and/or using operations directly on the arrays that back the [`rvar`]s #' (via [draws_of()]). #' #' @return An [`rvar`]. #' #' @examples #' #' mu <- rdo(rnorm(10, mean = 1:10, sd = 1)) #' sigma <- rdo(rgamma(1, shape = 1, rate = 1)) #' x <- rdo(rnorm(10, mu, sigma)) #' x #' #' @family rfun #' @importFrom rlang eval_tidy quo_get_env enquo missing_arg quo_get_expr #' @export rdo <- function(expr, dim = NULL, ndraws = NULL) { ndraws <- ndraws %||% getOption("posterior.rvar_ndraws", 4000) # basic idea here is to find all the variables that are used in the expression # and which are also random variables in the expression's environment, then # build a function that executes the expression and takes those random # variables as arguments, then vectorize that function using `rfun()` and execute it. f_expr <- enquo(expr) f_env <- quo_get_env(f_expr) rvars_in_expr <- list() f_alist <- alist() for (name in all.vars(f_expr)) { var <- get(name, f_env) if (is_rvar(var)) { rvars_in_expr[[name]] <- var f_alist[[name]] <- missing_arg() } } f_alist <- append(f_alist, quo_get_expr(f_expr)) f <- rfun(as.function(f_alist, envir = f_env), ndraws = ndraws) result <- do.call(f, rvars_in_expr, envir = f_env) if (!is.null(dim)) { dim(result) <- dim } result } #' Create random variables from existing random number generators #' #' Specialized alternative to `rdo()` or `rfun()` for creating [`rvar`]s from #' existing random-number generator functions (such as `rnorm()`, `rbinom()`, etc). #' #' @param .f (function) A function (or string naming a function) representing a #' random-number generating function that follows the pattern of base random #' number generators (like `rnorm()`, `rbinom()`, etc). It must: #' - Have a first argument, `n`, giving the number of draws to take from the #' distribution #' - Have vectorized parameter arguments #' - Return a single vector of length `n` #' @param n (positive integer) The length of the output [`rvar`] vector (**not** #' the number of draws). #' @param ... Arguments passed to `.f`. These arguments may include [`rvar`]s, #' so long as they are vectors only (no multidimensional [`rvar`]s are #' allowed). #' @param ndraws (positive integer) The number of draws used to construct the #' returned random variable if no [`rvar`]s are supplied in `...`. If `NULL`, #' `getOption("posterior.rvar_ndraws")` is used (default 4000). If `...` #' contains [`rvar`]s, the number of draws in the provided [`rvar`]s is used #' instead of the value of this argument. #' #' @details This function unwraps the arrays underlying the input [`rvar`]s in #' `...` and then passes them to `.f`, relying on the vectorization of `.f` #' to evaluate it across draws from the input [`rvar`]s. This is why the arguments #' of `.f` **must** be vectorized. It asks for `n` times the number of draws #' in the input [`rvar`]s (or `ndraws` if none are given) draws from the #' random number generator `.f`, then reshapes the output from `.f` into an #' [`rvar`] with length `n`. #' #' `rvar_rng()` is a fast alternative to `rdo()` or `rfun()`, but you **must** #' ensure that `.f` satisfies the preconditions described above for the result #' to be correct. Most base random number generators satisfy these conditions. #' It is advisable to test against `rdo()` or `rfun()` (which should be correct, #' but slower) if you are uncertain. #' #' @return A single-dimensional [`rvar`] of length `n`. #' #' @examples #' #' mu <- rvar_rng(rnorm, 10, mean = 1:10, sd = 1) #' sigma <- rvar_rng(rgamma, 1, shape = 1, rate = 1) #' x <- rvar_rng(rnorm, 10, mu, sigma) #' x #' #' @family rfun #' @export rvar_rng <- function(.f, n, ..., ndraws = NULL) { args <- list(...) is_rvar_arg <- vapply(args, is_rvar, logical(1)) rvar_args <- conform_rvar_ndraws_nchains(args[is_rvar_arg]) if (length(rvar_args) < 1) { nchains <- 1 ndraws <- ndraws %||% getOption("posterior.rvar_ndraws", 4000) } else { # we have some arguments that are rvars. We require them to be single-dimensional # (vectors) so that R's vector recycling will work correctly. nchains <- nchains(rvar_args[[1]]) ndraws <- ndraws(rvar_args[[1]]) rvar_args_ndims <- lengths(lapply(rvar_args, dim)) if (!all(rvar_args_ndims == 1)) { stop_no_call("All arguments to rvar_rng() that are rvars must be single-dimensional (vectors).") } args[is_rvar_arg] <- lapply(rvar_args, function(x) as.vector(draws_of(x))) } # we must manually recycle numeric vector arguments up to the desired number # of draws so that they can be correctly recycled along the draws of any input # rvars. We only convert numeric *vectors*, as (1) scalars can be recycled # as-is and (2) matrices and 2d+ arrays cannot be correctly recycled using R's # recycling rules so they are typically only used as constant arguments to # random number generator functions (e.g. Sigma for a multivariate normal), # so we don't need to worry about them. is_numeric_vector_arg <- vapply(args, function(x) is.numeric(x) && length(x) > 1 && length(dim(x)) <= 1, logical(1)) & !is_rvar_arg args[is_numeric_vector_arg] <- lapply(args[is_numeric_vector_arg], rep, each = ndraws) nd <- n * ndraws args <- c(n = nd, args) result <- do.call(.f, args) dim(result) <- c(ndraws, n) new_rvar(result, .nchains = nchains) } posterior/R/rvar-dist.R0000755000175000017500000000424114165314652014704 0ustar nileshnilesh#' Density, CDF, and quantile functions of random variables #' #' The probability density function (`density()`), cumulative distribution #' function (`cdf()`), and quantile function / inverse CDF (`quantile()`) of #' an [`rvar`]. #' #' @param x (rvar) An [`rvar`] object. #' @param q,at (numeric vector) One or more quantiles. #' @param probs (numeric vector) One or more probabilities in `[0,1]`. #' @param ... Additional arguments passed onto underlying methods: #' - For `density()`, these are passed to [stats::density()]. #' - For `cdf()`, these are ignored. #' - For `quantile()`, these are passed to [stats::quantile()]. #' #' @return #' #' If `x` is a scalar [`rvar`], returns a vector of the same length as the input #' (`q`, `at`, or `probs`) containing values from the corresponding function #' of the given [`rvar`]. #' #' If `x` has length greater than 1, returns an array with dimensions #' `c(length(y), dim(x))` where `y` is `q`, `at`, or `probs`, where each #' `result[i,...]` is the value of the corresponding function,`f(y[i])`, for #' the corresponding cell in the input array, `x[...]`. #' #' @examples #' #' set.seed(1234) #' x = rvar(rnorm(100)) #' #' density(x, seq(-2, 2, length.out = 10)) #' cdf(x, seq(-2, 2, length.out = 10)) #' quantile(x, ppoints(10)) #' #' x2 = c(rvar(rnorm(100, mean = -0.5)), rvar(rnorm(100, mean = 0.5))) #' density(x2, seq(-2, 2, length.out = 10)) #' cdf(x2, seq(-2, 2, length.out = 10)) #' quantile(x2, ppoints(10)) #' #' @name rvar-dist #' @export density.rvar <- function(x, at, ...) { summarise_rvar_by_element(x, function(draws) { d <- density(draws, cut = 0, ...) f <- approxfun(d$x, d$y, yleft = 0, yright = 0) f(at) }) } #' @importFrom distributional cdf #' @export distributional::cdf #' @rdname rvar-dist #' @export cdf.rvar <- function(x, q, ...) { summarise_rvar_by_element(x, function(draws) { ecdf(draws)(q) }) } #' @rdname rvar-dist #' @export quantile.rvar <- function(x, probs, ...) { summarise_rvar_by_element_via_matrix(x, function(draws) { t(matrixStats::colQuantiles(draws, probs = probs, useNames = TRUE, ...)) }, .extra_dim = length(probs), .extra_dimnames = list(NULL) ) } posterior/R/reserved_variables.R0000644000175000017500000000434614165314652016643 0ustar nileshnilesh#' Reserved variables #' #' Get names of reserved variables from objects in the \pkg{posterior} package. #' #' @name reserved_variables #' @template args-methods-x #' @template args-methods-dots #' @details #' #' `reserved_variables()` returns the names of reserved variables in use by #' an object. #' #' The following variables names are currently reserved for special use cases #' in all [`draws`] formats: #' * `.log_weight`: Log weights per draw (see [`weight_draws`]). #' #' Further, specific for the [`draws_df`] format, there are three additional #' reserved variables: #' * `.chain`: Chain index per draw #' * `.iteration`: Iteration index within each chain #' * `.draw`: Draw index across chains #' #' More reserved variables may be added in the future. #' #' @return #' #' A character vector of reserved variables used in `x`. #' #' @examples #' #' x <- example_draws() #' reserved_variables(x) #' #' # if we add weights, the `.log_weight` reserved variable is used #' x <- weight_draws(x, rexp(ndraws(x))) #' reserved_variables(x) #' #' @export reserved_variables <- function(x, ...) { UseMethod("reserved_variables") } #' @rdname reserved_variables #' @export reserved_variables.default <- function(x, ...) { c(".log_weight") } #' @rdname reserved_variables #' @export reserved_variables.draws_matrix <- function(x, ...) { intersect(reserved_variables(), colnames(x)) } #' @rdname reserved_variables #' @export reserved_variables.draws_array <- function(x, ...) { intersect(reserved_variables(), dimnames(x)[[3]]) } #' @rdname reserved_variables #' @export reserved_variables.draws_df <- function(x, ...) { intersect(reserved_variables(), names(x)) } #' @rdname reserved_variables #' @export reserved_variables.draws_list <- function(x, ...) { intersect(reserved_variables(), names(x[[1]])) } #' @rdname reserved_variables #' @export reserved_variables.draws_rvars <- function(x, ...) { intersect(reserved_variables(), names(x)) } # internal ---------------------------------------------------------------- # reserved variables specific for the 'draws_df' format reserved_df_variables <- function() { c(".chain", ".iteration", ".draw") } all_reserved_variables <- function(x = NULL) { c(reserved_variables(x), reserved_df_variables()) } posterior/R/example_draws.R0000644000175000017500000000361114165314652015621 0ustar nileshnilesh#' Example `draws` objects #' #' Objects for use in examples, vignettes, and tests. #' #' @param example (string) The name of the example `draws` object. See #' **Details** for available options. #' @return A `draws` object. #' #' @details #' The following example `draws` objects are available. #' #' **eight_schools**: A [`draws_array`] object with 100 iterations #' from each of 4 Markov chains obtained by fitting the eight schools model #' described in Gelman et al. (2013) with [Stan](https://mc-stan.org). The #' variables are: #' * `mu`: Overall mean of the eight schools #' * `tau`: Standard deviation between schools #' * `theta`: Individual means of each of the eight schools #' #' **multi_normal**: A [`draws_array`] object with 100 iterations from each of #' the 4 Markov chains obtained by fitting a 3-dimensional multivariate normal #' model to 100 simulated observations. The variables are: #' * `mu`: Mean parameter vector of length 3 #' * `Sigma`: Covariance matrix of dimension 3 x 3 #' #' @note These objects are only intended to be used in demonstrations and tests. #' They contain fewer iterations and chains than recommended for performing #' actual inference. #' #' @references #' Andrew Gelman, John B. Carlin, Hal S. Stern, David B. Dunson, Aki Vehtari and #' Donald B. Rubin (2013). Bayesian Data Analysis, Third Edition. Chapman and #' Hall/CRC. #' #' @examples #' draws_eight_schools <- example_draws("eight_schools") #' summarise_draws(draws_eight_schools) #' #' draws_multi_normal <- example_draws("multi_normal") #' summarise_draws(draws_multi_normal) #' #' @export example_draws <- function(example = "eight_schools") { assert_choice(example, example_choices()) # saved in R/sysdata.rda draws_name <- paste0("draws_", example) get(draws_name, asNamespace("posterior")) } # names of choices for 'example_draws' example_choices <- function() { c("eight_schools", "multi_normal") } posterior/R/weight_draws.R0000644000175000017500000001161114165314652015454 0ustar nileshnilesh#' Weight `draws` objects #' #' Add weights to [`draws`] objects, with one weight per draw, for use in #' subsequent weighting operations. For reasons of numerical accuracy, weights #' are stored in the form of unnormalized log-weights (in a variable called #' `.log_weight`). See [weights.draws()] for details how to extract weights from #' `draws` objects. #' #' @template args-methods-x #' @param weights (numeric vector) A vector of weights of length `ndraws(x)`. #' Weights will be internally stored on the log scale (in a variable called #' `.log_weight`) and will not be normalized, but normalized (non-log) weights #' can be returned via the [weights.draws()] method later. #' @param log (logicla) Are the weights passed already on the log scale? The #' default is `FALSE`, that is, expecting `weights` to be on the standard #' (non-log) scale. #' @template args-methods-dots #' @template return-draws #' #' @seealso [weights.draws()], [resample_draws()] #' #' @examples #' x <- example_draws() #' #' # sample some random weights for illustration #' wts <- rexp(ndraws(x)) #' head(wts) #' #' # add weights #' x <- weight_draws(x, weights = wts) #' #' # extract weights #' head(weights(x)) # defaults to normalized weights #' head(weights(x, normalize=FALSE)) # recover original weights #' head(weights(x, log=TRUE)) # get normalized log-weights #' #' # add weights which are already on the log scale #' log_wts <- log(wts) #' head(log_wts) #' #' x <- weight_draws(x, weights = log_wts, log = TRUE) #' # extract weights #' head(weights(x)) #' head(weights(x, log=TRUE, normalize = FALSE)) # recover original log_wts #' #' @export weight_draws <- function(x, weights, ...) { UseMethod("weight_draws") } #' @rdname weight_draws #' @export weight_draws.draws_matrix <- function(x, weights, log = FALSE, ...) { log <- as_one_logical(log) log_weights <- validate_weights(weights, x, log = log) if (".log_weight" %in% variables(x, reserved = TRUE)) { # overwrite existing weights x[, ".log_weight"] <- log_weights } else { # add weights as a new variable log_weights <- draws_matrix(.log_weight = log_weights, .nchains = nchains(x)) x <- bind_draws(x, log_weights) } x } #' @rdname weight_draws #' @export weight_draws.draws_array <- function(x, weights, log = FALSE, ...) { log <- as_one_logical(log) log_weights <- validate_weights(weights, x, log = log) if (".log_weight" %in% variables(x, reserved = TRUE)) { # overwrite existing weights x[, , ".log_weight"] <- log_weights } else { # add weights as a new variable log_weights <- draws_array(.log_weight = log_weights, .nchains = nchains(x)) x <- bind_draws(x, log_weights) } x } #' @rdname weight_draws #' @export weight_draws.draws_df <- function(x, weights, log = FALSE, ...) { log <- as_one_logical(log) log_weights <- validate_weights(weights, x, log = log) x$.log_weight <- log_weights x } #' @rdname weight_draws #' @export weight_draws.draws_list <- function(x, weights, log = FALSE, ...) { log <- as_one_logical(log) log_weights <- validate_weights(weights, x, log = log) niterations <- niterations(x) for (i in seq_len(nchains(x))) { sel <- (1 + (i - 1) * niterations):(i * niterations) x[[i]]$.log_weight <- log_weights[sel] } x } #' @rdname weight_draws #' @export weight_draws.draws_rvars <- function(x, weights, log = FALSE, ...) { log <- as_one_logical(log) log_weights <- validate_weights(weights, x, log = log) x$.log_weight <- rvar(log_weights) x } #' Extract Weights from Draws Objects #' #' Extract weights from [`draws`] objects, with one weight per draw. #' See [`weight_draws`] for details how to add weights to [`draws`] objects. #' #' @param object (draws) A [`draws`] object. #' @param log (logical) Should the weights be returned on the log scale? #' Defaults to `FALSE`. #' @param normalize (logical) Should the weights be normalized to sum to 1 on #' the standard scale? Defaults to `TRUE`. #' @template args-methods-dots #' #' @return A vector of weights, with one weight per draw. #' #' @seealso [`weight_draws`], [`resample_draws`] #' #' @inherit weight_draws examples #' #' @export weights.draws <- function(object, log = FALSE, normalize = TRUE, ...) { log <- as_one_logical(log) normalize <- as_one_logical(normalize) if (!".log_weight" %in% variables(object, reserved = TRUE)) { return(NULL) } out <- extract_variable(object, ".log_weight") if (normalize) { out <- out - log_sum_exp(out) } if (!log) { out <- exp(out) } out } # validate weights and return log weights validate_weights <- function(weights, draws, log = FALSE) { checkmate::expect_numeric(weights) checkmate::expect_flag(log) if (length(weights) != ndraws(draws)) { stop_no_call("Number of weights must match the number of draws.") } if (!log) { if (any(weights < 0)) { stop_no_call("Weights must be non-negative.") } weights <- log(weights) } weights } posterior/R/order_draws.R0000644000175000017500000000501314165314652015277 0ustar nileshnilesh#' Order `draws` objects #' #' Order [`draws`] objects according to iteration and chain number. By default, #' draws objects are ordered but subsetting or extracting parts of them may #' leave them in an unordered state. #' #' @template args-methods-x #' @template args-methods-dots #' @template return-draws #' @seealso [repair_draws()] #' @examples #' x <- as_draws_array(example_draws()) #' dimnames(x[10:5, 4:3, ]) #' dimnames(order_draws(x[10:5, 4:3, ])) #' #' @export order_draws <- function(x, ...) { UseMethod("order_draws") } #' @rdname order_draws #' @export order_draws.draws_matrix <- function(x, ...) { draw_order <- order(draw_ids(x)) if (needs_ordering(draw_order)) { x <- x[draw_order, ] } x } #' @rdname order_draws #' @export order_draws.draws_array <- function(x, ...) { iteration_order <- order(iteration_ids(x)) chain_order <- order(chain_ids(x)) if (needs_ordering(iteration_order, chain_order)) { x <- x[iteration_order, chain_order, ] } x } #' @rdname order_draws #' @export order_draws.draws_df <- function(x, ...) { row_order <- order(x$.chain, x$.iteration) if (needs_ordering(row_order)) { x <- x[row_order, ] } x } #' @rdname order_draws #' @export order_draws.draws_list <- function(x, ...) { chain_order <- order(chain_ids(x)) if (needs_ordering(chain_order)) { x <- x[chain_order] } x } #' @rdname order_draws #' @export order_draws.draws_rvars <- function(x, ...) { for (i in seq_along(x)) { x[[i]] <- order_draws(x[[i]]) } x } #' @rdname order_draws #' @importFrom rlang missing_arg #' @importFrom vctrs vec_slice #' @export order_draws.rvar <- function(x, ...) { draw_order <- order(draw_ids(x)) if (needs_ordering(draw_order)) { # if ordering is needed, must also merge chains (as out-of-order draws # imply chain information is no longer meaningful) if (nchains(x) > 1) { x <- merge_chains(x) } draws_of(x) <- vec_slice(draws_of(x), draw_order) } x } # internal ---------------------------------------------------------------- #' Order draws if told to do so #' @param x draws object to be ordered #' @param order should the draws object be ordered? #' @return potentially ordered draws object #' @noRd do_ordering <- function(x, order, ...) { order <- as_one_logical(order) if (order) { x <- order_draws(x, ...) } x } # are vectors in an unordered state? needs_ordering <- function(...) { dots <- list(...) .needs_ordering <- function(x) { any(x != seq_along(x)) } any(ulapply(dots, .needs_ordering)) } posterior/R/merge_chains.R0000644000175000017500000000422014165314652015407 0ustar nileshnilesh#' Merge chains of `draws` objects #' #' Merge chains of [`draws`] objects into a single chain. Some operations will #' trigger an automatic merging of chains, for example, because chains do not #' match between two objects involved in a binary operation. By default, no #' warning will be issued when this happens but you can activate one via #' `options(posterior.warn_on_merge_chains = TRUE)`. #' #' @template args-methods-x #' @template args-methods-dots #' @template return-draws #' #' @examples #' x <- example_draws() #' #' # draws_array with 4 chains, 100 iters each #' str(x) #' #' # draws_array with 1 chain of 400 iterations #' str(merge_chains(x)) #' #' @export merge_chains <- function(x, ...) { UseMethod("merge_chains") } #' @rdname merge_chains #' @export merge_chains.draws_matrix <- function(x, ...) { attr(x, "nchains") <- 1L x } #' @rdname merge_chains #' @export merge_chains.draws_array <- function(x, ...) { x <- merge_chains(as_draws_matrix(x)) as_draws_array(x) } #' @rdname merge_chains #' @export merge_chains.draws_df <- function(x, ...) { x$.chain <- rep(1L, nrow(x)) x$.iteration <- x$.draw x } #' @rdname merge_chains #' @export merge_chains.draws_list <- function(x, ...) { if (nchains(x) == 0) { return(x) } out <- empty_draws_list(variables(x), nchains = 1) for (v in variables(out)) { out[[1]][[v]] <- ulapply(x, "[[", v) } out } #' @rdname merge_chains #' @export merge_chains.rvar <- function(x, ...) { nchains_rvar(x) <- 1L x } #' @rdname merge_chains #' @export merge_chains.draws_rvars <- function(x, ...) { for (i in seq_along(x)) { x[[i]] <- merge_chains(x[[i]]) } x } # some operations lead to an automatic chain merge # that users can choose to be warned about warn_merge_chains <- function(type = c("match", "index")) { warn <- as_one_logical(getOption( "posterior.warn_on_merge_chains", default = FALSE )) if (warn) { type <- as_one_character(type) warning_no_call( "Chains were dropped", switch(type, ".", match = " due to chain information not matching.", index = " due to manually indexing draws." ) ) } invisible(NULL) } posterior/R/subset_draws.R0000644000175000017500000003036714165314652015503 0ustar nileshnilesh#' Subset `draws` objects #' #' Subset [`draws`] objects by variables, iterations, chains, and draws indices. #' #' @template args-methods-x #' @param variable (character vector) The variables to select. All elements of #' non-scalar variables can be selected at once. #' @param iteration (integer vector) The iteration indices to select. #' @param chain (integer vector) The chain indices to select. #' @param draw (integer vector) The draw indices to be select. Subsetting draw #' indices will lead to an automatic merging of chains via [`merge_chains`]. #' @param regex (logical) Should `variable` should be treated as a #' (vector of) regular expressions? Any variable in `x` matching at least one #' of the regular expressions will be selected. Defaults to `FALSE`. #' @param unique (logical) Should duplicated selection of chains, iterations, or #' draws be allowed? If `TRUE` (the default) only unique chains, iterations, #' and draws are selected regardless of how often they appear in the #' respective selecting arguments. #' #' @template args-methods-dots #' @template return-draws #' #' @details #' To ensure that multiple consecutive subsetting operations work correctly, #' `subset()` *[repairs][repair_draws]* the `draws` object before and after #' subsetting. #' #' @examples #' x <- example_draws() #' subset_draws(x, variable = c("mu", "tau")) #' subset_draws(x, chain = 2) #' subset_draws(x, iteration = 5:10, chain = 3:4) #' #' # extract the first chain twice #' subset_draws(x, chain = c(1, 1), unique = FALSE) #' #' # extract all elements of 'theta' #' subset_draws(x, variable = "theta") #' #' @export subset_draws <- function(x, ...) { UseMethod("subset_draws") } #' @rdname subset_draws #' @export subset_draws.draws_matrix <- function(x, variable = NULL, iteration = NULL, chain = NULL, draw = NULL, regex = FALSE, unique = TRUE, ...) { if (all_null(variable, iteration, chain, draw)) { return(x) } x <- repair_draws(x) variable <- check_existing_variables(variable, x, regex = regex) iteration <- check_iteration_ids(iteration, x, unique = unique) chain <- check_chain_ids(chain, x, unique = unique) draw <- check_draw_ids(draw, x, unique = unique) x <- prepare_subsetting(x, iteration, chain, draw) x <- .subset_draws(x, iteration, chain, draw, variable, reserved = TRUE) if (!is.null(chain) || !is.null(iteration)) { x <- repair_draws(x, order = FALSE) } x } #' @rdname subset_draws #' @export subset_draws.draws_array <- function(x, variable = NULL, iteration = NULL, chain = NULL, draw = NULL, regex = FALSE, unique = TRUE, ...) { if (all_null(variable, iteration, chain, draw)) { return(x) } x <- repair_draws(x) variable <- check_existing_variables(variable, x, regex = regex) iteration <- check_iteration_ids(iteration, x, unique = unique) chain <- check_chain_ids(chain, x, unique = unique) draw <- check_draw_ids(draw, x, unique = unique) x <- prepare_subsetting(x, iteration, chain, draw) if (!is.null(draw)) { iteration <- draw } x <- .subset_draws(x, iteration, chain, variable, reserved = TRUE) if (!is.null(chain) || !is.null(iteration)) { x <- repair_draws(x, order = FALSE) } x } #' @rdname subset_draws #' @export subset_draws.draws_df <- function(x, variable = NULL, iteration = NULL, chain = NULL, draw = NULL, regex = FALSE, unique = TRUE, ...) { if (all_null(variable, iteration, chain, draw)) { return(x) } x <- repair_draws(x) unique <- as_one_logical(unique) variable <- check_existing_variables(variable, x, regex = regex) iteration <- check_iteration_ids(iteration, x, unique = unique) chain <- check_chain_ids(chain, x, unique = unique) draw <- check_draw_ids(draw, x, unique = unique) x <- prepare_subsetting(x, iteration, chain, draw) x <- .subset_draws( x, iteration, chain, draw, variable, unique = unique, reserved = TRUE ) x } #' @rdname subset_draws #' @export subset_draws.draws_list <- function(x, variable = NULL, iteration = NULL, chain = NULL, draw = NULL, regex = FALSE, unique = TRUE, ...) { if (all_null(variable, iteration, chain, draw)) { return(x) } x <- repair_draws(x) variable <- check_existing_variables(variable, x, regex = regex) iteration <- check_iteration_ids(iteration, x, unique = unique) chain <- check_chain_ids(chain, x, unique = unique) draw <- check_draw_ids(draw, x, unique = unique) x <- prepare_subsetting(x, iteration, chain, draw) if (!is.null(draw)) { iteration <- draw } x <- .subset_draws(x, iteration, chain, variable, reserved = TRUE) if (!is.null(chain) || !is.null(iteration)) { x <- repair_draws(x, order = FALSE) } x } #' @rdname subset_draws #' @export subset_draws.draws_rvars <- function(x, variable = NULL, iteration = NULL, chain = NULL, draw = NULL, regex = FALSE, unique = TRUE, ...) { if (all_null(variable, iteration, chain, draw)) { return(x) } x <- repair_draws(x) variable <- check_existing_variables(variable, x, regex = regex) iteration <- check_iteration_ids(iteration, x, unique = unique) chain <- check_chain_ids(chain, x, unique = unique) draw <- check_draw_ids(draw, x, unique = unique) x <- prepare_subsetting(x, iteration, chain, draw) if (!is.null(draw)) { iteration <- draw } x <- .subset_draws(x, iteration, chain, variable, reserved = TRUE) if (!is.null(chain) || !is.null(iteration)) { x <- repair_draws(x, order = FALSE) } x } #' @rdname subset_draws #' @export subset.draws <- function(x, ...) { subset_draws(x, ...) } #' subset specified non-NULL dimensions #' @param x an object to be subsetted #' @param ... arguments containing indices for subsetting a dimension #' NULL is treated as not subsetting that dimension #' @noRd subset_dims <- function(x, ...) { dots <- list(...) if (!length(dots)) { return(x) } dim_x <- max(length(dim(x)), 1L) if (length(dots) > dim_x) { stop_no_call("'x' has only ", dim_x, " dimensions.") } if (length(dots) < dim_x) { dots <- c(dots, repl(NULL, dim_x - length(dots))) } names(dots) <- paste0("i", seq_along(dots)) args <- rep("", length(dots)) for (i in seq_along(dots)) { if (!is.null(dots[[i]])) { args[i] <- names(dots)[i] } } args <- paste0(args, collapse = ", ") call <- paste0("x[", args, "]") dots$x <- x eval2(call, dots) } # internal method for subset_draws .subset_draws <- function(x, ...) { UseMethod(".subset_draws") } #' @export .subset_draws.draws_matrix <- function(x, iteration = NULL, chain = NULL, draw = NULL, variable = NULL, reserved = FALSE, ...) { out <- subset_dims(x, NULL, variable) if (!is.null(draw)) { out <- out[draw, ] } else { if (!is.null(chain)) { chain <- unique(chain) nchains <- length(chain) chain_ids <- rep(chain_ids(out), each = niterations(out)) slice_index <- chain_ids %in% chain out <- out[slice_index, ] attr(out, "nchains") <- nchains } if (!is.null(iteration)) { niterations <- length(iteration) slice_index <- iteration + (rep(chain_ids(out), each = niterations) - 1) * niterations(out) nchains <- nchains(out) out <- out[slice_index, ] attr(out, "nchains") <- nchains } } if (reserved && !is.null(variable)) { new_vars <- variables(out, reserved = TRUE) reserved_vars <- setdiff(reserved_variables(x), new_vars) if (length(reserved_vars)) { x_reserved <- subset_dims(x, draw, reserved_vars) out <- cbind(out, x_reserved) class(out) <- class(x) } } out } #' @export .subset_draws.draws_array <- function(x, iteration = NULL, chain = NULL, variable = NULL, reserved = FALSE, ...) { out <- subset_dims(x, iteration, chain, variable) if (reserved && !is.null(variable)) { new_vars <- variables(out, reserved = TRUE) reserved_vars <- setdiff(reserved_variables(x), new_vars) if (length(reserved_vars)) { x_reserved <- subset_dims(x, iteration, chain, reserved_vars) out <- abind(out, x_reserved, along = 3L) class(out) <- class(x) } } out } #' @export .subset_draws.draws_df <- function(x, iteration = NULL, chain = NULL, draw = NULL, variable = NULL, unique = TRUE, reserved = FALSE, ...) { if (!is.null(variable)) { x <- x[, variable, reserved = TRUE] } if (!is.null(draw)) { # each x$.draw is unique so using 'match' is valid here x <- x[match(draw, x$.draw), ] x$.draw <- repair_iteration_ids(x$.draw) x$.iteration <- x$.draw } else if (!is.null(chain) || !is.null(iteration)) { if (unique) { if (!is.null(chain)) { x <- x[x$.chain %in% chain, ] } if (!is.null(iteration)) { x <- x[x$.iteration %in% iteration, ] } x <- repair_draws(x, order = FALSE) } else { if (!is.null(chain)) { x <- x[unlist(lapply(chain, function(c) which(x$.chain == c))), ] x$.chain <- rep(seq_along(chain), each = nrow(x) / length(chain)) } if (!is.null(iteration)) { x <- x[unlist(lapply(iteration, function(i) which(x$.iteration == i))), ] x$.iteration <- rep(seq_along(iteration), each = nrow(x) / length(iteration)) } x <- repair_draws(x) } } if (!reserved && !is.null(variable)) { # remove reserved variables which were not selected reserved_vars <- setdiff(reserved_variables(x), variable) x <- remove_variables(x, reserved_vars) } x } #' @export .subset_draws.draws_list <- function(x, iteration = NULL, chain = NULL, variable = NULL, reserved = FALSE, ...) { if (!is.null(chain)) { x <- x[chain] } if (!is.null(variable)) { if (reserved) { z <- x } for (i in seq_along(x)) { x[[i]] <- x[[i]][variable] } if (reserved) { new_vars <- variables(x, reserved = TRUE) reserved_vars <- setdiff(reserved_variables(z), new_vars) if (length(reserved_vars)) { for (i in seq_along(x)) { x[[i]] <- c(x[[i]], z[[i]][reserved_vars]) } } remove(z) } } if (!is.null(iteration)) { for (i in seq_along(x)) { for (j in seq_along(x[[i]])) { x[[i]][[j]] <- x[[i]][[j]][iteration] } } } x } #' @importFrom vctrs vec_slice #' @export .subset_draws.draws_rvars <- function(x, iteration = NULL, chain = NULL, variable = NULL, reserved = FALSE, ...) { if (!is.null(variable)) { if (reserved) { z <- x } x <- x[variable] if (reserved) { new_vars <- variables(x, reserved = TRUE) reserved_vars <- setdiff(reserved_variables(z), new_vars) x <- c(x, z[reserved_vars]) # c() currently removes the 'draws' classes class(x) <- class_draws_rvars() remove(z) } } if (!is.null(chain)) { chain <- unique(chain) nchains <- length(chain) chain_ids <- rep(chain_ids(x), each = niterations(x)) slice_index <- chain_ids %in% chain for (i in seq_along(x)) { draws_of(x[[i]]) <- vec_slice(draws_of(x[[i]]), slice_index) nchains_rvar(x[[i]]) <- nchains } } if (!is.null(iteration)) { niterations <- length(iteration) slice_index <- iteration + (rep(chain_ids(x), each = niterations) - 1) * niterations(x) for (i in seq_along(x)) { draws_of(x[[i]]) <- vec_slice(draws_of(x[[i]]), slice_index) } } x } # prepare object to be subsetted via 'subset_draws' prepare_subsetting <- function(x, iteration = NULL, chain = NULL, draw = NULL) { if (!is.null(draw)) { if (!is.null(iteration)) { stop_no_call("Cannot subset 'iteration' and 'draw' at the same time.") } if (!is.null(chain)) { stop_no_call("Cannot subset 'chain' and 'draw' at the same time.") } if (nchains(x) > 1L) { message("Merging chains in order to subset via 'draw'.") x <- merge_chains(x) } } x } posterior/R/mutate_variables.R0000644000175000017500000000654414165314652016325 0ustar nileshnilesh#' Mutate variables in `draws` objects #' #' Mutate variables in a [`draws`] object. #' #' @param .x (draws) A [`draws`] object. #' @param ... Name-value pairs of expressions, each with either length 1 or the #' same length as in the entire input (i.e., number of iterations or draws). #' The name of each argument will be the name of a new variable, and the value #' will be its corresponding value. Use a `NULL` value in `mutate_variables` #' to drop a variable. New variables overwrite existing variables of the same #' name. #' #' @return #' Returns a [`draws`] object of the same format as `.x`, with variables mutated #' according to the expressions provided in `...`. #' #' @details #' In order to mutate variables in [`draws_matrix`] and [`draws_array`] objects, #' they are transformed to [`draws_df`] objects first and then transformed back #' after mutation. As those transformations are quite expensive for larger #' number of draws, we recommend using `mutate_variables` on [`draws_df`] and #' [`draws_list`] objects if speed is an issue. #' #' In [`draws_rvars`] objects, the output of each expression in `...` is #' coerced to an [`rvar`] object if it is not already one using `as_rvar()`. #' #' @seealso [`variables`], [`rename_variables`] #' #' @examples #' x <- as_draws_df(example_draws()) #' x <- subset(x, variable = c("mu", "tau")) #' #' mutate_variables(x, tau2 = tau^2) #' mutate_variables(x, scale = 1.96 * tau, lower = mu - scale) #' #' @importFrom rlang enquos caller_env eval_tidy as_label #' @export mutate_variables <- function(.x, ...) { UseMethod("mutate_variables") } #' @rdname mutate_variables #' @export mutate_variables.draws_matrix <- function(.x, ...) { as_draws_matrix(mutate_variables(as_draws_df(.x), ...)) } #' @rdname mutate_variables #' @export mutate_variables.draws_array <- function(.x, ...) { as_draws_array(mutate_variables(as_draws_df(.x), ...)) } #' @rdname mutate_variables #' @export mutate_variables.draws_df <- function(.x, ...) { dots <- enquos(..., .named = TRUE) names(dots) <- check_reserved_variables(names(dots)) env <- caller_env() for (var in names(dots)) { .x[[var]] <- .mutate_variable(dots[[var]], .x, env) } .x } #' @rdname mutate_variables #' @export mutate_variables.draws_list <- function(.x, ...) { dots <- enquos(..., .named = TRUE) names(dots) <- check_reserved_variables(names(dots)) env <- caller_env() for (chain in seq_along(.x)) { for (var in names(dots)) { .x[[chain]][[var]] <- .mutate_variable(dots[[var]], .x[[chain]], env) } } .x } #' @rdname mutate_variables #' @export mutate_variables.draws_rvars <- function(.x, ...) { dots <- enquos(..., .named = TRUE) names(dots) <- check_reserved_variables(names(dots)) env <- caller_env() for (var in names(dots)) { .x[[var]] <- as_rvar(eval_tidy(dots[[var]], .x, env)) } conform_rvar_ndraws_nchains(.x) } # evaluate an expression passed to 'mutate_variables' and check its validity .mutate_variable <- function(expr, data, env = caller_env()) { out <- eval_tidy(expr, data, env) if (!is.numeric(out)) { stop_no_call("{", as_label(expr), "} does not evaluate to a numeric vector.") } n <- length(data[[1]]) if (length(out) == 1L) { out <- rep(out, n) } if (length(out) != n) { stop_no_call("{", as_label(expr), "} does not evaluate ", "to a vector of length 1 or ", n, ".") } out } posterior/R/repair_draws.R0000644000175000017500000001020214165314652015442 0ustar nileshnilesh#' Repair indices of `draws` objects #' #' Repair indices of `draws` objects so that iterations, chains, and draws #' are continuously and consistently numbered. #' #' @template args-methods-x #' @template args-methods-dots #' @param order (logical) Should draws be ordered (via [`order_draws()`]) before #' repairing indices? Defaults to `TRUE`. #' @template return-draws #' @seealso [order_draws()] #' @examples #' x <- as_draws_array(example_draws()) #' (x <- x[10:5, 3:4, ]) #' repair_draws(x) #' #' @export repair_draws <- function(x, order = TRUE, ...) { UseMethod("repair_draws") } #' @rdname repair_draws #' @export repair_draws.draws_matrix <- function(x, order = TRUE, ...) { # ensure integer instead of character ordering rownames(x) <- repair_ids(rownames(x)) x <- do_ordering(x, order) rownames(x) <- as.character(seq_rows(x)) x } #' @rdname repair_draws #' @export repair_draws.draws_array <- function(x, order = TRUE, ...) { # ensure integer instead of character ordering rownames(x) <- repair_ids(rownames(x)) colnames(x) <- repair_ids(colnames(x)) x <- do_ordering(x, order) rownames(x) <- as.character(seq_rows(x)) colnames(x) <- as.character(seq_cols(x)) x } #' @rdname repair_draws #' @export repair_draws.draws_df <- function(x, order = TRUE, ...) { x <- do_ordering(x, order) x$.chain <- repair_chain_ids(x$.chain) x$.iteration <- repair_iteration_ids(x$.iteration, x$.chain) x$.draw <- compute_draw_ids(x$.chain, x$.iteration) x } #' @rdname repair_draws #' @export repair_draws.draws_list <- function(x, order = TRUE, ...) { # ensure integer instead of character ordering names(x) <- repair_ids(names(x)) x <- do_ordering(x, order) names(x) <- seq_along(x) x } #' @rdname repair_draws #' @export repair_draws.draws_rvars <- function(x, order = TRUE, ...) { for (i in seq_along(x)) { x[[i]] <- repair_draws(x[[i]], order = order, ...) } x } #' @rdname repair_draws #' @export repair_draws.rvar <- function(x, order = TRUE, ...) { rownames(draws_of(x)) <- repair_ids(rownames(draws_of(x))) order <- as_one_logical(order) if (order) { x <- order_draws(x) } else if (nchains(x) > 1) { # even if we aren't asked to order draws, still need to check on the order # because if the draws are out of order we have to drop chain info (it would # no longer be guaranteed to be correct) draw_order <- order(draw_ids(x)) if (needs_ordering(draw_order)) { x <- merge_chains(x) } } rownames(draws_of(x)) <- as.character(seq_rows(draws_of(x))) x } # internal ---------------------------------------------------------------- #' Repair indices to be continuously numbered integers starting from one #' @param x vector of values #' @noRd repair_ids <- function(x) { out <- SW(as.integer(x)) if (anyNA(out)) { # use character instead of integer ordering if # some values cannot be converted to integers out <- factor(x) } else { out <- factor(out) } as.integer(out) } #' Repair iteration indices #' @param iteration_ids A vector of iteration indices #' @param chain_ids A vector of chain indices #' @noRd repair_iteration_ids <- function(iteration_ids, chain_ids = NULL) { .repair_iteration_ids <- function(x) { match(seq_along(x), order(x)) } if (is.null(chain_ids)) { out <- .repair_iteration_ids(iteration_ids) } else { check_true(length(iteration_ids) == length(chain_ids)) unique_chain_ids <- unique(chain_ids) out <- rep(NA, length(iteration_ids)) for (u in unique(chain_ids)) { sel <- chain_ids == u out[sel] <- .repair_iteration_ids(iteration_ids[sel]) } } as.integer(out) } #' Repair chain indices #' @param chain_ids A vector of chain indices #' @noRd repair_chain_ids <- function(chain_ids) { repair_ids(chain_ids) } #' Compute draw indices from iteration and chain indices #' @param chain_ids A vector of chain indices #' @param iteration_ids A vector of iteration indices #' @noRd compute_draw_ids <- function(chain_ids, iteration_ids) { assert_true(length(chain_ids) == length(iteration_ids)) niterations <- SW(max(iteration_ids)) out <- (chain_ids - 1L) * niterations + iteration_ids as.integer(out) } posterior/R/rvar-summaries-within-draws.R0000755000175000017500000001425314165314652020370 0ustar nileshnilesh# Summaries over array elements, within draws --------------------------------------------------------- #' Summaries of random variables over array elements, within draws #' #' Compute summaries of random variables over array elements and within draws, #' producing a new random variable of length 1 (except in the case of #' `rvar_range()`, see **Details**). #' #' @param ... (rvar) One or more [`rvar`]s. #' @template args-rvar-summaries-na.rm #' @param constant (scalar real) For `rvar_mad()`, a scale factor for computing #' the median absolute deviation. See the details of `stats::mad()` for the #' justification for the default value. #' @param probs (numeric vector) For `rvar_quantile()`, probabilities in `[0, 1]`. #' @param names (logical) For `rvar_quantile()`, if `TRUE`, the result has a #' `names` attribute. #' #' @details #' #' These functions compute statistics within each draw of the random variable. #' For summaries over draws (such as expectations), see [rvar-summaries-over-draws]. #' #' Each function defined here corresponds to the base function of the same name #' without the `rvar_` prefix (e.g., `rvar_mean()` calls `mean()` under the hood, etc). #' #' @return #' An [`rvar`] of length 1 (for `range()`, length 2; for `quantile()`, length #' equal to `length(probs)`) with the same number #' of draws as the input rvar(s) containing the summary statistic computed within #' each draw of the input rvar(s). #' #' @examples #' #' set.seed(5678) #' x = rvar_rng(rnorm, 4, mean = 1:4, sd = 2) #' #' # These will give similar results to mean(1:4), #' # median(1:4), sum(1:4), prod(1:4), etc #' rvar_mean(x) #' rvar_median(x) #' rvar_sum(x) #' rvar_prod(x) #' rvar_range(x) #' rvar_quantile(x, probs = c(0.25, 0.5, 0.75), names = TRUE) #' #' @seealso [rvar-summaries-over-draws] for summary functions across draws (e.g. expectations). #' [rvar-dist] for density, CDF, and quantile functions of random variables. #' @family rvar-summaries #' @name rvar-summaries-within-draws #' @export rvar_mean <- function(..., na.rm = FALSE) { summarise_rvar_within_draws_via_matrix(c(...), matrixStats::rowMeans2, na.rm = na.rm) } # numeric summaries ------------------------------------------------------- #' @rdname rvar-summaries-within-draws #' @export rvar_median <- function(..., na.rm = FALSE) { summarise_rvar_within_draws_via_matrix(c(...), matrixStats::rowMedians, na.rm = na.rm) } #' @rdname rvar-summaries-within-draws #' @export rvar_sum <- function(..., na.rm = FALSE) { summarise_rvar_within_draws_via_matrix(c(...), matrixStats::rowSums2, na.rm = na.rm) } #' @rdname rvar-summaries-within-draws #' @export rvar_prod <- function(..., na.rm = FALSE) { summarise_rvar_within_draws_via_matrix(c(...), matrixStats::rowProds, na.rm = na.rm) } #' @rdname rvar-summaries-within-draws #' @export rvar_min <- function(..., na.rm = FALSE) { summarise_rvar_within_draws_via_matrix(c(...), matrixStats::rowMins, na.rm = na.rm) } #' @rdname rvar-summaries-within-draws #' @export rvar_max <- function(..., na.rm = FALSE) { summarise_rvar_within_draws_via_matrix(c(...), matrixStats::rowMaxs, na.rm = na.rm) } # spread ------------------------------------------------------------------ #' @rdname rvar-summaries-within-draws #' @export rvar_sd <- function(..., na.rm = FALSE) { summarise_rvar_within_draws_via_matrix(c(...), matrixStats::rowSds, na.rm = na.rm) } #' @rdname rvar-summaries-within-draws #' @export rvar_var <- function(..., na.rm = FALSE) { summarise_rvar_within_draws_via_matrix(c(...), matrixStats::rowVars, na.rm = na.rm) } #' @rdname rvar-summaries-within-draws #' @export rvar_mad <- function(..., constant = 1.4826, na.rm = FALSE) { summarise_rvar_within_draws_via_matrix(c(...), matrixStats::rowMads, constant = constant, na.rm = na.rm) } # range ------------------------------------------------------------------- #' @rdname rvar-summaries-within-draws #' @export rvar_range <- function(..., na.rm = FALSE) { summarise_rvar_within_draws_via_matrix(c(...), matrixStats::rowRanges, na.rm = na.rm) } # quantiles --------------------------------------------------------------- #' @rdname rvar-summaries-within-draws #' @export rvar_quantile <- function(..., probs, names = FALSE, na.rm = FALSE) { names <- as_one_logical(names) na.rm <- as_one_logical(na.rm) out <- summarise_rvar_within_draws_via_matrix( c(...), matrixStats::rowQuantiles, probs = probs, na.rm = na.rm, drop = FALSE ) if (!names) { dimnames(out) <- NULL } out } # logical summaries ------------------------------------------------------- #' @rdname rvar-summaries-within-draws #' @export rvar_all <- function(..., na.rm = FALSE) { summarise_rvar_within_draws_via_matrix(c(...), matrixStats::rowAlls, na.rm = na.rm) } #' @rdname rvar-summaries-within-draws #' @export rvar_any <- function(..., na.rm = FALSE) { summarise_rvar_within_draws_via_matrix(c(...), matrixStats::rowAnys, na.rm = na.rm) } # special value predicates ------------------------------------------------ #' Special value predicates for random variables #' #' Compute special value predicates (checking for finite / infinite values, `NaN`, and `NA`) #' on all draws within a random variable, returning a random variable. #' #' @param x (rvar) An [`rvar`]. #' #' @details #' #' These functions return a new [`rvar`] that is the result of applying #' `is.finite()`, `is.infinite()`, `is.nan()`, or `is.na()` to every draw #' in the input random variable. #' #' @return #' A logical [`rvar`] of the same length as the input. #' #' @examples #' #' x <- rvar(c(1, Inf, -Inf, NaN, NA)) #' x #' #' rvar_is_finite(x) #' rvar_is_infinite(x) #' rvar_is_nan(x) #' rvar_is_na(x) #' #' @seealso [rvar-summaries-over-draws] for summary functions across draws, including #' implementations of `is.finite()`, `is.infinite()`, `is.nan()`, and `is.na()` for #' `rvar`s. #' @family rvar-summaries #' @name rvar_is_finite #' @export rvar_is_finite <- function(x) rvar_apply_vec_fun(is.finite, x) #' @rdname rvar_is_finite #' @export rvar_is_infinite <- function(x) rvar_apply_vec_fun(is.infinite, x) #' @rdname rvar_is_finite #' @export rvar_is_nan <- function(x) rvar_apply_vec_fun(is.nan, x) #' @rdname rvar_is_finite #' @export rvar_is_na <- function(x) rvar_apply_vec_fun(is.na, x) posterior/R/zzz.R0000644000175000017500000000060614165314655013627 0ustar nileshnilesh.onAttach <- function(...) { ver <- utils::packageVersion("posterior") packageStartupMessage("This is posterior version ", ver) # packageStartupMessage("- Online documentation and vignettes at mc-stan.org/posterior") } .onLoad <- function(...) { # S3 generics for packages in Suggests, for compatibility with R < 3.6. vctrs::s3_register("dplyr::dplyr_reconstruct", "draws_df") } posterior/R/extract_variable.R0000644000175000017500000000351714165314652016312 0ustar nileshnilesh#' Extract draws of a single variable #' #' Extract a vector of draws of a single variable. #' #' @template args-methods-x #' @param variable (string) The name of the variable to extract. #' @template args-methods-dots #' @return A numeric vector of length equal to the number of draws. #' #' @examples #' x <- example_draws() #' mu <- extract_variable(x, variable = "mu") #' str(mu) #' #' @export extract_variable <- function(x, variable, ...) { UseMethod("extract_variable") } #' @rdname extract_variable #' @export extract_variable.default <- function(x, variable, ...) { x <- as_draws(x) extract_variable(x, variable, ...) } #' @rdname extract_variable #' @export extract_variable.draws <- function(x, variable, ...) { variable <- as_one_character(variable) out <- .subset_draws(x, variable = variable, reserved = FALSE) out <- as_draws_matrix(out) as.vector(out) } #' @rdname extract_variable #' @export extract_variable.draws_rvars <- function(x, variable, ...) { variable <- as_one_character(variable) variable_regex <- regexec("^(.*)\\[.*\\]$", variable) if (!isTRUE(variable_regex[[1]] == -1)) { # regex match => variable with indices in the name ("x[1]", etc), which # can't be subset from draws_rvars directly, so we'll convert to a # draws_array first. root_variable is "x" when variable is "x[...]" root_variable <- regmatches(variable, variable_regex)[[1]][[2]] out <- extract_variable(as_draws_array(x[root_variable]), variable, ...) } else if (length(x[[variable]]) > 1) { stop_no_call( 'Cannot extract non-scalar value using extract_variable():\n', ' "', variable, '" has dimensions: [', paste0(dim(x[[variable]]), collapse = ","), ']\n', ' Try including brackets ("[]") and indices in the variable name to extract a scalar value.' ) } else { out <- NextMethod() } out } posterior/R/resample_draws.R0000644000175000017500000001335114165314652016000 0ustar nileshnilesh#' Resample `draws` objects #' #' Resample [`draws`] objects according to provided weights, for example weights #' obtained through importance sampling. #' #' @template args-methods-x #' @param weights (numeric vector) A vector of positive weights of length #' `ndraws(x)`. The weights will be internally normalized. If `weights` is not #' specified, an attempt will be made to extract any weights already stored in #' the draws object (via [weight_draws()]). How exactly the weights influence #' the resampling depends on the `method` argument. #' @param method (string) The resampling method to use: #' * `"simple"`: simple random resampling with replacement #' * `"simple_no_replace"`: simple random resampling without replacement #' * `"stratified"`: stratified resampling with replacement #' * `"deterministic"`: deterministic resampling with replacement #' #' Currently, `"stratified"` is the default as it has comparably low variance #' and bias with respect to ideal resampling. The latter would sample perfectly #' proportional to the weights, but this is not possible in practice due to the #' finite number of draws available. For more details about resampling methods, #' see Kitagawa (1996). #' @param ndraws (positive integer) The number of draws to be returned. By #' default `ndraws` is set internally to the total number of draws in `x` if #' sensible. #' @template args-methods-dots #' @template return-draws #' #' @details Upon usage of `resample_draws()`, chains will automatically be merged #' due to subsetting of individual draws (see [`subset_draws`] for details). #' Also, weights stored in the `draws` object will be removed in the process, #' as resampling invalidates existing weights. #' #' @references #' Kitagawa, G., Monte Carlo Filter and Smoother for Non-Gaussian Nonlinear ' #' State Space Models, *Journal of Computational and Graphical Statistics*, #' 5(1):1-25, 1996. #' #' @seealso [resample_draws()] #' #' @examples #' x <- as_draws_df(example_draws()) #' #' # random weights for justr for demonstration #' w <- runif(ndraws(x), 0, 10) #' #' # use default stratified sampling #' x_rs <- resample_draws(x, weights = w) #' summarise_draws(x_rs, default_summary_measures()) #' #' # use simple random sampling #' x_rs <- resample_draws(x, weights = w, method = "simple") #' summarise_draws(x_rs, default_summary_measures()) #' #' @export resample_draws <- function(x, ...) { UseMethod("resample_draws") } #' @rdname resample_draws #' @export resample_draws.draws <- function(x, weights = NULL, method = "stratified", ndraws = NULL, ...) { ndraws_total <- ndraws(x) assert_numeric(weights, len = ndraws_total, lower = 0, null.ok = TRUE) assert_choice(method, supported_resample_methods()) assert_number(ndraws, null.ok = TRUE, lower = 0) if (is.null(weights)) { weights <- weights(x, normalize = TRUE) if (is.null(weights)) { stop_no_call("No weights are provided and none can ", "be found within the draws object.") } # resampling invalidates stored weights x <- remove_variables(x, ".log_weight") } else { weights <- weights / sum(weights) } if (is.null(ndraws)) { if (grepl("_no_replace$", method)) { stop_no_call("Argument 'ndraws' is required when sampling without replacement.") } ndraws <- length(weights) } method_fun <- paste0(".resample_", method) method_fun <- get(method_fun, asNamespace("posterior")) draw_ids <- method_fun(weights = weights, ndraws = ndraws, ...) subset_draws(x, draw = draw_ids, unique = FALSE) } # simple random resampling with replacement # @return index vector of length 'ndraws' .resample_simple <- function(weights, ndraws, ...) { out <- seq_along(weights) sample(out, ndraws, replace = TRUE, prob = weights) } # internal ---------------------------------------------------------------- # simple random resampling without replacement # @return index vector of length 'ndraws' .resample_simple_no_replace <- function(weights, ndraws, ...) { if (ndraws > length(weights)) { stop_no_call("Argument 'ndraws' must be smaller than the total ", "number of draws in method 'simple_no_replace'.") } out <- seq_along(weights) sample(out, ndraws, replace = FALSE, prob = weights) } # Stratified resampling # Kitagawa, G., Monte Carlo Filter and Smoother for Non-Gaussian # Nonlinear State Space Models, Journal of Computational and # Graphical Statistics, 5(1):1-25, 1996. # @return index vector of length 'ndraws' .resample_stratified <- function(weights, ndraws, ...) { # expected number of repetitions for each original draw w <- ndraws * weights out <- integer(ndraws) c <- 0 j <- 0 for (i in seq_along(w)) { c <- c + w[i] if (c >= 1) { a <- floor(c) c <- c - a out[j + seq_len(a)] <- i j <- j + a } if (j < ndraws && c >= runif(1)) { c <- c - 1 j <- j + 1 out[j] <- i } } out } # Deterministic resampling # Kitagawa, G., Monte Carlo Filter and Smoother for Non-Gaussian # Nonlinear State Space Models, Journal of Computational and # Graphical Statistics, 5(1):1-25, 1996. # @return index vector of length 'ndraws' .resample_deterministic <- function(weights, ndraws, ...) { # expected number of repetitions for each original draw w <- ndraws * weights fw <- floor(w) out <- integer(ndraws) k <- 0 c <- 0.5 for (i in seq_along(w)) { if (w[i] >= 1) { a <- fw[i] w[i] <- w[i] - a out[k + seq_len(a)] <- i k <- k + a; } c <- c + w[i] if (c >= 1) { k <- k + 1 out[k] <- i c <- c - 1 } } out } # names of supported resampling methods supported_resample_methods <- function() { c("simple", "simple_no_replace", "stratified", "deterministic") } posterior/R/rvar-print.R0000755000175000017500000001716214165314655015106 0ustar nileshnilesh#' Print or format a random variable #' #' Printing and formatting methods for [`rvar`]s. #' #' @encoding UTF-8 #' @param x,object (rvar) The [`rvar`] to print. #' @template args-print-digits #' @template args-print-summary #' @template args-print-dots #' @param color (logical) Whether or not to use color when formatting the #' output. If `TRUE`, the [pillar::style_num()] functions may be used to #' produce strings containing control sequences to produce colored output on #' the terminal. #' @param vec.len (nonnegative integer) How many 'first few' elements are #' displayed of each vector. If `NULL`, defaults to #' `getOption("str")$vec.len`, which defaults to 4. #' @param indent.str (string) The indentation string to use. #' @param nest.lev (nonnegative integer) Current nesting level in the recursive #' calls to `str()`. #' @param give.attr (logical) If `TRUE` (default), show attributes as sub #' structures. #' #' @details #' `print()` and `str()` print out [`rvar`] objects by summarizing each element #' in the random variable with either its mean±sd or median±mad, depending on #' the value of `summary`. Both functions use the `format()` implementation for #' [`rvar`] objects under the hood, which returns a character vector in the #' mean±sd or median±mad form. #' #' @return #' For `print()`, an invisible version of the input object. #' #' For `str()`, nothing; i.e. `invisible(NULL)`. #' #' For `format()`, a character vector of the same dimensions as `x` where each #' entry is of the form `"mean±sd"` or `"median±mad"`, depending on the value #' of `summary`. #' #' @examples #' #' set.seed(5678) #' x = rbind( #' cbind(rvar(rnorm(1000, 1)), rvar(rnorm(1000, 2))), #' cbind(rvar(rnorm(1000, 3)), rvar(rnorm(1000, 4))) #' ) #' #' print(x) #' print(x, summary = "median_mad") #' #' str(x) #' #' format(x) #' #' @importFrom utils str lsf.str #' @export print.rvar <- function(x, ..., summary = NULL, digits = 2, color = TRUE) { # \u00b1 = plus/minus sign summary_functions <- get_summary_functions(summary) summary_string <- paste0(paste(summary_functions, collapse = " \u00b1 "), ":") if (color) { summary_string <- pillar::style_subtle(summary_string) } cat0(rvar_type_abbr(x), " ", summary_string, "\n") print(format(x, summary = summary, digits = digits, color = FALSE, pad_right = " "), quote = FALSE) invisible(x) } #' @rdname print.rvar #' @export format.rvar <- function(x, ..., summary = NULL, digits = 2, color = FALSE) { format_rvar_draws(draws_of(x), ..., summary = summary, digits = digits, color = color) } #' @rdname print.rvar #' @export str.rvar <- function( object, ..., summary = NULL, vec.len = NULL, indent.str = paste(rep.int(" ", max(0, nest.lev + 1)), collapse = ".."), nest.lev = 0, give.attr = TRUE ) { str_next <- function(x, ...) { str(x, ..., summary = summary, vec.len = vec.len, indent.str = paste(indent.str, ".."), nest.lev = nest.lev + 1, give.attr = give.attr ) } # HEADER .draws <- draws_of(object) vec.len <- vec.len %||% getOption("str")$vec.len %||% 4 # flatten all the non-draws dimensions for display .dim <- dim(.draws) dim(.draws) <- c(.dim[1], prod(.dim[-1])) if (dim(.draws)[[2]] > vec.len) { .draws <- .draws[, 1:vec.len] ellipsis <- " ..." } else { ellipsis <- "" } cat0(" ", rvar_type_abbr(object), " ", paste(format_rvar_draws(.draws, summary = summary, trim = TRUE), collapse = " "), ellipsis, "\n" ) # ATTRIBUTES # we have to be a bit clever about this to hide internal structure we don't # want people messing with + the fact that some attributes (like dimnames) # are actually attributes of the draws and not the base object. if (give.attr) { .dimnames <- dimnames(object) if (!all(sapply(.dimnames, is.null))) { # only show dimnames if they aren't all NULL cat0(indent.str, paste0('- dimnames(*)=')) str_next(.dimnames, ...) } str_attr <- function(a, base, exclude) { a_names <- names(a) for (i in seq_along(a)) { if (!a_names[[i]] %in% exclude) { cat0(indent.str, paste0('- attr(', base, ', "', a_names[[i]], '")=')) str_next(a[[i]], ...) } } } str_attr(attributes(draws_of(object)), "draws_of(*)", c("names", "dim", "dimnames", "class")) str_attr(attributes(object), "*", c("draws", "names", "dim", "dimnames", "class", "nchains", "cache")) } invisible(NULL) } #' @importFrom pillar pillar_shaft new_pillar_shaft_simple #' @export pillar_shaft.rvar <- function(x, ...) { new_pillar_shaft_simple(format(x, color = TRUE, pad_left = " "), align = "right", ...) } #' @importFrom pillar format_glimpse #' @export format_glimpse.rvar <- function(x, ...) { .dim <- dim(x) if (length(.dim) > 1) { paste0("") } else { format(x, ..., trim = TRUE) } } # type summaries ---------------------------------------------------------- #' @importFrom vctrs vec_ptype_abbr #' @export vec_ptype_abbr.rvar <- function(x, ...) { "rvar" } #' @importFrom vctrs vec_ptype_full #' @export vec_ptype_full.rvar <- function(x, ...) { rvar_type_abbr(x, dim1 = FALSE) } rvar_type_abbr <- function(x, dim1 = TRUE) { .dim <- dim(draws_of(x)) dim_str <- if (dim1) { paste0("[", paste0(.dim[-1], collapse = ","), "]") } else if (length(.dim) > 2) { paste0("[,", paste0(.dim[-c(1,2)], collapse = ","), "]") } else { "" } chain_str <- if (nchains(x) > 1) { paste0(",", nchains(x)) } paste0("rvar<", niterations(x), chain_str, ">", dim_str) } # rvar draws formatting helpers ------------------------------------------------ # formats a draws array for display as individual "variables" (i.e. maintaining # its dimensions except for the dimension representing draws) format_rvar_draws <- function( draws, ..., pad_left = "", pad_right = "", summary = NULL, digits = 2, color = FALSE, trim = FALSE ) { if (prod(dim(draws)) == 0) { # NULL: no draws return(NULL) } summary_functions <- get_summary_functions(summary) summary_dimensions <- seq_len(length(dim(draws)) - 1) + 1 # these will be mean/sd or median/mad depending on `summary` .mean <- apply(draws, summary_dimensions, summary_functions[[1]]) .sd <- apply(draws, summary_dimensions, summary_functions[[2]]) out <- paste0(pad_left, format_mean_sd(.mean, .sd, digits = digits, color = color, trim = trim), pad_right) dim(out) <- dim(draws)[summary_dimensions] dimnames(out) <- dimnames(draws)[summary_dimensions] out } format_mean <- function(x, digits = 2, color = FALSE, trim = FALSE) { format(x, justify = "right", digits = digits, scientific = 2, trim = trim) } format_sd <- function(x, digits = 2, color = FALSE) { # \u00b1 = plus/minus sign sd_string <- paste0("\u00b1 ", format(x, justify = "left", trim = TRUE, digits = digits, scientific = 2)) if (color) { pillar::style_subtle(sd_string) } else { sd_string } } format_mean_sd <- function(.mean, .sd, digits = 2, color = FALSE, trim = FALSE) { format(paste0( format_mean(.mean, digits = digits, color = color, trim = trim), " ", format_sd(.sd, digits = digits, color = color)), justify = if (trim) "none" else "left", trim = trim) } # check that summary is a valid name of the type of summary to do and # return a vector of two elements, where the first is mean or median and the # second is sd or mad get_summary_functions <- function(summary = NULL) { if (is.null(summary)) summary <- getOption("posterior.rvar_summary", "mean_sd") switch(summary, mean_sd = c("mean", "sd"), median_mad = c("median", "mad"), stop_no_call('`summary` must be one of "mean_sd" or "median_mad"') ) } posterior/R/print.R0000644000175000017500000002524714165314655014136 0ustar nileshnilesh#' Print `draws_matrix` objects #' #' Pretty printing for [`draws_matrix`] objects. #' #' @template args-methods-x #' @template args-print-digits #' @template args-print-max_draws #' @template args-print-max_variables #' @template args-methods-reserved #' @template args-print-dots #' @template return-draws #' #' @examples #' x <- as_draws_matrix(example_draws()) #' print(x) #' #' @export print.draws_matrix <- function(x, digits = 2, max_draws = getOption("posterior.max_draws", 10), max_variables = getOption("posterior.max_variables", 8), reserved = FALSE, ...) { max_draws <- as_one_integer(max_draws) max_variables <- as_one_integer(max_variables) reserved <- as_one_logical(reserved) niterations <- niterations(x) nchains <- nchains(x) ndraws <- ndraws(x) nvariables <- nvariables(x) header <- paste0( "# A draws_matrix: ", niterations, " iterations, ", nchains, " chains, and ", nvariables, " variables\n" ) cat(header) sel_draws <- seq_len(min(max_draws, ndraws)) sel_variables <- seq_len(min(max_variables, nvariables)) y <- x if (!reserved) { y <- remove_reserved_variables(y) } y <- .subset_draws( y, draw = sel_draws, variable = sel_variables, reserved = reserved ) class(y) <- "matrix" print(y, digits = digits, ...) more_iterations <- ndraws - max_draws more_variables <- nvariables - max_variables if (more_iterations > 0 || more_variables > 0) { comment <- character(0) if (more_iterations > 0) { comment <- c(comment, paste0(more_iterations, " more draws")) } if (more_variables > 0) { comment <- c(comment, paste0(more_variables, " more variables")) } comment <- paste0(comment, collapse = ", and ") comment <- paste0("# ... with ", comment, "\n") cat(comment) } reserved_variables <- reserved_variables(x) if (!reserved && length(reserved_variables)) { cat0("# ... hidden reserved variables ", comma(reserved_variables), "\n") } invisible(x) } #' Print `draws_array` objects #' #' Pretty printing for [`draws_array`] objects. #' #' @template args-methods-x #' @template args-print-digits #' @template args-print-max_iterations #' @template args-print-max_chains #' @template args-print-max_variables #' @template args-methods-reserved #' @template args-print-dots #' @template return-draws #' #' @examples #' x <- as_draws_array(example_draws()) #' print(x) #' #' @export print.draws_array <- function(x, digits = 2, max_iterations = getOption("posterior.max_iterations", 5), max_chains = getOption("posterior.max_chains", 8), max_variables = getOption("posterior.max_variables", 4), reserved = FALSE, ...) { max_iterations <- as_one_integer(max_iterations) max_chains <- as_one_integer(max_chains) max_variables <- as_one_integer(max_variables) reserved <- as_one_logical(reserved) niterations <- niterations(x) nchains <- nchains(x) nvariables <- nvariables(x) header <- paste0( "# A draws_array: ", niterations, " iterations, ", nchains, " chains, and ", nvariables, " variables\n" ) cat(header) sel_iterations <- seq_len(min(max_iterations, niterations)) sel_chains <- seq_len(min(max_chains, nchains)) sel_variables <- seq_len(min(max_variables, nvariables)) y <- x if (!reserved) { y <- remove_reserved_variables(y) } y <- .subset_draws( y, sel_iterations, sel_chains, sel_variables, reserved = reserved ) class(y) <- "array" print(y, digits = digits, ...) more_iterations <- niterations - max_iterations more_chains <- nchains - max_chains more_variables <- nvariables - max_variables if (more_iterations > 0 || more_chains > 0 || more_variables > 0) { comment <- character(0) if (more_iterations > 0) { comment <- c(comment, paste0(more_iterations, " more iterations")) } if (more_chains > 0) { comment <- c(comment, paste0(more_chains, " more chains")) } if (more_variables > 0) { comment <- c(comment, paste0(more_variables, " more variables")) } comment <- paste0(comment, collapse = ", and ") comment <- paste0("# ... with ", comment, "\n") cat(comment) } reserved_variables <- reserved_variables(x) if (!reserved && length(reserved_variables)) { cat0("# ... hidden reserved variables ", comma(reserved_variables), "\n") } invisible(x) } #' Print `draws_df` objects #' #' Pretty printing for [`draws_df`] objects. #' #' @template args-methods-x #' @template args-print-digits #' @template args-print-max_draws #' @template args-print-max_variables #' @template args-methods-reserved #' @template args-print-dots #' @template return-draws #' #' @examples #' x <- as_draws_df(example_draws()) #' print(x) #' #' @export print.draws_df <- function(x, digits = 2, max_draws = getOption("posterior.max_draws", 10), max_variables = getOption("posterior.max_variables", 8), reserved = FALSE, ...) { max_draws <- as_one_integer(max_draws) max_variables <- as_one_integer(max_variables) reserved <- as_one_logical(reserved) niterations <- niterations(x) nchains <- nchains(x) ndraws <- ndraws(x) nvariables <- nvariables(x, reserved = reserved) header <- paste0( "# A draws_df: ", niterations, " iterations, ", nchains, " chains, and ", nvariables, " variables\n" ) cat(header) sel_draws <- seq_len(min(max_draws, ndraws)) sel_variables <- variables(x, reserved = reserved) seq_variables <- seq_len(min(max_variables, nvariables)) sel_variables <- sel_variables[seq_variables] y <- .subset_draws( x[sel_draws,], variable = sel_variables, reserved = reserved ) if (!reserved) { # reserved df variables can only be removed after subsetting y <- remove_reserved_df_variables(y) } class(y) <- "data.frame" print(y, digits = digits, ...) more_iterations <- ndraws - max_draws more_variables <- nvariables - max_variables if (more_iterations > 0 || more_variables > 0) { comment <- character(0) if (more_iterations > 0) { comment <- c(comment, paste0(more_iterations, " more draws")) } if (more_variables > 0) { comment <- c(comment, paste0(more_variables, " more variables")) } comment <- paste0(comment, collapse = ", and ") comment <- paste0("# ... with ", comment, "\n") cat(comment) } reserved_variables <- all_reserved_variables(x) if (!reserved && length(reserved_variables)) { cat0("# ... hidden reserved variables ", comma(reserved_variables), "\n") } invisible(x) } #' Print `draws_list` objects #' #' Pretty printing for [`draws_list`] objects. #' #' @template args-methods-x #' @template args-print-digits #' @template args-print-max_iterations #' @template args-print-max_chains #' @template args-print-max_variables #' @template args-methods-reserved #' @template args-print-dots #' @template return-draws #' #' @examples #' x <- as_draws_list(example_draws()) #' print(x) #' #' @export print.draws_list <- function(x, digits = 2, max_iterations = getOption("posterior.max_iterations", 10), max_chains = getOption("posterior.max_chains", 2), max_variables = getOption("posterior.max_variables", 4), reserved = FALSE, ...) { max_iterations <- as_one_integer(max_iterations) max_chains <- as_one_integer(max_chains) max_variables <- as_one_integer(max_variables) reserved <- as_one_logical(reserved) niterations <- niterations(x) nchains <- nchains(x) nvariables <- nvariables(x) header <- paste0( "# A draws_list: ", niterations, " iterations, ", nchains, " chains, and ", nvariables, " variables\n" ) cat(header) sel_iterations <- seq_len(min(max_iterations, niterations)) sel_chains <- seq_len(min(max_chains, nchains)) sel_variables <- seq_len(min(max_variables, nvariables)) y <- x if (!reserved) { y <- remove_reserved_variables(y) } y <- .subset_draws( y, sel_iterations, sel_chains, sel_variables, reserved = reserved ) for (i in seq_along(y)) { cat0("\n[chain = ", i, "]\n") print(y[[i]], digits = digits, ...) } more_iterations <- niterations - max_iterations more_chains <- nchains - max_chains more_variables <- nvariables - max_variables if (more_iterations > 0 || more_chains > 0 || more_variables > 0) { comment <- character(0) if (more_iterations > 0) { comment <- c(comment, paste0(more_iterations, " more iterations")) } if (more_chains > 0) { comment <- c(comment, paste0(more_chains, " more chains")) } if (more_variables > 0) { comment <- c(comment, paste0(more_variables, " more variables")) } comment <- paste0(comment, collapse = ", and ") comment <- paste0("# ... with ", comment, "\n") cat(comment) } reserved_variables <- reserved_variables(x) if (!reserved && length(reserved_variables)) { cat0("# ... hidden reserved variables ", comma(reserved_variables), "\n") } invisible(x) } #' Print `draws_rvars` objects #' #' Pretty printing for [`draws_rvars`] objects. #' #' @encoding UTF-8 #' @template args-methods-x #' @template args-print-digits #' @template args-print-max_variables #' @template args-print-summary #' @template args-methods-reserved #' @template args-print-dots #' @template return-draws #' #' @examples #' x <- as_draws_rvars(example_draws()) #' print(x) #' #' @export print.draws_rvars <- function(x, digits = 2, max_variables = getOption("posterior.max_variables", 8), summary = getOption("posterior.rvar_summary", "mean_sd"), reserved = FALSE, ... ) { max_variables <- as_one_integer(max_variables) niterations <- niterations(x) nchains <- nchains(x) nvariables <- nvariables(x) header <- paste0( "# A draws_rvars: ", niterations, " iterations, ", nchains, " chains, and ", nvariables, " variables\n" ) cat(header) sel_variables <- seq_len(min(max_variables, nvariables)) y <- x if (!reserved) { y <- remove_reserved_variables(y) } y <- .subset_draws(y, variable = sel_variables, reserved = reserved) for (i in seq_along(y)) { cat0("$", names(y)[[i]], ": ") print(y[[i]], summary = summary, digits = digits, ...) cat("\n") } more_variables <- nvariables - max_variables if (more_variables > 0) { comment <- paste0(more_variables, " more variables") comment <- paste0("# ... with ", comment, "\n") cat(comment) } reserved_variables <- reserved_variables(x) if (!reserved && length(reserved_variables)) { cat0("# ... hidden reserved variables ", comma(reserved_variables), "\n") } invisible(x) } posterior/R/as_draws.R0000644000175000017500000000706614165314652014601 0ustar nileshnilesh#' Transform to `draws` objects #' #' Try to transform an \R object to a format supported by the \pkg{posterior} #' package. #' #' @name draws #' @family formats #' #' @template args-methods-x #' @template args-methods-dots #' #' @details The class `"draws"` is the parent class of all supported formats, #' which also have their own subclasses of the form `"draws_{format}"` (e.g. #' `"draws_array"`). #' #' @return If possible, a `draws` object in the closest supported format to `x`. #' The formats are linked to in the **See Also** section below. #' #' @examples #' # create some random draws #' x <- matrix(rnorm(30), nrow = 10) #' colnames(x) <- c("a", "b", "c") #' str(x) #' #' # transform to a draws object #' y <- as_draws(x) #' str(y) #' #' # remove the draws classes from the object #' class(y) <- class(y)[-(1:2)] #' str(y) #' NULL #' @rdname draws #' @export as_draws <- function(x, ...) { UseMethod("as_draws") } #' @export as_draws.draws <- function(x, ...) { x } #' @export as_draws.default <- function(x, ...) { # transform an object to the closest supported draws format format <- closest_draws_format(x) fun_name <- paste0("as_", format) if (!has_s3_method(fun_name, class(x))) { # if there is no implementation of as_draws_XXX() for this class, then # we can't call as_draws_XXX() here as it will end up in as_draws_XXX.default() # which will call back to as_draws.default(), creating an infinite loop. So # we call down to .as_draws_XXX() instead. fun_name <- paste0(".", fun_name) } fun <- get(fun_name, asNamespace("posterior")) fun(x, ...) } #' @export as_draws.rvar <- function(x, ...) { as_draws_rvars(x, ...) } # detect the supported format closest to the format of the input closest_draws_format <- function(x) { if (is_draws_matrix_like(x)) { out <- "matrix" } else if (is_draws_array_like(x)) { out <- "array" } else if (is_draws_df_like(x)) { out <- "df" } else if (is_draws_rvars_like(x)) { out <- "rvars" } else if (is_draws_list_like(x)) { out <- "list" } else { stop_no_call("Don't know how to transform an object of class ", "'", class(x)[1L], "' to any supported draws format.") } paste0("draws_", out) } #' @rdname draws #' @export is_draws <- function(x) { inherits(x, "draws") } # check if an object is supported by the posterior package # the name 'check_draws' is already in use for checking # the validity of the 'draw' argument in 'subset' check_draws_object <- function(x) { if (!is_draws(x)) { stop_no_call("The object is not in a format supported by posterior.") } x } # define default variable names # use the 'unique' naming strategy of tibble # @param nvariables number of variables default_variables <- function(nvariables) { paste0("...", seq_len(nvariables)) } # validate draws vectors per variable # @param ... Named arguments containing numeric vector # @return a named list of numeric vectors validate_draws_per_variable <- function(...) { out <- list(...) if (!rlang::is_named(out)) { stop_no_call("All variables must be named.") } if (".nchains" %in% names(out)) { # '.nchains' is an additional argument in chain supporting formats stop_no_call("'.nchains' is not supported for this format.") } out <- lapply(out, as.numeric) ndraws_per_variable <- lengths(out) ndraws <- max(ndraws_per_variable) if (!all(ndraws_per_variable %in% c(1, ndraws))) { stop_no_call("Number of draws per variable needs to be 1 or ", ndraws, ".") } for (i in which(ndraws_per_variable == 1)) { out[[i]] <- rep(out[[i]], ndraws) } out } posterior/R/summarise_draws.R0000644000175000017500000002344114165314652016176 0ustar nileshnilesh#' Summaries of `draws` objects #' #' The `summarise_draws()` (and `summarize_draws()`) methods provide a quick way #' to get a table of summary statistics and diagnostics. These methods will #' convert an object to a `draws` object if it isn't already. For convenience, a #' [summary()][base::summary] method for `draws` and `rvar` objects are also #' provided as an alias for `summarise_draws()` if the input object is a `draws` #' or `rvar` object. #' #' @name draws_summary #' #' @param .x,object (draws) A `draws` object or one coercible to a `draws` object. #' @param ... Name-value pairs of summary or [diagnostic][diagnostics] #' functions. The provided names will be used as the names of the columns in #' the result *unless* the function returns a named vector, in which case the #' latter names are used. The functions can be specified in any format #' supported by [as_function()][rlang::as_function]. See **Examples**. #' @param .args (named list) Optional arguments passed to the summary functions. #' @param .cores (positive integer) The number of cores to use for computing #' summaries for different variables in parallel. Coerced to integer if #' possible, otherwise errors. The default is `.cores = 1`, in which case no #' parallelization is implemented. By default, a socket cluster is used on #' Windows and forks otherwise. #' #' @return #' The `summarise_draws()` methods return a [tibble][tibble::tibble] data frame. #' The first column (`"variable"`) contains the variable names and the remaining #' columns contain summary statistics and diagnostics. #' #' The functions `default_summary_measures()`, `default_convergence_measures()`, #' and `default_mcse_measures()` return character vectors of names of the #' default measures. #' #' @details #' The default summary functions used are the ones specified by #' `default_summary_measures()` and `default_convergence_measures()`: #' #' `default_summary_measures()` #' * [mean()] #' * [median()] #' * [sd()] #' * [mad()] #' * [quantile2()] #' #' `default_convergence_measures()` #' * [rhat()] #' * [ess_bulk()] #' * [ess_tail()] #' #' The `var()` function should not be used to compute variances due #' to its inconsistent behavior with matrices. Instead, please use #' `distributional::variance()`. #' #' @seealso [`diagnostics`] for a list of available diagnostics and links to #' their individual help pages. #' #' @examples #' x <- example_draws("eight_schools") #' class(x) #' str(x) #' #' summarise_draws(x) #' summarise_draws(x, "mean", "median") #' summarise_draws(x, mean, mcse = mcse_mean) #' summarise_draws(x, ~quantile(.x, probs = c(0.4, 0.6))) #' #' # using default_*_meaures() #' summarise_draws(x, default_summary_measures()) #' summarise_draws(x, default_convergence_measures()) #' summarise_draws(x, default_mcse_measures()) #' #' # compute variance of variables #' summarise_draws(x, var = distributional::variance) #' #' # illustrate use of '.args' #' ws <- rexp(ndraws(x)) #' summarise_draws(x, weighted.mean, .args = list(w = ws)) #' NULL #' @rdname draws_summary #' @export summarise_draws <- function(.x, ...) { UseMethod("summarise_draws") } #' @rdname draws_summary #' @export summarize_draws <- summarise_draws #' @export summarise_draws.default <- function(.x, ...) { .x <- as_draws(.x) summarise_draws(.x, ...) } #' @rdname draws_summary #' @export summarise_draws.draws <- function(.x, ..., .args = list(), .cores = 1) { if (ndraws(.x) == 0L) { return(empty_draws_summary()) } .cores <- as_one_integer(.cores) if (.cores <= 0) { stop_no_call("'.cores' must be a positive integer.") } funs <- as.list(c(...)) .args <- as.list(.args) if (length(funs)) { if (is.null(names(funs))) { # ensure names are initialized properly names(funs) <- rep("", length(funs)) } calls <- substitute(list(...))[-1] calls <- ulapply(calls, deparse_pretty) for (i in seq_along(funs)) { fname <- NULL if (is.character(funs[[i]])) { fname <- as_one_character(funs[[i]]) } # label unnamed arguments via their calls if (!nzchar(names(funs)[i])) { if (!is.null(fname)) { names(funs)[i] <- fname } else { names(funs)[i] <- calls[i] } } # get functions passed as strings from the right environments if (!is.null(fname)) { if (exists(fname, envir = caller_env())) { env <- caller_env() } else if (fname %in% getNamespaceExports("posterior")) { env <- asNamespace("posterior") } else { stop_no_call("Cannot find function '", fname, "'.") } } funs[[i]] <- rlang::as_function(funs[[i]], env = env) } } else { # default functions funs <- list( mean = base::mean, median = stats::median, sd = stats::sd, mad = stats::mad, quantile = quantile2, rhat = rhat, ess_bulk = ess_bulk, ess_tail = ess_tail ) } # it is more efficient to repair and transform objects for all variables # at once instead of doing it within the loop for each variable separately .x <- repair_draws(.x) .x <- as_draws_array(.x) variables_x <- variables(.x) if (!length(variables_x)) { warning_no_call( "The draws object contained no variables with unreserved names. ", "No summaries were computed." ) return(tibble::tibble(character())) } if (.cores == 1) { out <- summarise_draws_helper(.x, funs, .args) } else { .x <- .x[, , variables_x] n_vars <- length(variables_x) chunk_size <- ceiling(n_vars / .cores) n_chunks <- ceiling(n_vars / chunk_size) chunk_list <- vector(length = n_chunks, mode = "list") for (i in seq_len(n_chunks)) { if ((chunk_size * (i - 1) + 1) <= n_vars) { chunk <- (chunk_size * (i - 1) + 1):(min(c(chunk_size * i, n_vars))) chunk_list[[i]] <- .x[, , chunk] } } if (checkmate::test_os("windows")) { cl <- parallel::makePSOCKcluster(.cores) on.exit(parallel::stopCluster(cl)) # exporting all these functions seems to be required to # pass GitHub actions checks on Windows parallel::clusterExport( cl, varlist = package_function_names("posterior"), envir = as.environment(asNamespace("posterior")) ) parallel::clusterExport( cl, varlist = package_function_names("checkmate"), envir = as.environment(asNamespace("checkmate")) ) parallel::clusterExport( cl, varlist = package_function_names("rlang"), envir = as.environment(asNamespace("rlang")) ) summary_list <- parallel::parLapply( cl, X = chunk_list, fun = summarise_draws_helper, funs = funs, .args = .args ) } else { summary_list <- parallel::mclapply( X = chunk_list, FUN = summarise_draws_helper, mc.cores = .cores, funs = funs, .args = .args ) } out <- do.call("rbind", summary_list) } out } #' @rdname draws_summary #' @export summary.draws <- function(object, ...) { summarise_draws(object, ...) } #' @rdname draws_summary #' @export summarise_draws.rvar <- function(.x, ...) { x <- draws_rvars(x = .x) names(x) <- deparse_pretty(substitute(.x)) summarise_draws(x, ...) } #' @rdname draws_summary #' @export summary.rvar <- function(object, ...) { .x <- draws_rvars(x = object) names(.x) <- deparse_pretty(substitute(object)) summarise_draws(.x, ...) } #' @rdname draws_summary #' @export default_summary_measures <- function() { c("mean", "median", "sd", "mad", "quantile2") } #' @rdname draws_summary #' @export default_convergence_measures <- function() { c("rhat", "ess_bulk", "ess_tail") } #' @rdname draws_summary #' @export default_mcse_measures <- function() { c("mcse_mean", "mcse_median", "mcse_sd", "mcse_quantile") } class_draws_summary <- function() { c("draws_summary", "tbl_df", "tbl", "data.frame") } # empty draws_summary object # @param dimensions names of dimensions to be added as empty columns empty_draws_summary <- function(dimensions = "variable") { assert_character(dimensions, null.ok = TRUE) out <- tibble::tibble() for (d in dimensions) { out[[d]] <- character(0) } class(out) <- class_draws_summary() out } create_summary_list <- function(x, v, funs, .args) { draws <- drop_dims_or_classes(x[, , v], dims = 3, reset_class = FALSE) args <- c(list(draws), .args) v_summary <- named_list(names(funs)) for (m in names(funs)) { v_summary[[m]] <- do.call(funs[[m]], args) } v_summary } summarise_draws_helper <- function(x, funs, .args) { variables_x <- variables(x) # get length and output names, calculated on the first variable out_1 <- create_summary_list(x, variables_x[1], funs, .args) the_names <- vector(mode = "list", length = length(funs)) for (i in seq_along(out_1)){ if (rlang::is_named(out_1[[i]])) { the_names[[i]] <- names(out_1[[i]]) } else if (length(out_1[[i]]) > 1) { the_names[[i]] <- paste0(names(out_1)[i], ".", c(1:length(out_1[[i]]))) } else { the_names[[i]] <- names(out_1)[i] } } the_names <- unlist(the_names) # Check for naming issues prior do doing lengthy computation if ("variable" %in% the_names) { stop_no_call("Name 'variable' is reserved in 'summarise_draws'.") } # Pre-allocate matrix to store output out <- matrix(NA, nrow = length(variables_x), ncol = length(the_names)) colnames(out) <- the_names out[1, ] <- unlist(out_1) # Do the computation for all remaining variables if (length(variables_x) > 1L) { for (v_ind in 2:length(variables_x)) { out_v <- create_summary_list(x, variables_x[v_ind], funs, .args) out[v_ind, ] <- unlist(out_v) } } out <- tibble::as_tibble(out) out$variable <- variables_x out <- move_to_start(out, "variable") class(out) <- class_draws_summary() out } posterior/R/misc.R0000644000175000017500000001413314165314652013722 0ustar nileshnilesh# initialize a named list # @param names names of the elements # @param values optional values of the elements named_list <- function(names, values = NULL) { if (!is.null(values)) { if (length(values) <= 1L) { values <- replicate(length(names), values) } values <- as.list(values) stopifnot(length(values) == length(names)) } else { values <- vector("list", length(names)) } setNames(values, names) } # unlist lapply output ulapply <- function(X, FUN, ..., recursive = TRUE, use.names = TRUE) { unlist(lapply(X, FUN, ...), recursive, use.names) } seq_rows <- function(x) { seq_len(NROW(x)) } seq_cols <- function(x) { seq_len(NCOL(x)) } # selectively drop one-level dimensions of an array and/or reset object classes drop_dims_or_classes <- function(x, dims = NULL, reset_class = FALSE) { assert_array(x) assert_integerish(dims, null.ok = TRUE) reset_class <- as_one_logical(reset_class) old_dims <- dim(x) # proceed to drop dimensions if the input array has any non-NULL dimensions if (length(old_dims)) { # base::drop if all one-level dimensions are to be dropped non-selectively if (is.null(dims) || setequal(dims, which(old_dims == 1L))) { x <- drop(x) # custom drop if certain one-level dimensions are to be dropped selectively } else { dim(x) <- old_dims[-dims] old_dimnames <- dimnames(x) # if all names of new dimnames are empty strings (""), set them to NULL new_dimnames <- old_dimnames[-dims] if (all(names(new_dimnames) == "")) { names(new_dimnames) <- NULL } dimnames(x) <- new_dimnames } } # optionally, set class to NULL and let R decide appropriate classes if (reset_class) { class(x) <- NULL } x } '%||%' <- function(x, y) { if (is.null(x)) x <- y x } # cat with without separating elements cat0 <- function(..., file = "", fill = FALSE, labels = NULL, append = FALSE) { cat(..., sep = "", file = file, fill = fill, labels = labels, append = append) } # coerce 'x' to a single logical value as_one_logical <- function(x, allow_na = FALSE) { s <- substitute(x) x <- as.logical(x) if (length(x) != 1L || anyNA(x) && !allow_na) { s <- deparse_pretty(s) stop_no_call("Cannot coerce '", s, "' to a single logical value.") } x } # coerce 'x' to a single integer value as_one_integer <- function(x, allow_na = FALSE) { s <- substitute(x) x <- SW(as.integer(x)) if (length(x) != 1L || anyNA(x) && !allow_na) { s <- deparse_pretty(s) stop_no_call("Cannot coerce '", s, "' to a single integer value.") } x } # coerce 'x' to a single numeric value as_one_numeric <- function(x, allow_na = FALSE) { s <- substitute(x) x <- SW(as.numeric(x)) if (length(x) != 1L || anyNA(x) && !allow_na) { s <- deparse_pretty(s) stop_no_call("Cannot coerce '", s, "' to a single numeric value.") } x } # coerce 'x' to a single character string as_one_character <- function(x, allow_na = FALSE) { s <- substitute(x) x <- as.character(x) if (length(x) != 1L || anyNA(x) && !allow_na) { s <- deparse_pretty(s) stop_no_call("Cannot coerce '", s, "' to a single character value.") } x } # check if all inputs are NULL all_null <- function(...) { all(ulapply(list(...), is.null)) } # check if two objects are equal is_equal <- function(x, y, ...) { isTRUE(all.equal(x, y, ...)) } # move elements to the start of a named object move_to_start <- function(x, start) { assert_named(x) start <- intersect(names(x), start) if (!length(start)) { return(x) } out <- x[c(start, setdiff(names(x), start))] class(out) <- class(x) out } # prettily deparse an expression # @return a single character string deparse_pretty <- function(x, max_chars = NULL, max_wsp = 1L) { out <- collapse(deparse(x)) out <- rm_wsp(out, max_wsp) assert_int(max_chars, null.ok = TRUE) if (isTRUE(max_chars > 0L)) { out <- substr(out, 1L, max_chars) } out } # remove NULL elements from a list remove_null <- function(x) { Filter(Negate(is.null), x) } # remove whitespaces from strings rm_wsp <- function(x, max_wsp = 0) { assert_character(x) assert_int(max_wsp) wsp <- collapse(rep(" ", max_wsp)) gsub("[ \t\r\n]+", wsp, x, perl = TRUE) } # collapse a character vector collapse <- function(..., sep = "") { paste(..., sep = sep, collapse = "") } # like 'eval' but parses characters before evaluation eval2 <- function(expr, envir = parent.frame(), ...) { if (is.character(expr)) { expr <- parse(text = expr) } eval(expr, envir, ...) } # wrapper around replicate but without simplifying repl <- function(expr, n) { replicate(n, expr, simplify = FALSE) } isNA <- function(x) { length(x) == 1L && is.na(x) } is_constant <- function(x, tol = .Machine$double.eps) { abs(max(x) - min(x)) < tol } # collapse variables via commas for pretty printing comma <- function(...) { paste0("{", paste0("'", c(...), "'", collapse = ", "), "}") } stop_no_call <- function(...) { stop(..., call. = FALSE) } warning_no_call <- function(...) { warning(..., call. = FALSE) } SW <- function(expr) { base::suppressWarnings(expr) } # escape all special characters in character strings escape_all <- function(x) { specials <- c(".", "*", "+", "?", "^", "$", "(", ")", "[", "]", "|") for (s in specials) { x <- gsub(s, paste0("\\", s), x, fixed = TRUE) } x } # numerically stable version of log(sum(exp(x))) log_sum_exp <- function(x) { max <- max(x) sum <- sum(exp(x - max)) max + log(sum) } # simple version of destructuring assignment `%<-%` <- function(vars, values, envir = parent.frame()) { vars <- as.character(substitute(vars)[-1]) for (i in seq_along(vars)) { assign(vars[[i]], values[[i]], envir = envir) } invisible(NULL) } # get names of all the functions of a package package_function_names <- function(package) { unclass(utils::lsf.str(envir = asNamespace(package), all = TRUE)) } # return true if there is an S3 method for the # given function and class signature has_s3_method <- function(f, signature) { for (class in signature) { if (!is.null(utils::getS3method(f, class, optional = TRUE))) { return(TRUE) } } FALSE } posterior/R/rvar-apply.R0000755000175000017500000000752414165314652015075 0ustar nileshnilesh#' Random variable resulting from a function applied over margins of an array or random variable #' #' Returns an [`rvar`] obtained by applying a function to margins of an array or [`rvar`]. #' Acts like `apply()`, except that the function supplied (`.f`) should return an [`rvar`], #' and the final result is always an [`rvar`]. #' #' @param .x An array or an [`rvar`]. #' @param .margin (multiple options) The subscripts which the function will be applied over: #' * An integer vector. E.g., for a matrix `1` indicates rows, `2` indicates #' columns, `c(1, 2)` indicates rows and columns. #' * A character vector of dimension names if `.x` has named dimensions. #' @param .f (function) The function to be applied. The function `.f` must #' return an [`rvar`] and the dimensions of the result of `.f` applied to each #' margin of `.x` must be able to be broadcasted to a common shape (otherwise #' the resulting [`rvar`] cannot be simplified). See **Details**. #' @param ... Optional arguments passed to `.f`. #' #' @details #' #' This function acts much like `apply()`, except that the function passed to it (`.f`) #' must return [`rvar`]s, and the result is simplified into an [`rvar`]. Unlike #' `apply()`, it also keeps the dimensions of the returned values along each margin, #' rather than simplifying each margin to a vector, and if the results of `.f` do #' not all have the same dimensions, it applies the [`rvar`] broadcasting rules to #' bind results together rather than using vector recycling. #' #' If you wish to apply functions over [`rvar`]s where the result is not intended to #' be simplified into an [`rvar`], you can use the standard `apply()`, `lapply()`, #' `sapply()`, or `vapply()` functions. #' #' @seealso [as_rvar()] to convert objects to `rvar`s. See [rdo()], [rfun()], and #' [rvar_rng()] for higher-level interfaces for creating `rvar`s. #' #' @return An [`rvar`]. #' #' If the result of each call to `.f` returns an [`rvar`] of dimension `d` after #' being broadcast to a common shape, then `rvar_apply()` returns an [`rvar`] of #' dimension `c(d, dim(.x)[.margin])`. If the last dimension of the result would #' be `1`, it is dropped (other dimensions equal to `1` are retained). If `d` is #' `0`, the result has length `0` but not necessarily the 'correct' dimension. #' #' @examples #' #' set.seed(3456) #' x <- rvar_rng(rnorm, 24, mean = 1:24) #' dim(x) <- c(2,3,4) #' #' # we can find the distributions of marginal means of the above array #' # using rvar_mean along with rvar_apply #' rvar_apply(x, 1, rvar_mean) #' rvar_apply(x, 2:3, rvar_mean) #' #' @export rvar_apply <- function(.x, .margin, .f, ...) { # this should return a list of rvars rvar_list <- apply(.x, .margin, .f, ...) if (!is.list(rvar_list) || !all(sapply(rvar_list, is_rvar))) { stop_no_call("The function passed to rvar_apply() must return rvars.") } # get the dimensions of the results in each cell cell_dim <- dim(rvar_list[[1]]) # get the dimensions from the original array that are being kept marginal_dim <- dim(rvar_list) %||% length(rvar_list) # bind the output into an rvar along the first dimension (which the # marginal dimensions flattened into a single dim) out <- rvar_list[[1]] dim(out) <- c(1, dim(out)) # process remaining rvars in succession, binding them to the output for (i in seq_along(rvar_list)[-1]) { rvar_i <- rvar_list[[i]] dim(rvar_i) <- c(1, dim(rvar_i)) out <- broadcast_and_bind_rvars(out, rvar_i, 1) } if (length(out) > 0) { # restore the shape of the marginal dimensions dim(out) <- c(marginal_dim, dim(out)[-1]) # if the last dimension is 1, drop it n_dim <- length(dim(out)) if (dim(out)[[n_dim]] == 1) { dim(out) <- dim(out)[-n_dim] } # restore marginal dimnames marginal_dim_i <- seq_along(marginal_dim) out <- copy_dimnames(.x, .margin, out, marginal_dim_i) } out } posterior/R/rvar-math.R0000755000175000017500000001513114165314652014672 0ustar nileshnilesh# Ops: math operators --------------------------------------------------- #' @export Ops.rvar <- function(e1, e2) { e1 <- as_rvar(e1) f <- get(.Generic) if (missing(e2)) { # unary operators return(rvar_apply_vec_fun(f, e1)) } c(e1, e2) %<-% conform_rvar_nchains(list(as_rvar(e1), as_rvar(e2))) draws_x <- draws_of(e1) draws_y <- draws_of(e2) # broadcast draws to common dimension new_dim <- dim2_common(dim(draws_x), dim(draws_y)) # Most of the time we don't broadcast scalars (constant rvars of length 1). # With broadcast_scalars = FALSE broadcast_array will return a vector (no dims) # version of the input, which works unless *both* x and y are constants # (because then the correct output shape is lost; in this case we do need to # broadcast both x and y in case their dimensions are not equal; e.g. if x is # 1x1 and y is 1x1x1x1 we must broadcast both to 1x1x1x1) broadcast_scalars = length(draws_x) == 1 && length(draws_y) == 1 draws_x <- broadcast_array(draws_x, new_dim, broadcast_scalars = broadcast_scalars) draws_y <- broadcast_array(draws_y, new_dim, broadcast_scalars = broadcast_scalars) new_rvar(f(draws_x, draws_y), .nchains = nchains(e1)) } #' @export Math.rvar <- function(x, ...) { f <- get(.Generic) if (.Generic %in% c("cumsum", "cumprod", "cummax", "cummin")) { # cumulative functions need to be handled differently # from other functions in this generic new_rvar(t(apply(draws_of(x), 1, f)), .nchains = nchains(x)) } else { new_rvar(f(draws_of(x), ...), .nchains = nchains(x)) } } # matrix stuff --------------------------------------------------- #' Matrix multiplication of random variables #' #' Matrix multiplication of random variables. #' #' @name rvar-matmult #' @aliases %**% #' @param x (multiple options) The object to be postmultiplied by `y`: #' * An [`rvar`] #' * A [`numeric`] vector or matrix #' * A [`logical`] vector or matrix #' #' If a vector is used, it is treated as a *row* vector. #' #' @param y (multiple options) The object to be premultiplied by `x`: #' * An [`rvar`] #' * A [`numeric`] vector or matrix #' * A [`logical`] vector or matrix #' #' If a vector is used, it is treated as a *column* vector. #' #' @details #' If `x` or `y` are vectors, they are converted into matrices prior to multiplication, with `x` #' converted to a row vector and `y` to a column vector. Numerics and logicals can be multiplied #' by [`rvar`]s and are broadcasted across all draws of the [`rvar`] argument. Tensor multiplication #' is used to efficiently multiply matrices across draws, so if either `x` or `y` is an [`rvar`], #' `x %**% y` will be much faster than `rdo(x %*% y)`. #' #' Because [`rvar`] is an S3 class and S3 classes cannot properly override `%*%`, [`rvar`]s use #' `%**%` for matrix multiplication. #' #' @return An [`rvar`] representing the matrix product of `x` and `y`. #' #' @examples #' #' # d has mu (mean vector of length 3) and Sigma (3x3 covariance matrix) #' d <- as_draws_rvars(example_draws("multi_normal")) #' d$Sigma #' #' # trivial example: multiplication by a non-random matrix #' d$Sigma %**% diag(1:3) #' #' # Decompose Sigma into R s.t. R'R = Sigma ... #' R <- chol(d$Sigma) #' # ... and recreate Sigma using matrix multiplication #' t(R) %**% R #' #' @importFrom tensorA mul.tensor as.tensor #' @export `%**%` <- function(x, y) { # Fast version of rdo(x %*% y) # convert both objects into rvars if they aren't already (this will ensure # we have a 3d draws array for each variable) x <- as_rvar(x) y <- as_rvar(y) # ensure everything is a matrix by adding dimensions as necessary to make `x` # a row vector and `y` a column vector ndim_x <- length(dim(x)) if (ndim_x == 1) { dim(x) <- c(1, dim(x)) } else if (ndim_x != 2) { stop_no_call("First argument (`x`) is not a vector or matrix, cannot matrix-multiply") } ndim_y <- length(dim(y)) if (ndim_y == 1) { dim(y) <- c(dim(y), 1) } else if (ndim_y != 2) { stop_no_call("Second argument (`y`) is not a vector or matrix, cannot matrix-multiply") } # conform the draws dimension in both variables c(x, y) %<-% conform_rvar_ndraws_nchains(list(x, y)) # drop the names of the dimensions (mul.tensor gets uppity if dimension names # are duplicated, but we don't care about that) x_tensor <- as.tensor(draws_of(x)) y_tensor <- as.tensor(draws_of(y)) names(dim(x_tensor)) <- NULL names(dim(y_tensor)) <- NULL # do a tensor multiplication equivalent of the requested matrix multiplication result <- unclass(mul.tensor(x_tensor, 3, y_tensor, 2, by = 1)) # move draws dimension back to the front result <- aperm(result, c(3,1,2)) # restore dimension names (as.tensor adds dummy names to dimensions) names(dim(result)) <- NULL result <- copy_dimnames(draws_of(x), 1:2, result, 1:2) result <- copy_dimnames(draws_of(y), 3, result, 3) new_rvar(result, .nchains = nchains(x)) } #' Cholesky decomposition of random matrix #' #' Cholesky decomposition of an [`rvar`] containing a matrix. #' #' @param x (rvar) A 2-dimensional [`rvar`]. #' @param ... Additional parameters passed on to `chol.tensor()` #' #' @return An [`rvar`] containing the upper triangular factor of the Cholesky #' decomposition, i.e., the matrix \eqn{R} such that \eqn{R'R = x}. #' #' @importFrom tensorA chol.tensor as.tensor #' @export chol.rvar <- function(x, ...) { # ensure x is a matrix if (length(dim(x)) != 2) { stop_no_call("`x` must be a random matrix") } # must re-order draws dimension to the end, as chol.tensor expects it there x_tensor <- as.tensor(aperm(draws_of(x), c(2,3,1))) # do the cholesky decomp result <- unclass(chol.tensor(x_tensor, 1, 2, ...)) # move draws dimension back to the front result <- aperm(result, c(3,1,2)) # drop dimension names (chol.tensor screws them around) names(dim(result)) <- NULL new_rvar(result, .nchains = nchains(x)) } # transpose and permutation ----------------------------------------------- #' @export t.rvar = function(x) { .draws = draws_of(x) ndim = length(dim(.draws)) if (length(x) != 0 && ndim == 2) { # vector .dimnames = dimnames(.draws) dim(.draws) = c(dim(.draws)[1], 1, dim(.draws)[2]) dimnames(.draws) = c(.dimnames[1], list(NULL), .dimnames[2]) result <- new_rvar(.draws, .nchains = nchains(x)) } else if (ndim == 3) { .draws <- aperm(.draws, c(1, 3, 2)) result <- new_rvar(.draws, .nchains = nchains(x)) } else { stop_no_call("argument is not a random vector or matrix") } result } #' @export aperm.rvar = function(a, perm, ...) { .draws <- aperm(draws_of(a), c(1, perm + 1), ...) new_rvar(.draws, .nchains = nchains(a)) } posterior/R/rvar-bind.R0000755000175000017500000001231414165314655014660 0ustar nileshnilesh# concatenation and binding ---------------------------------------------------- #' @export c.rvar <- function(...) { if (!is_rvar(vctrs::vec_ptype_common(...))) { # if the common type of the arguments is not an rvar, fall back to the # vctrs implementation of c() return(vctrs::vec_c(...)) } args <- list(...) out <- make_1d(args[[1]], names(args)[[1]]) # process remaining args in succession, binding them to the output for (i in seq_along(args)[-1]) { arg_name <- names(args)[[i]] arg <- make_1d(as_rvar(args[[i]]), arg_name) out <- broadcast_and_bind_rvars(out, arg) } out } #' @export rbind.rvar <- function(...) { # not sure why deparse.level is not passed here correctly... deparse.level <- rlang::caller_env()$deparse.level %||% 1 bind_rvars(list(...), as.list(substitute(list(...))[-1]), deparse.level) } #' @export cbind.rvar <- function(...) { # not sure why deparse.level is not passed here correctly... deparse.level <- rlang::caller_env()$deparse.level %||% 1 bind_rvars(list(...), as.list(substitute(list(...))[-1]), deparse.level, axis = 2) } #' bind a list of objects together, as in cbind or rbind (depending on `axis`), #' converting to rvars as needed #' @noRd bind_rvars <- function(args, arg_exprs, deparse.level = 1, axis = 1) { if (any(sapply(args, is.data.frame))) { # if there is a data frame in args, we should just make the first arg # into a data frame and then use the data frame bind implementation # data frames always deparse at level 2 (expressions get named) args <- deparse_names(args, arg_exprs, deparse.level = 2) args[[1]] <- as.data.frame(make_at_least_2d(args[[1]], axis, names(args)[[1]])) bind <- if (axis == 1) rbind else cbind return(do.call(bind, args)) } args <- deparse_names(args, arg_exprs, deparse.level) out <- make_at_least_2d(as_rvar(args[[1]]), axis, names(args)[[1]]) # process remaining args in succession, binding them to the output for (i in seq_along(args)[-1]) { arg_name <- names(args)[[i]] arg <- make_at_least_2d(as_rvar(args[[i]]), axis, arg_name) out <- broadcast_and_bind_rvars(out, arg, axis) } out } # helpers: concatenation and binding -------------------------------------- #' broadcast two rvars to compatible dimensions and bind along the `axis` dimension #' @noRd broadcast_and_bind_rvars <- function(x, y, axis = 1) { if (!length(x)) return(y) if (!length(y)) return(x) draws_axis <- axis + 1 # because first dim is draws # conform nchains # (don't need to do draws here since that's part of the broadcast below) c(x, y) %<-% conform_rvar_nchains(list(x, y)) # broadcast each array to the desired dimensions # (except along the axis we are binding along) draws_x <- draws_of(x) draws_y <- draws_of(y) new_dim <- dim2_common(dim(draws_x), dim(draws_y)) new_dim[draws_axis] <- dim(draws_x)[draws_axis] draws_x <- broadcast_array(draws_x, new_dim) new_dim[draws_axis] <- dim(draws_y)[draws_axis] draws_y <- broadcast_array(draws_y, new_dim) # bind along desired axis result <- new_rvar(abind(draws_x, draws_y, along = draws_axis), .nchains = nchains(x)) } #' Deparse argument names roughly following the rules of the deparse.level #' argument to cbind / rbind #' @importFrom rlang as_name as_label #' @noRd deparse_names <- function(args, arg_exprs, deparse.level) { # give arguments names if needed if (deparse.level > 0) { if (is.null(names(args))) { names(args) <- rep("", length(args)) } for (i in seq_along(arg_exprs)) { arg_name <- names(args)[[i]] arg_expr <- arg_exprs[[i]] if (!isTRUE(nzchar(arg_name))) { if (deparse.level == 1 && is.name(arg_expr)) { names(args)[[i]] <- as_name(arg_expr) } else if (deparse.level > 1) { names(args)[[i]] <- as_label(arg_expr) } } } if (all(names(args) == "")) { names(args) = NULL } } args } #' restructure a variable for concatenation with `c()` by ensuring that `x` has #' only 1 dimension and merging the high-level `name` with names in `x` #' @noRd make_1d <- function(x, name) { if (length(dim(x)) > 1) { dim(x) <- length(x) } if (isTRUE(nzchar(name))) { # name provided, merge with names in the vector if (length(x) > 1) { if (!length(names(x))) names(x) <- rep("", length(x)) empty_names <- !nzchar(names(x)) names(x)[empty_names] <- seq_along(x)[empty_names] names(x)[!empty_names] <- paste0(".", names(x)[!empty_names]) names(x) <- paste0(name, names(x)) } else { names(x) <- name } } x } #' restructure a variable for binding along `axis` with rbind (axis = 1) or #' cbind (axis = 2). Ensures that `x` has at least two dimensions (filling #' setting extra dimension `axis` to 1 if needed) and if `x` is vector-like #' (is 1-dimensional), sets the name of the newly-added dimension to `axis_name` #' @noRd make_at_least_2d <- function(x, axis, axis_name) { if (length(dim(x)) <= 1) { # input is a vector, turn it into a matrix if (axis == 1) { # rbind dim(x) = c(1, length(x)) } else { # cbind dim(x) = c(length(x), 1) } if (isTRUE(nchar(axis_name) > 0)) { dimnames(x)[[axis]] <- axis_name } } x } posterior/R/split_chains.R0000644000175000017500000000261014165314652015444 0ustar nileshnilesh#' Split Chains #' #' Split chains by halving the number of iterations per chain and doubling the #' number of chains. #' #' @template args-methods-x #' @template args-methods-dots #' @template return-draws #' #' @examples #' x <- example_draws() #' niterations(x) #' nchains(x) #' #' x <- split_chains(x) #' niterations(x) #' nchains(x) #' #' @export split_chains <- function(x, ...) { UseMethod("split_chains") } #' @export split_chains.draws <- function(x, ...) { niter <- niterations(x) if (niter %% 2 != 0) { warning_no_call( "Number of iterations is not even. Removing the last iteration ", "in order to split chains into two parts of equal length." ) niter <- niter - 1 } iter_first_half <- seq_len(floor(niter / 2)) iter_second_half <- seq_len(niter)[-iter_first_half] x_first_half <- .subset_draws(x, iteration = iter_first_half) x_second_half <- .subset_draws(x, iteration = iter_second_half) bind_draws(x_first_half, x_second_half, along = "chain") } # internal ---------------------------------------------------------------- # split chains for use in convergence diagnostics # @param x matrix of draws (iterations x chains) # @return matrix of draws with split chains .split_chains <- function(x) { x <- as.matrix(x) niter <- NROW(x) if (niter == 1L) { return(x) } half <- niter / 2 cbind(x[1:floor(half), ], x[ceiling(half + 1):niter, ]) } posterior/R/sysdata.rda0000644000175000017500000017725513636365323015026 0ustar nileshnileshBZh91AY&SY)ew;?QUEעخ"WAAҖ}R*5oҟA=ht13}wմO}]oww{{-}4owwMsjW[.wsmn5ۻmmtιI뛜nS[.ZnΙLӥ[geq͝KWf[r.cwnN\ۺZֶ;7Qwus4m(lܤxmVvnU[kv;rt ֻGv6֎pqk-kw]kwrFx}nwkwWyؕn׼^oj}׽+wk9{+w{ɯU]/vZ>mQx4^>_}}n}}vb{:v}.W{V9}E}U_lY_fwvQ{^̺T0&`b &0LL#Li~d41 01 M4`&0T L&1a2`LJ~ѓ24 &#4hdhi ѐžUSf@4#M2b` 0 LM122&F)ɦ# ?M zbPjx&4 0F 4 xLL)2!2'IC!OiɄdѪUud`hi -J*A 腠J6=cٵ.~ Ch" Y>zm⌜F,h1.b *f e:/ʃV:euwI4y4,\ĵݳ6{hq Uaqz~?[FvdtCBB|3CZڭ9ߞbȑ!v|lqOeo[s;)`hŃS"=.|v>o'c Hً۝8 .bΏDSd@%'1oHK<ɩ1E6I(Gl `(ư};`(`jѣp}-sV#b?շ3P(x DRQ@Fsɦ֭L0 Ӛ4!\fP(6'?[.D:){mXoI1 !N'I8,#Rwa WqvbҴJR,QmhFR 1ΎnsÅ?lKlH OZsG^VܣZ⢬xfdkg=eA}IEQv!kfi5’I<*`kdzO-z7uc7f0ì'$ד'^Sܜ7ekmk}; ߌljV,oƘ(}Zλߧ2oU6FsW4h+Bb\2\%RyZeȰb +ɒggJ7o.?Ϸ 5cpDjnǬ9^t@#oZOmToVyI;qB#R ZCKsi찡x> .V|d/_9h[b _x55g߾R6r!gW)`#Jm[}) {Ha Big` c-}GlG ?;r̘y軉YK&rj"åj0$ Q`V.:Iv%1ъ&eĸx3M~3HN!:ejvl_72gZv덙A Ւ;#gA(n-6GeeחvSd[# z\.~aeK\#8# 㽅<#ma3.YYG(xA_6V@ELL%L.J 0)4Cf7:?{4-պH^En:ԣ%KHA@-(to,tU ?0~cufg SOLqZkU}8'0+|XyTjK_K>Z(G*גʫdܹ{Q8`3Kq}1n.D P@*7H\(8 d& rW$3 xdR|'#:0\̪g~I /.4<!KMuq+s-){-4+VbIy!lfwB19{^*9Z-?2YoL&_:jWI RO_r%TgPwH9X>xn>4p.c -zE݃j #i$; oJ+Y2^vbO$qNUzX7"~ŽFٹgڂ.Z2Yn uyupt6@uM+V夙E[Xe V SP̬ a -h@Vg~\4W]O/};6ǵ!8$updppR^PJj$l"+݊v2]$Vn>Z5L e+$;DwG[My!S29d-*La6DnN0ݱ=;C\-^NeΜe8!ಝO KaTyѪwv}}Wh -~]ae)񕬂Rd<~O)/ :?HdY4$~rE(˖׫|@7Ka6S8Ω&5AʹHT`pe;XjǪJ|vk#kXԑ\$7!pv4M"R`4P@8n0h-#>%@DlYұY ,$G丣p;i&&e_v#cH}4;=h⢟>SȏK7o=Z78zƂ)e(H\dojG*ֿ_jvG|>^MxeɊ;Egv>Y o#hJ3-ɇJ"F ۲M$w&[l`jP S=^rҎ^"IA?PkMy$xfGGD?5H,1F' x}DEZ5Y **_n8ō<Ԧҗ5 ^pgw_:4N-pm) eqbU\Đb_<@]q4w2`"1R274e_A;譚]5dҰH~q *IJ\r{^_Aj{YF%琦_M*hYq]^TM~ʓRq_R`Q+!r鯝z+ # w t@jut,0aġK O~b,}aTt)}+']f ŅފJ>)VBn=R*ܚJbxҷkꦹ$ٽ fgzWWvsE/fd" `H~PU\C):a[wZwpKRf"ivLQ]KZ]5y6p΀EbCRPCKA''Iۓ6~i>.kD-y1OP@E.AXsh6ӂW(43kx၍3A+ r>ւ=RjaJFبQ?3';qd-L >ֵb[Ijė:$ *봂~0lvG2r`)i?mp-f.5:$aElUK>< #Ev[ÿʫ !#QXhlSI/К8sfA˻R}-6ZԊFqRzQCG(/55bk/V42R5 dPO˟#)EjDgl}_ sEQ^W=싗߆#β&̆YxH"t&s\.1f &t'5yU#PFL~:`"fجhQNq@,h&/P\BLM˸KAWZhJg6*Õ5 eijS{m*clZЫ@"y† E;JOȰDZE8K( |>E_(k@iOeI<{媤 aP G53N̪(6bxo8Niԛ\=o4 cDN}Sn͵,߶.AOvL9fs36ڻOVy%dO2mLbSdD'i(\`[xr!܀U~=aP: s#3aرžDq*2M|(Ehu V8VӔ@̜4T,qgg,E&,Ԛ VܛMnƢʍRJLtôExd/k;tHLeG+^fԹ[9N.-L{6Ɔm/ + b9sCsdR|+pz+GgbmWb\r Q.͏Ye]3bdpC,M2)|tVvYaz? `Ch * w˄b% O&̣{I򟫜}]RfkD% Hʰ΢9}HlSkc>jNS I< ba#>^ciTEb7\Sd{! W[IJ\Hd ÑM幮?пA累4F$y$]6Xoʬ\~kjo{pZ\(mk KŶcHD*T>YAcTvkk&;3gw`3ۜq 50u*PNqr(TIPEϧV!g$1U*Ą--ދVS5+i[7O0ʍW~(GgnT}yeQ| {@IϴD")wg5@UtL$x8 D N)M#v*n%`ň|* H,h?c3v2A$w4~Sb&.DAxH2XτM ]Y(;/U8U* $kF ~)%K:/[؝iV\8H+WӎWj;i1}>*~8BOX6Ojkeܩb{;?o+(\pENT<<|65!=QbC.^X>FwR&ȵKۢftHi!i[R|dbOC\ݷ3O`$ m W. l(nՖ7T=0Ƅkqð4uw7d4QA#t5f{8 ]')MomI[hlT*Vg \U,Gܕjp(#w_@lWS#CW^5ΐk"lLF(B;L!sF?643‘W9ɚ6AU[>?_e@r o,a :^j3Vjna\!3q93yg4=.ݫĐots3:]\.֥~]E Z &=8'"s S6;Vv =ꢎ-c. Wh=Hv C%3 /4&1ՌC;h,g}aYB HFUPs&WE VC?NZ SDQN6Z6yV!8|IN3 骱XuM3}#~hr sMmO, au9XDiSkb%;JcG8Cy.W(l*!H]L*+"+ (aY^M|j}PIHcf.m_X'M2ze H2"~c5ɋQ^ˇ]kxz(P`d.̳)y0H61.՛Ԣ^>"6堠-V DB !^/Ĩ9]Ƣ4\޷-@)-Z$>@= SzBsAW>z.H^CQ@<n2dW{^\)8kW)PWBMR#`{`yBLwd2fE+G8(5gq.-5²& >V`3{dLT7u%KXKDɄI?5ѩx{q&RpD 6SfUV$xq\~$;X/'07T"Ɋh 4t(ihkˆ^,[&s'”)o u(dcD⡥SՋ(NG*gZHŪX0tLI݄߫RTδ55 p=KQVc9 CFS 'Cccsѧj%4zw:)A%RA *X.S^Lsa0PhJ-%?gh=;H3T |79Z4^ -)hBJ5X+̨5Դm[<~6x^v* xz+4@P9嚱&oL=2vm ԛ-usԼ\ƌ_kd] ;Śdw (iy읜½M/̶/CS# %-A, srO=tm&X4dAqx*-0M&ZAW>,  FciP/sl#c`Ѐ:ʠX2" #is8PCY٣NC$D""=u$X$xô8&^)Lݭֳ̰ Q/kԻ1a"*ͩQlseRqRjB=M!0wu?9L%g 'paՑin55RJTx,&pv5+h[ 2I./C`2m#_\5:f@^SqmEċZՇjsgPzY,>H Kn((BmI3:Mt_:7=b~k1Y B󉁴|Im1@C_C5򦟱^N!7?p g{f*b巧-lNDžx&ͪ,Wׄ|B'!@X!0H#O) G0`pxv> WZu {F~I=+gǫFSM404r90I%i)kl+ "B8+ϟu "X&/[w=s}3|Lذ`Qu l*_dwgU<4AwMC&Pff, HM=al0vNϓp BhFZ(4@[VI@A On6UKyqI*"Q Ѐ0P/`En ^ϊxs5|Q@`% X#Q7~ [w߂L3(ضݥEȒ ]ΨsP!*Ngz"7dGs(X>OdMe&&EipD}zD.6jG}s(Yz PM걉z)|-:B/ ˏw?&;w\Z}3>[f N#KJq&7wl@`~d+/ t|SM:ylG`(9V7Yz}p*z^7qljF3(k@ӈW?)>dݖ›Qo[+%O'HWTWI(vC'*Aq!K-" zC(+۵="^xC@GZtQ[7nfCXsc`@7'!}|Zs7aENQfP3? jC@t+mlvhW0]<z/jnfǃ`}#W3aǔJhеy?! 0ܴ6l M\ |H!<%)˜m80o`c86x@* pb$;tލ,$' ;.?kh]r&[ζPPq5 csГQCٳl cvzeաɗϋHE8 /jRU,I~ba&?+4=Ͳь#!}j%C)('ge lU4CĜ?m+.w+aAIDm!RE4LFF׽ h`|0EA ޮd rbW# NShj"  i@?ZZw! >r?&da,*sIfRqI4d'ޭ=>d21N^lw'O>xf"XM\XޒyfOXow-E7b+ |V5񼥐OZ X lyTgW|@=C]a| 50b;픴6(I=UP |Lw)U,kuZg4W'xbаEo{:|/N8ͳ (=&4{]] *Qgx/&PNQ`ce<^Y;40϶XYO09vy{8kP,>23:zب &8v' ՌW1 nk6-篓 ''54 %H>7Q@ Ep$ڐǂ${\-UT:mr$cTUJm NW88kKQk U (]%ȍ% Ԗ 8" R΁ v^j'nql`R}v ;S&]{9"dkz_{O[Q-I+QrQ~!=-=o?vn~E q5dm̛(jq?Qι;\QpN440#\[k"=ԈߞC80rSlj M JkEw|(ETm7h2޾ڢA`P G H3)rfLA^C=5 &ΑHG4'Q8N;+I»tϟϬ4;7ݗ:v ɋIHzbb5 Я1o $<\5 qvkZshQfSf9) ̍t:'0Je4tUFWSZ/Z{eq-1>@Wڀ^tp-Sنzb2hObVצ.Ò9(3\YFOx<̫UfHًEB?w{x.a>:3:;s^s?M:q~g U?5G)!A濌1Lj[YgneV y학KI\\}۷c-)7YiE:t%<8RW?ҝ) bqYAٵIHN 2ūø JJlРOcD<Dpfd۽_-!;f_]4!Q 5E&'rHvdiZce"C!w9aP+R>^=8h+9Ef(a^+ {7BC 2׼!T;J|1Yn]Nc[ҢF..U*1g'lSڟ0^`?빕 pG(2_(G`5UvQP+9C𥘅GlunB=n>mbwKKYKK-w(54iw8R& kגb_O"*cCRQh@/5E繓RK8@$x;!G:Qc$vuE9[n Ń;իw3 }DbxP PJ:⹶ozTFK*y|? G=ibRu}(*`Xr3^Nyd!dd O@~LG| \@cլ)hn9c\1>z͒(vA3L(J@_o?N m ӧ" MXl4C&jO Ө):&MC(JcOu}!=Ze/B_~5ԡP\ B `AX+jC]P[7g7;/_>Ok},J%6crYhĔH RܝQ`K@\!dM?s%4BwgR&C^|1oxpK>TtJe-tSImW459KivNOUV3Ա/anMw(VmC$L݁C"r$s!~ 57q\}NS\e|eYwnzbV;(0ZmQ;FC?>5M^AAjN f 9V R'O}PuHqȿo67q;ϭ)3o˛4i*?c gLS>nJ00Dݱ ;Qvϡi5v^GE1i5`XJ5dBkخJwXe7Zx|aug͖<}O|.r#_-=%\Eٛ*ξ9و;|˰/M/3L08|<,0P}hnr,56s-SV#+NS/0].!\d&WnU6L&{v xMOUZ NwN,"X+79>F5PBO#c+VH3~갎%NQRR)`F#T%MjL9x[7x/;Xs_'eo%щfko*_CV{crȩUzv">[2rw{ax`s?y^ջKQ־\ QeF=&Ym>qhAayxwrmGvO>'zp~1Q0\me4:b&*&d??|n5ce,rJ)K̷EHnޭg$f҆&2QםFo|`ncΘߍ=wkEfm|bCD1^U%Ӭn\2~gslQbNn%@z@;O],vhdtUԲ|eȵc<:E,Pag&]$?"yrOsSKƞll3xXLCgt# #;hw\g!~ZC>7 N7ۖAUc&v՚?c^9ͯ-X EK"qN24RlrSij}Z,T6AY-ˬ\d^f y$<9 . Gp㳔'a雺G Կ;oISZB[cߎ(Lj{.lʈK8~8FJcɯLvHUhVj5޷{MQ]իpw_BWW,nދ]=(j}~r-+H/ϫs;qA|-fLT[v2a L8Iъ2,O`:dyؾwtTV~}a6LǢugа/3r^M2s[U> =bwuZ'=2ܑ%Cʆw}8;$6٨iV(@.3{hh]^əKydN%Ӟy9#}SY9o]{T~%3S-S-cn%Kҕ & NCkO&Ⱥ6Q8| ~]V<ʂ~ "TScVjWN5&;{VfѯY&-)h'^IXٿ}SV~{8UF0"q6Wdlp\`+:f&QR;HǮ5>nS7L$K&>/?g!^ƨ;E +\xy75tJ}̫7} S\1:\ee͐Qr/OHDO9BѢĞ|΅?;`UnO o<'B*z/ϛj5<ƵGw&<ʓf$v6\eWi5?ԅcV7lY2{dxrMr'VNˡoxWti{Vޘ:5cYw4s\Tr/<}Qm< -*jw)'{:Wԋ_+kX%dzLɋu6Ljt7PhݐOH<_ͷQڶ8EYH* hoD9P ~koyoe<;G1 =X aV- f_?) : _G8)(omZJF`ΚXy{UBT&,i<!w*lL~`|>$C<+S,I%NNzz޴bQ aWW@ˑu_*$Y:7&?9գ_ 'Ћ֛ޝ,Ҝ@GǧT[Ɛnp\w(!6Gwߜ , uZWAhX2) !'&Jb!kc)A^af??&"aNݼ̨3ly@k WKpƧċ".6Psi+-\i_}s#Fwpu9upH/r4TuЕx~ZD LUZ`U =5Nɢx1zLxsGxXoAj"1ȵqdž $SE#ˣ$F[1PA}mե+>#O;zP7uמƎ@g!/-QS42&,.DU'wdS `#]q8S7: ,߾u%`48qۼ|[j0b9Sx_*?](Hx8R AXEN;똲LC{F l+YP7=L? _=J{Ojze K7B-֐ FgHUK(w*_XƗ۞4sukrVzt Vx=xhh("]²[OҖ+\WєCεw e׺e%[P$[%Q3Pgױ] v?Kۢ{KqaYe/䣼jUUS=LFLh#kʥpΒLO)V>ue;`]Ax 'a/.iyt UMrv <蜴/sHX۫f"WKQ_̢D- =ˠ$#Ň޵- )v/ U]"1wLݧ# a@8PY(xT=8>AoI BO]=ymJ^Ci)qO/C͟`#[VO#ZɤBcԮ׹F^?٠ kF ?Js 6@ X_dOq;Wj*4Z9¢=5(oF8x˧Fn>$&Z:4_f|u K[uM_rpubּym`c~PCo?i5mZ{mFz'2WZ]cb`Tw}Q)4.!({j%}ފv`ff >13 x Q@.與iB0bEP aB57"6OgJV+ͱeY\}QX4]K݂uezYgrQ:A!DW~vg8{ȍ&,93F 9GQk׾P]˰ SS.*g*:+?#@HqK0Dqs鑎);3{)q:nQIHX|+#(FdF& w6q±2 npz0&U W!qH8w[]㌰ߡ7{.8=]}@V2EdgA37G"'2[jGj?kpfsĹ)+[sX% ?ay+$vh3]3ӫ|2 gjB2-&Q)HqEKa#OYKO^a7B#49<';xѰgh_Q_^'va &w@L} }pEJ))91gPD=]afש>,0qRG*%dԽFka-tRyxT.@]R$|b6o{tqV_OjyqeZʔb_܍u?$aP˨dԲA= E6Cf2n̅ #^PP-b{u$rP# lڡEWt?h_?կL^xwg$J7/$i g=z@6J{Y`1;hc9`E#ʴ'f/*ُaulDl!R\\{*$u%ڈ_*F [KP\KsAX>X` (@GlѕK1*1*9,&t-prrC9R55Č8Vjs xWQ#d:Q`G' 2ܪa-MAʔ:|fj~FVbu!`t}#e$|(A5[3x,_BXOT9<}Ahř6#A+&B6_/)J_4<⸩MVY=ȗĆ9 (V:E-l#r@*^Dn$q,W޺;꨸+R͚Bhs/ঈ=ْ뙙a<>Lƍ k4š: tF[СQ; ~aCE|9v`k$T`4͡QhU;"i 1CyV|TVͣ7˲ 8[\֜?Tj.%i竿M_‡*-$Em_.eWŃK;ʤ(-!4 o9s K2$O K_?aJmj!q +d:Xȯ@!_,?P9ηn> +MP꽆Ђp)4+yS/3C}rXf;x^c/ PFcDw hlNpP!{PV]ӰR# 3FܨH0Ē'=L>zǸ(# U)&7s~#ϦQAQUC( P/‘[J#%Dyǂ;ju<׋@b$PW JkCOu=>䎼D2 9Ӷ[@֨SFgGMNY|nHTGG)q{r:s:g1X%,e׹H{l?G=ZhOjq;vN>ҷ̓Ҷ $AfqC^_6n+du hĞᖻ;ܱMgƪS@t?Ks P[# 3KWzu*KGNxSnKPA;JBnVGhDF~-_}JvSҫӫU sb)LKl#ô79< ]s‘[|W4;xW+UN`y;UڡWN)P>)@Ѯ;%ש+#dPTqeosTOa%yYL}k<=*h%^;ᚫD* RFMpbuxķLF^ f(ߢqYj3$A{rKEcgv[%(zS+[יh[y5;LuӎR !',L'EU ytYң#`>_vm|m5n tdeG[ W>tͼO=:@pv.`d`,hZ2ce(be\c ,;-Sz_,E(N\8FZSF:Ѣ&\MⳟO FYgdP&Y+Ҡ<8_"Bֹ4@ Ӿ ^%Vz9@ bܡgq{25YF% \YrSۘ#cҷ}.} o E&jq,H /ٷ< M8(ks6 ћFWt>{>RůAX$vq,P*[M;H +qP:\og{[Bym]MO<¡,78xq\hU+#zc:Z_z&!/_%UrAJG.GT>Vy˓ 2Xʼn,p{?YgVyv '1YVeԁz5Cy9Gl|y29/B^h. B:#Кdܐn|V=«4Ymi$,Ӳ (_/8υ-u,wgfSYXn^Kuh_JÉeLǝti%Y^n-}D|ؙr#\7N7̅pΛNYp Cޠ'?e::rCP 0Bb_{9ӗEOc'ͅa*tgM\} :}bh.r9 W\P0TrO %ŎiUgd{G{5 t %/}-4]JTlJ8^s5ȳF5ju9Tpy|vG>#zPLFXl[ Fta8'EoyE8Kb!&^5͝amz]!O K cp(DN) #̜RvBkB5fau* b2Ej&zbT {-i39  /a~Gs-ؼ$j*;ʬPЭ-{U9kh+]>@"d?HK~׭B7GNiS|~; 7)HCAED Uu\x{oM JXI5\iC=W DsEl4X9orސΝ܍ȣ q’:QEd*{D,.Gb5|m=3twҕ<+>RAN3lT?Iũddݙ1XW9y!_0-X' !RTj=P5Cr#t-6=tGumZ^C伕$e%d.ҋkk6L2o( uuL3.q?Hfېllp ^H*&tJG:=f YSKkޅ7}2x":i(h%ld֞> }c"i|H9m}/+:a-] tL0_Ymu҉jqڍ"ض 0 5霶A*ƞ(?Bh/T%PU ]66;5"f"QA,f0ψ5,ۏzs5ʉZlEvziKƍb(#0~n^K`(CݍQY b7&?s<ۢU>DZDa3  qbXbm56qDӹZO\jouD=}ػ$8TlfoEsG[C8;,ozF@Πm{&hCuz;<2SU"ֻVc}uR|X`rm.Hcӕ nZJ᳡k` ֵ|p]A=?t _dG o Q,X|Ir8_!ܜPQbIg_oң蝖s9gfNٱ eg6 Et|g(\ _Kg9%h=: R+T;/^Op|E+7x H _JK[EWt7Aj8-!'NƦbOrmo0osT%%#AS8ŏMXUx_\@`Yw, YۣU{ѕ#CF{$qG(>& Yej]*s j\0)op=^pO~'2oceJGRHBГg:AꞋ㻢uWD>Eqkk>0c{KwƨvFG0ڪ8ܭGDχ*۷}"ne+v]wYrB63#÷~p<5xk;7$[7E̒@T9J̿s*ձF]R 1ܦ!Љ ]|p&dwj}7.Rdɨ>n\~Oټ g&޹=g{YK"+oˆ c@4zH }cBoo5q;>dt̼Mȝ5}Ln`t;3o,8\Ho@˅?ۃ//ahZqug-كc%L]*6FU՟%4`=-A͠Uu07>/N=VxJ,zQę)8E|֫pϝybj=MrWmUP#Y q [ZVJgZ1(WY U9\@d/E!+ :~0&xM _̱ 1g?|A 5nXhÀw_*yN6zHH"UT06>0~5w3Q#k2Z fy&*jُɷm-yʲv^;W]ҟ4n͝BQۅa%n{]2f›Ɔ~{@@nNjQ; fߧz`e/%}oU䷳khjxNoSq7N}'MC?Kq?U& p>I&ZƧpiV$~I-S$Z]Gke[6* mYowŗ3 hxwXy<`11n8/ڒ>iѩq/ -R/S\ke"-9CyZFg鷈LBCjGbϼ s{Ta " !EKIPLֺp?#,Dy?ēAfk+膔dsBo>>k o[N( ~b{r8Qy_55ߐ$-YV5^^'ϵ4w18(UHfcE25á;Fk@wmV #mGQJ|kL/5Δd;jܼ Azl`Q:Gnh[󿘱ދ%b ><:BSLt[I[#XYقLS9[xB LuQcFNz—єpM5WāMCV,nh,t5.*黕L^*t^i5A$:()0dY녺?^8Můx=z" ;EQ\ aǍ bh^}*ӗy?]S^Z ATxՎ8J-{>?+c/z9 < ĸL s*Wx$&6\}#.nH~5_ESmkoz7(D"9\HB-v[`p p 8/}k3js_0׬s-uI ā6q+ .T(G9Q8*qRbXU19NP&ΆJ -0-bǹ;u0JHCB EA[18[o7F7dP]H0\8uDO*Dcݍ0QE1Nګ ,ri)Ҋ,.Smeun"GhC#iQF6 )uˍ|yl52 ,a XzU,?TF%g^T]m4n%oeꥡ󙯊*9 6S52V;%RC@&e>PԓڅBrc9Mq]3Ij'V۷Yݯn#$]mb$xS֙]#1V wVyeLqY;jT{<j֩ "?^ i`Yȇc'T3jB,v)´2zg!$SrhV?ޛSk;sk5(,:{VȺ I$7X _ 4sZύ<&KsiPGdڛi{̈́H^|`cҐit#j7Jj9LB]\-[2Ma"'vtڱzZܸ;p@ '*C<k&-^o{n]wm!k4ObzO<貿P ?¤;Z";'Ѳפݽ+3:kT9`=\Vp"i(HÏWR *(:kfۂg kftOpŋ@^48yӳfIe„% !}Tn$ɯϸ%L,DŇ?(QM/o7<׵ٯy_9Qi+r̵Gv%4R Ч+ghYlzc.هi3EeĆDQ da\ eXs Q.6zQ_Հ`m` o-0&EB:M>zZ&UvOvɷ :\K6or)ɝ7y<10)16 s̢Ttmň ĔKQR YA7eV?,w4U+(0St5>CDDS-T#=Xo| Lm=Mg~zFq*Dׄ'=sfM @|oFtnM-@ !1xY2Ԁ3aQP=d.r>wD0?]6Əd;*::@zKO_4`i ' t}z<8$0` ?u-Lu7" 2%}_yd jlr֞=fI$"X$QsZ{f'NjfDDa)S-Ny-0W&#+*uQxͽRub^LUK8G_9i o gZW=bzϑĹ>YF?3 uU=r@3d)M#\21yAv1\~M[-%?u{05{6Lv 8C]/O@$+̆;3?!Ć1UhaW>pĮ쭬؉ w'qW NLkN,nLjE] 8nlOcSQb0Kih·fWf!_8&dC8?Y,ڦ:)djDBIi9x;}. KxRWxfj ۅ䖯Jw$%|qs+Wz V%7o)(lϥtnNǵIMΘoZb8tXt;$?fGdž+(i聅 \|fSRCmVMqjhcm٨\_D݉犥!m~{vWtX`p ZY*p\@Ox/L_vG̭U.b7mq:L-q蚹 Bw AqqWU?HK P2sO 5I |4?fJS .'pA$~a@P, Q=d 5:#[rLyG.3`35xʩ\Ht(`c*q˃)o hM*>sDyA9J Yÿl;u33oʑwvFU ט*L)fM\-{Zª;ZqԲ{.& ۬V$GD{~I3ߩhϧ!N -w$&-M~rJG(rlaY_GؚM,kt5k4ݫ`P6NtM` "5(lS9#K:ze$Zk[ӎ୊}ߊ/E&~5kmTlpYqip;Bl\;gNXkgpk8'4ঝ_"<՟z@/m*O ؾ.$b NAYkPlszBO4H:UŰ+^Ad`Hޯa ":pwVC0AUӟj1ճ7yW[H#A~TuߛJ[oH=y~ڟα=v ް#2B5e!-W@++P|u3 _LIYC[ 1UnZǧB5} VǼי(Wⷤˊ":l "x D2 S.&5P118LHvJg߯YPzȝY) BN v3߱ӁaGF%Aqުa{6y}D>]Bř=~mлړÑwլU+Taynœj.45zD_3q${=쭇U$D`ǜTŊJ ZT}\$7]r[Ҙ?I@YZEx} M(y^wiP?=*h %nk#[|Z9G'mwσ'N."ĂJÐOt[\+_DIO_F1nA0o=aܓ,^dލaݘ|û%wzwvX%(mZ;ԏ/}XQWqYGɰَ;ꮞ.QrfA8ˋl`f[;EM-xd niiā@m,n+Qrgi0E\!=-\QHaRJL5UA;g#o 1b DlcAݘӚۺ@vT( kӛ ~٫h N!7,XKzgPc% 5{:.Encf?_F! WBrvC''Z=ĺvb]H4ezR0IV熪#-Dcp ,ayt5, &S9Y!5`=:~YX3%-5Uhs*^Z}%,>s-0|W3'BEGNfl8A1165jn ^4- -ʕ&wwڻݕiFrS]D?9=h-'sh/NT{; X%QHQ|q=88*u%י"^ b8 ׇB)Ī"]4/[˱aܗJĖ(aa@ qs2+SZg_mJ(w]v/lYyΒSq>qo<|,#>t"2U=N`sƷ3myWL -fm΋Se ϗ5\pt1}bֈ.f"W-6SDGmYԋդv":3;A p5v*g|s ٢>K^Nv+ +" |)mf,Br]zH5 5 a%.Slz;ǘgj(/Pg8!@/g|&rhry񱃑A,RqWd'LoGak&BB|΄JSvY]#+8) ~*{FPg`%_L<vfcu>jO{UayT;?fJ-($FE @y3d$YimH8OHqƮ]~ Wmێ_{ 6`(e¯JMr60@O_P%e=&\G39NN 67y~ (@>[@&p>eEzX`"]J=&r?[' /\nu_8mZ޼EI 3؝H#S/b/ sPB\_^ %BIg?-0{O =$ f~0xH*k" \X[o|q ʙLC(_Y<'h GqujrՓw^Kph9^b63eSjwU2fEk くFԒ°&+·J(ïpp\lsF5rUIxKoG_ܴMhX֑Kʘ$M%\9d#fix)@hI;֒}ʞAQ+kΚFA;.$Oyу{̶iX%HsB OvF7l?n xt G\  9gm8%d|X$"q'uWozdMrG7njAArR-CM(!٫2&$;G?Dp$*+תxҫyzrDΠJyzs؄.-`Nҭ7~n_Ĉ9P{p$ӧ<2 -:lX 7m~Z (w!,S`mYg(3.kΟ3rJXlxG>$Ԛ8oۂw;*VǮ\Ŏk,2n'c`.?I,Zr~Ņlo}C%t$, >kah=ێ&1 \e5}2l;ط&(D!;z^oO(I{ySH/gF{'ikrFo_,q¹ixS,^$Ɍ'^]&;Gpp٬:ꔒ6>^ʿGb4SLMVd;VOeGh?h1w 8T0|PbyM3!5\6r'ǒ` ]d%%P2$'6^Iތ>`V~>/3(7AxV8ϞR 3%F7Xu-f\-T7J{rHܥ%۠Ji1(A_$'){#acee\KОBi⍥Du4.xm3_ό@Ý< H%j <Ĩ~[kD9kl<'nKS_i47Ct|s[eR=pK|_TSda.]ުPRvz_?R>sLk@RJH;|:]S:sO'R@-({>'@ч@[?__KX,j*)pxrߗ 6FmfSRLԹ&JFLZ#^w 21h>bd\c '!hKӆ:Û8ITE4z\|!GVym2}+Y'%IbowVՊcϖSP߻`^:NY֫E!EI: VcD>U; dvx k7]!1{GGѺ)K+G'>LRu㢼 T %# GT"է0jN~\SWc"NF*aPiogȡ*ŧta^IKzhDQt <~:bgzsZRV0e{p1³EKp(oXPx߬l<ޥ0:\9ԅڔpoN0;D=-E]qJЂ3~3>w|F,uҿ(2Y?N=g.un阨H0fW@إ1zo"qk׍Aѱ 7!?M2C-1ڧ"2JPANؘ+$SbgB@kn) !9U|>l ;#U5_boT}Wj3/ yG,ղ 9 !g NHޓEaHjAϙ^?ᮁAn%5Rҽ:k?B&o`5NK%90ySWbFvlY֕RƸ^ #MUϵT'굱^k."lW w,;nAY:сwAv $LnԵgsT5 ∘byaJIc0Bߖ71_hF1Y_5?ml:{c -!ވaF[B3ԸMfx~vO/wC\*Jq8l?D/!t5B>jr\F&X-cѱ} ̞dj"oвx=#>B9Htד6;', X5e_Oct&T=:FijVV vݱJХDc Rң@OsBٸ(|pN3}amþZ@14i˴nB ˲n/!s#vE!$`v7tSj GSſVrȰ$Mbqܺ7}ЀGk`yk65 ˽JB@nF3Cm/{Gb<_ )i7J"}V7K 5LIH#;8G;A]3[p_,w4Z.^?#fuڱXeAc Nh D#Da ɛJg_̓)[nd`I30.MK%ծCJP\?h4MpGN|J>#$ԗL'SC-JXNF)С*ҹ'ى22̩d7~gYJMҼāF V<4;m|Cѹq+Х=&`T\g(b,70"(;pSVD5Ǟ"WvJ,/7A(/XYۓx'__APS /CJOۘ*_|$CGQǝ2zVTؾdce,\w,;ѻA/-̯MJ"șA7J2snDqxhɈ!y8d*>uX(($"9Gh1Z(0p޲oW+SBH>WhNU:=)`3Ke`#򧆹OۘLi1wYqJEŰbrgԂ,A)D=)-3ɅBrO#JU&,mW*~KpupԵ͟94VޟFܲX#0@'L%n08E VyȢbTSkKi6šgΪ*&~#Y'4YaFzbՓ=u;|[+HvCd*RGZ+A:=יmm V厞k]y &.O}\ʰ5C@0UYDKNx(K0陋B!/ |ؖEKj:<7MEo Ό+A6O[\B*?6p=e>KkComJ+r*!ŧ~Es~j?axuur_C0+XuJ!ڨ9LԒg+¢ܶ M/9Rb`p:۟o1o=UB^uh6Q(Ӏn⹕%.m UjXDhi~%@_@a/\ezA+e:Ky^!5H#pߎO!JeB«&P\(9!P׀ 3NM!#&Ywφ phg&$':e|{ĉ>|һ `RYH$@礨 (J#FK3xn"TZx^;2)K,JOQ16My\5 ]ּ_Zâ e8J}~"T7쑕jw ^YX= ֓i>Rg g0`Y6Efr`!Ih.O2ZmHF8E}C;"q=-vNkoMh*iBjr*f4v[6t]cY gÞ \rfah&bix!n֏ˉ$=4#_IyXz^`&u6.υnf/͕c!K3)la\1![%Ƈ9br{{nQ;luY2 ?U׌0 +Z=@DRRrچkuEqMP3OM*]f-Sיnqc<k<沇A+1. "Gl(s[ {8L^11wWr=$c'UF $?坥kK5M'\]߱GɎT،FAA5~]=FY^^C'Aw׋4孢ZX#)4epVw75QG*7cg_/ DZ6dY/5~K/#q%V5 = =/4L冔Ɋ>1XF:< *DTz:zY=z@Q=¼ah3uϯbxX`$ap&u<7>EX ^X #%8#<.'8[M2[ve23ƴd(470 jvr}h<)g8܃.9sVh |,0Xp-Dޣˠ hÏ#&BS.3S_N$sgP۝ .jĔTMƅ3V 5sO"4L3Nk{ۘי1|j;~w?HI~%D$6Xcy:ڻZ"=Vr+wBɇGRVtzu2w]:_9hbg3QOyT=jΗ~,"rwJϏ͢mn9B3Xbnʹ =jlA޳wƓ&qͤ\7 ?W`x.0V37%Xǂ3 ]"!;%eY(7! VWҾo]-$~}Y&#pmۀVb#K.'=Wmث ݿGR}gY|'Ờ1a@]QiuD4FU&o$L6X3(eFV*ab9|NA:]/4jϮÖB(9=1nXj&1CFLJY PSqR$'+AQOMNVsQ>0:Cx [sY_ G/hE0ҕB XrP<+ G|}D@H &:O> :81rŽdeOiꑘ1~9 G2Fai`pBP Y|7,oׁF0H$贍XoPʀ q=9"HdN$̋Bxn' +<|BkDTgk}>xF(="᫱w~jB51)'NRxD)*SŠA7T [cXaRpF/ouC*Ixa;Eď$8M;0uZ B0orD`TT ڐ=ኀbCBbPQDDoCi".&w1:44[-ʟ%`_!ckv /NIDJ닏bJoftꃬ_%qc$LH}<$N~8ڑMK@8b_Ze>Ӄvƅxpp\?QWxm#d4A7 &2ʫDmcY5ioF멃 'bN`:QTo?m{lz\&cth`ǵW,𙅿}Q !J h*9@ xAUjI`/S| ?Mmj|%FViv$ I*HեxHz= 7%Ks;05B\_i<[J2MK9@jffcdfgx7䧆lA(*nJ"=K8?lmv5"9дbB$4 1 +z@R!#$#(;P5 S"C  =݈V|Eq Bt^K-ޭ2 XlAtV.Pp?cS(hN ʂWRJayP'6qA$b-J \҄u59TF n|(P+Im9%%R5sX랻 ]:%1Uqmpжw1 P%Ϙ:6ÜDžuWt<ڣ]&޾#QPkJZlaj̼ 0pSJ»Z6 6P\nkij*Di`9 CŷexŠt5BK./ QK{}uy МU5G ȶ{AXj`:(t$𫂥X:hbR!" 9ypS=nxkmCB>d#B6je} B)E .%H_.&#E焻Ǔ<4 ^k JԇRtoz*;]y]^9_Q{( 3%35Rp)͡=yɷ0c!i}ޮ9_Wq|.,%7ӟĚU  WZ$(⇁$ j L_{7`kmhSz"6[)ټtnHq7cO C\(3DWf~A?"p'ن[FuppІ+T)3 & \;lU۫HE<6X8xܨND@#<weRx(@huBrAqClfM!AC_:Au8GxXv2%썘#FW*u 1 q26֌$ c`lf{9l[wJķ$U95-\(bx ͔~1r >Va a2yk̖R2V3 OIhᑢ.EƊ!E2Yts,(1 .9G\rB0xxH,-@mr,5 >j)Bw{^z7%T^~,w3ZrF?%o81 O',{j>(vtFlON v,;>] i2&W7›,AKd57Oh>Ke%ŏuh`dHT|V03 9ק,.=cϝ1q6w8 4+%;Kºװ03C7D@;&wԶͫt FoODz泙!BX E:eQ3[$k/.:FjkΈqpD[ = Zeh^YL̒t)#Ti@,p\Ix֠Nm=Y|-ˡ . y>{n d6O7oZ[೷ =xAz¢xmh W=`IbB)57YjKbM޲-8ܨ8.`1cۆxb>ⱧѶϞ0B&Y)nކԺy`~@ $?$=sq*wpKKlpschwE*X ^Z=u>կ 1ͻ6nEG[9d-M.*_|I>yʾpX!bDRI9/0漧 na.M~3w.rV|[Pr- LDB@ihJ/( t>=~(WQW*&dƩCSbajiv&`B( UT4g8zyrT9RĜϖധyFV`wEsh{2³9;S F!DHU]4hBK=ݗF:.TkaTk͘q$ۈTqӃb޸MjIZD lo21 Qʸ8XM5GAapy˔)23]UiJmGʼn0Ȁ݆:27Srd4x"+v]c~V.xg3R/ʠ#(+. t'z`fD u31$yVL55d`# +G2м<*b|A&aӄ̜$ c=wcҿ ϋТj$_%w+B|Idh0 Ãm!BJr l%XM hVOÞfYi3VozjAuTp֞7tcタ 6cϧu +h EC:O缥FlF?ŒEbD7C{̰h%Ԟw56JLjA}Sc{kRr7 Ln $df-Q bp9 u{[:$ e1NQGTc@BkwOMB |*a#Aqy%zVq艚t9^p LXЊ?h QvQe/oc} `9CUfJX~'?Ĝ*m%EV@0X~M̬g|P+nUDF*CĒL4[[at<͎FJ< ȜY6;-DoJE):Z?I54 zQckx"o- yB3E&vwHkֻ.>[|]V]A )43xa>}};/U)|`euƖ#1V"lG`ơΟxdsvXϦUOۜ{-ѕ ͺ {"5῍n[u͒bCv ,վ/f57ghk ]q=B!w]qJ{s3g˜J$V/yc8٠t+})nyc_0L+@4M^UN6ugF~:< 8n&Ezb;Cas?t=Hz֟!Zk蔀}9; LF0b4v[N~$,"@U7SQwUEc9k `T `9<&Z;&zxfca%-DX|҇OYw{Q+tXS ﯗeap oe/2vKG|2E,*rK^d(]rmB&P kC;#n {)G%+֐a&4p0*AZWr7}|c@ge .0V;44MC /kA\ds5eS*bqbDW@Y:ڂQ GByeGnVM^6踀fHk-È"٦aj^(O[9:̀o"7(0 nkmݒټZ{-={!84<,ҁ>g5+0Ü(;.%>d#'(аF鐽xN(um 82u3q;epE(Aߍ !?C vq%,~jx(]Iˆ` \q`KD6Ro(h};nЂhNf79E[8:~N? pA5(8}vJ p+u!\+R/z\_!PO3 5tXeA+Î :*njϦ+6LXFbX~L:qedV_2P'гG~tо oZL[Ukǀh86G:<}| XSRl),buf>mqP9JcX3eTz ^9!N݈B4LN`$'No3R^isV+/6x ^؀-s习0 N(pU,9ȃ`ɶ:MtĽ`h4*ꛮ+ykZLPe^A!76&7 &2HwGa{>-)e8}2Λ|:8FtJ"n]pEmSKt2έ S3 [ &F'DzxUI"yإ4^y~rZ]tORxjA6i.a`Ӯ Aiqʏ#F) VXNڙ#p젅A r $,!$|1bTF i9;" mxDKsg# %tnAq]L@iT+n'Q!~W*ݝ;?{Z4yaZlkVB}z=J-BZUait ֲcc>}3-uP47".S/{p.' KrD7 ; x4{pǀ6Wm B#7sGSl4Lzsp6%ˊPg=r͊ CIs%'dE[-;L~tB i ƯG%Wg_eq+Ó[u[F\4xqwF"[EIi^p`Z`PJ\_.Ĺ=d_QN|JDV.1ez'|O%3[1և%I~Fq 1ftM(LM' $3L*Ϛ䂃K H Y Rm"ɼVqhi/.DXizFڨ^CC$5"R~%ju{XSK#󁳘`&݇^}3k79=;3Y_z 6l,_zOW]xsӻ|C06 {̷;eB'CZ9./Fԅ*皍N׷) ܔ\N7< 1EbL: \3 \~%e ``\LuKM {:ي Ζ2ܵ \Ui0G:K)m\~9 O:Ž%i#97ߚ\Od2՘˼Cт]nd[ע8$ӏm6iBq^W&v1ЃW2 d! ) nΌʬyWO[TС䜣NyɵBLJTk-௔~ **Vn ]/89Lf4ZN1&mxKỷhsyF -r{xo,xX"xվ^ٝu)cY;u%_JB>q牵_݁uJ7)$Ʃ$ղWwMHUz?Rl, iP]XLsj$ސ͸#GfoׇcE:"ipWh&$vX(5d8Y\jD@"|TlM[G_ƍ #d>+F= ֝+ y%xX<5/Tt x = m;3BŀؙHCd~PCMx9DIsKBK iw8\hQ:5 ǀio`]AB^v, D VJB`#!M+ {ص #ز-v̕\ړ֜"SgW̪ r1)0V9pNl[?̲ʎzw`BҔ]Avp>Gɺ MCJ(uMD#dGݡK^M4}m8ƭjUw{eUU8H sELh .b \'WO-V_ʙ]8$ATz"2 vV_!O/)>:5 5ѤE 1L s]x,Nc>!֥ ~($X'‡ՠtC!lٌrسVdb Gѩugh>Ԯ@]{mL!=^jw=G!F$r%q.}gf47Xʗ,'*|8Dq:]Q3ʯ8'0S6[Jg-*Ȼw:Z1.0 |/`fnAnw9m1B56C ac*'2Q~cwgj٣f5 b$r̢_O_\ "1$y2C0nQL(Ĉ}r8B@c;Ud_vUa~^iC4 Vw"<g-PC=:aÏm,Ha_ i7IH<|u/ʍ~MglG{xh4/صp]-A{9ܕ)/0Xfw8wuQ7~t9}+'jV:vfN:06Ν& c!7ψoɻ*]t"u*kXyf{O: 5Z#5:隋 La:eiy3sNjtT -m&O*kCH w1 hsH4qɌzC> (6NU-}nN1b[]ʛW-GGM{9^M0G0&HXa?Z(1o376UK pU{ټ~{T fT~;R>Ӝ_K[V &t+pt ^3?حZ|^X{j=ZŤ *&*II@7%Ac\s'V9PK"H_ H4_,iyę\kѓy -帝( kaU(Zfmj I`Cn`n~ %0j+ÖD9!O37k M@^4ٓ W)ƿ. _v jz:Ae8.9pOXM=q7@UJ:L="lO z;9JK٘㢥KjxcE2,'~Z[e)ىbBkhFvHX ҴYDXD$J7xx$u?x!3F3v"PbCy8"3Q%dvͬڗJl˴#8? zڴo"[yਮzZD3l-Ss&*d@.اe-RHN=lCÊ0tx]N=ooNH>X:eDKL|^ |KO6231nC6QR\y- ?}d>24o:^]coFBa!wMnY} ՆA Ul9|5Adoo 4euJM xj׊m|l#'hnÕ;9Ǎgkgm%dskR:L`xۛ/%3҃z0i,]}X Zmc26X Aư\E^')f.E?#w' '{~$ZEaE)}>zj/̓dёwљ6hd 1qfIOۖo4 O5x:t}9E⨤1CP ;=ҮZ?fDSJȤ%Y';?tNTQ{dbd}s: p[*4.|L2 ^=Џ$^R8+H# ԅB"ĖKr&pmM| yg ݟowzn'uƿu[}M:aܱV᎗pP"̓6Ǩg +MkQ$pAJ/eY=J9c~F//х8V.չ^ Pƾֺ rP4uEk-Xgm1+=Y*|p6\hw"R!RaM>@!9ϻc([M92=:*I.Gٌ rm:󘂤=r;anWPcӓ׵TsHV "V^RZކ~;`Br@@$_^ݑTv%! čnVMw |Yu.!O[tuH2S8谺4n0EKc<Gˠ)MhgnX9V#pD~PxPmoyξQeuDLy,  ѶljbWz*Yb4 &]t4{εG}<<xi,C83dYV$ 3Ȥ칿j>mS:IaE_" GhTMswr9p&,wl-P!'!e &[ ?3^0%DqKYmPvsp/5&ֺh6%&̡/lHH*o:*2W Ќ.wkⅿ\P㤚i|gH'5w2leZ#!996tB ͜\?9PUs~6v]7? L&k4:Mu][4.R $bJ!~Mf{-WH ;2HW\ (Z!>l^ʓ˷4>︬V]j3泺ReͺhF4B !Ɖ8AN7I{Y i9̛~鳞#v{A'! 4DxN?rtC{@WZOO+fx]kUL(|TпYdA^T5[Eb`uAk]/Sc>:P *P4)J2Ōo݄>]bˮwUYI 9&DR˔hlJi/㊍0O"Ű\`T ӳC1u h 6I6Ϥ./ G"A&P6kSթClop\ F?(]D\ =IΝU!"Si hhgS]ݝǙNB7v<`I8tN\5K襴CT: LCl -Rʻ*rgGT6Gzm-xsx> %GaM<FujXBf +AZh*Byc`AXv` 'j(Vv>^ф j{Nc e"XxT p%6CM{ IXi709M:*ڏ:GcT撵{ l%Lc[,'n\ġn&J$ EB]T/>Agg5nf) D P(BIe6md f#ySd5}q)z=`@e62=~CEP>t>ʳ&Q `GDP.'>!\o+:U6$kyqDwyO5׬pxvrawb=L[E@Vh}";u5jIDH, =qXМہ%TiI:3 ѱC ÊpFjYX=gF'쯫VC*+@k#ȥAJi %4fs?'[_ J¦NlLBDŽ>)鏉NCm#+c;WҾp('p%r@?ɰ|34g% EmrM_Ta[dwGC]ɌH] kRg[A!\ǎ|ϳ"ϝ{E˞RtBW>H|%P; /"ӪwgRp[kD隞ܵNߡ6ZSX_ DVzoPt.# ,zfNNޢk .)+|A0XP1a9VEpu9!X c>o~7w_&\>Qv( 99',7tMcdΎ\r/ cc&p]0(ҼRۂvd.~;,7|<8K]ꕀ1/Hg7LϤ #2YhA8VLh`c2ʏgPWHaMG難قXA DI#1jC[Z@n%wGz,'Kt_׻l1i3_`ld{ʊWfU]u:"MԧECag.p Rposterior/R/rvar-cast.R0000755000175000017500000002062714165314655014704 0ustar nileshnilesh#' Coerce to a random variable #' #' Convert `x` to an [`rvar`] object. #' #' @param x (multiple options) An object that can be converted to an [`rvar`], #' such as a vector, array, or an [`rvar`] itself. #' @template args-rvar-dim #' @template args-rvar-dimnames #' @param nchains (positive integer) The number of chains. The default is `1`. #' #' @details For objects that are already [`rvar`]s, returns them (with modified dimensions #' if `dim` is not `NULL`). #' #' For numeric or logical vectors or arrays, returns an [`rvar`] with a single draw and #' the same dimensions as `x`. This is in contrast to the [rvar()] constructor, which #' treats the first dimension of `x` as the draws dimension. As a result, `as_rvar()` #' is useful for creating constants. #' #' @seealso [rvar()] to construct [`rvar`]s directly. See [rdo()], [rfun()], and #' [rvar_rng()] for higher-level interfaces for creating `rvar`s. #' #' @return An object of class `"rvar"` representing a random variable. #' #' @examples #' #' # You can use as_rvar() to create "constant" rvars (having only one draw): #' x <- as_rvar(1) #' x #' #' # Such constants can be of arbitrary shape: #' as_rvar(1:4) #' as_rvar(matrix(1:10, nrow = 5)) #' as_rvar(array(1:12, dim = c(2, 3, 2))) #' #' @export as_rvar <- function(x, dim = NULL, dimnames = NULL, nchains = NULL) { out <- x if (!is_rvar(out)) { out <- vec_cast(out, new_rvar()) } if (!length(out)) { out <- rvar() } if (!is.null(dim)) { dim(out) <- dim } else if (is.null(dimnames) && is.vector(x)) { # for non-vector-like input (matrices, arrays, etc), vec_cast should # have already copied over the dimnames correctly. For vector-like input, # it doesn't; so as long as the `dim` argument isn't set we can copy # the name over names(out) <- names(x) } if (!is.null(dimnames)) { dimnames(out) <- dimnames } if (!is.null(nchains)) { .ndraws <- ndraws(out) nchains <- as_one_integer(nchains) check_nchains_compat_with_ndraws(nchains, .ndraws) nchains_rvar(out) <- nchains } out } # type predicates -------------------------------------------------- #' Is `x` a random variable? #' #' Test if `x` is an [`rvar`]. #' #' @param x (any object) An object to test. #' #' @seealso [as_rvar()] to convert objects to `rvar`s. #' #' @return `TRUE` if `x` is an [`rvar`], `FALSE` otherwise. #' #' @export is_rvar <- function(x) { inherits(x, "rvar") } #' @export is.matrix.rvar <- function(x) { length(dim(draws_of(x))) == 3 } #' @export is.array.rvar <- function(x) { length(dim(draws_of(x))) > 0 } # type conversion --------------------------------------------------------- #' @export as.vector.rvar <- function(x, mode = "any") { dim(x) <- NULL names(x) <- NULL x } #' @export as.list.rvar <- function(x, ...) { apply(draws_of(x), 2, new_rvar, .nchains = nchains(x)) } #' @importFrom rlang as_label #' @export as.data.frame.rvar <- function(x, ..., optional = FALSE) { out <- as.data.frame.array(x, ..., optional = optional) if (length(dim(x)) <= 1 && !optional) { names(out) <- as_label(substitute(x)) } out } #' @importFrom tibble as_tibble #' @export as_tibble.rvar <- function(x, ...) { #default name for vectors is `value` with as_tibble value <- x as_tibble(as.data.frame(value, optional = FALSE), ...) } # vctrs proxy / restore -------------------------------------------------------- invalidate_rvar_cache = function(x) { attr(x, "cache") <- new.env(parent = emptyenv()) x } #' @importFrom vctrs vec_proxy vec_chop #' @export vec_proxy.rvar = function(x, ...) { # TODO: probably could do something more efficient here and for restore # In the meantime, using caching to help with algorithms that call vec_proxy # repeatedly. See https://github.com/r-lib/vctrs/issues/1411 out <- attr(x, "cache")$vec_proxy if (is.null(out)) { # proxy is not in the cache, calculate it and store it in the cache .draws = draws_of(x) out <- vec_chop(aperm(.draws, c(2, 1, seq_along(dim(.draws))[c(-1,-2)]))) for (i in seq_along(out)) { attr(out[[i]], "nchains") <- nchains(x) } attr(x, "cache")$vec_proxy <- out } out } #' @importFrom vctrs vec_restore #' @export vec_restore.rvar <- function(x, ...) { if (length(x) > 0) { # need to handle the case of creating NAs from NULL entries so that # vec_init() works properly: vec_init requires vec_slice(x, NA_integer_) # to give you back NA values, but this breaks because we use lists as proxies. # When using a list as a proxy, a proxy entry in `x` that is equal to NULL # actually corresponds to an NA value due to the way that list indexing # works: when you do something like list()[c(NA_integer_,NA_integer_)] # you get back list(NULL, NULL), but when you do something like # double()[c(NA_integer_,NA_integer_)] you get back c(NA, NA). # So we have to make the NULL values be NA values to mimic vector indexing. # N.B. could potentially do this with vec_cast as well (as long as the first # dimension is the slicing index) x[sapply(x, is.null)] <- list(array(NA, dim = c(1,1))) } # broadcast dimensions and bind together new_dim <- dim_common(lapply(x, dim)) .draws <- abind(lapply(x, broadcast_array, new_dim), along = 1) # move draws dimension back to the front if (!is.null(.draws)) { .draws <- aperm(.draws, c(2, 1, seq_along(dim(.draws))[c(-1,-2)])) } # determine the number of chains nchains_or_null <- lapply(x, function(x) if (dim(x)[[2]] %||% 1 == 1) NULL else attr(x, "nchains")) .nchains <- Reduce(nchains2_common, nchains_or_null) %||% 1L out <- new_rvar(.draws, .nchains = .nchains) # since we've already spent time calculating it, save the proxy in the cache attr(out, "cache")$vec_proxy <- x out } # vec_ptype performance generic ------------------------------------------- #' @importFrom vctrs vec_ptype #' @export vec_ptype.rvar <- function(x, ..., x_arg = "") new_rvar() # identity cast ----------------------------------------------------------- #' @importFrom vctrs vec_ptype2 #' @export vec_ptype2.rvar.rvar <- function(x, y, ...) new_rvar() #' @importFrom vctrs vec_cast #' @export vec_cast.rvar.rvar <- function(x, to, ...) x # numeric and logical casts ----------------------------------------------- #' @export vec_ptype2.double.rvar <- function(x, y, ...) new_rvar() #' @export vec_ptype2.rvar.double <- function(x, y, ...) new_rvar() #' @export vec_cast.rvar.double <- function(x, to, ...) new_constant_rvar(x) #' @export vec_ptype2.integer.rvar <- function(x, y, ...) new_rvar() #' @export vec_ptype2.rvar.integer <- function(x, y, ...) new_rvar() #' @export vec_cast.rvar.integer <- function(x, to, ...) new_constant_rvar(x) #' @export vec_ptype2.logical.rvar <- function(x, y, ...) new_rvar() #' @export vec_ptype2.rvar.logical <- function(x, y, ...) new_rvar() #' @export vec_cast.rvar.logical <- function(x, to, ...) new_constant_rvar(x) # character casts --------------------------------------------------------- #' @export vec_cast.character.rvar <- function(x, to, ...) format(x) # casting between rvar and distribution objects --------------------------- #' @export vec_ptype2.distribution.rvar <- function(x, y, ...) x #' @export vec_ptype2.rvar.distribution <- function(x, y, ...) x #' @export vec_cast.rvar.distribution <- function(x, to, ..., x_arg = "", to_arg = "") { x_list <- vctrs::vec_data(x) if (length(dim(to)) > 1 || !is_dist_sample_list(x_list)) { vctrs::stop_incompatible_cast(x, to, x_arg = x_arg, to_arg = to_arg) } x_rvar_list <- lapply(x_list, function(x) rvar(vctrs::field(x, 1))) do.call(c, x_rvar_list) } #' @export vec_cast.distribution.rvar <- function(x, to, ..., x_arg = "", to_arg = "") { if (length(dim(x)) > 1) { vctrs::stop_incompatible_cast(x, to, x_arg = x_arg, to_arg = to_arg) } x_vector_list <- lapply(vec_proxy(x), as.vector) names(x_vector_list) <- names(x) distributional::dist_sample(x_vector_list) } # helpers: casting -------------------------------------------------------- # create a constant rvar based on x (a double, logical, or integer) new_constant_rvar <- function(x) { out <- x dim_x <- dim(x) if (length(dim_x) == 0) { dim(out) <- c(1, length(x)) } else { dim(out) <- c(1, dim_x) dim_i <- seq_along(dim_x) out <- copy_dimnames(x, dim_i, out, dim_i + 1) } new_rvar(out) } # is this a list of dist_sample()s? is_dist_sample_list <- function(x) { all(vapply(x, inherits, logical(1), "dist_sample")) } posterior/R/rvar-.R0000755000175000017500000005747414165314655014043 0ustar nileshnilesh#' Random variables of arbitrary dimension #' #' Random variables backed by arrays of arbitrary dimension #' #' @name rvar #' #' @param x (multiple options) The object to convert to an `rvar`: #' * A vector of draws from a distribution. #' * An array where the first dimension represents draws from a distribution. #' The resulting [`rvar`] will have dimension `dim(x)[-1]`; that is, #' everything except the first dimension is used for the shape of the #' variable, and the first dimension is used to index draws from the #' distribution (see **Examples**). Optionally, #' if `with_chains == TRUE`, the first dimension indexes the iteration and the #' second dimension indexes the chain (see `with_chains`). #' @template args-rvar-dim #' @template args-rvar-dimnames #' @param nchains (positive integer) The number of chains. The default is `1`. #' @param with_chains (logical) Does `x` include a dimension for chains? #' If `FALSE` (the default), chains are not included, the first dimension of #' the input array should index draws, and the `nchains` argument can be #' used to determine the number of chains. If `TRUE`, the `nchains` argument #' is ignored and the second dimension of `x` is used to index chains. #' Internally, the array will be converted to a format without the chain index. #' #' @details #' #' The `"rvar"` class internally represents random variables as arrays of arbitrary #' dimension, where the first dimension is used to index draws from the distribution. # #' Most mathematical operators and functions are supported, including efficient matrix #' multiplication and vector and array-style indexing. The intent is that an `rvar` #' works as closely as possible to how a base vector/matrix/array does, with a few #' differences: #' #' - The default behavior when subsetting is not to drop extra dimensions (i.e. #' the default `drop` argument for `[` is `FALSE`, not `TRUE`). #' - Rather than base R-style recycling, `rvar`s use a limited form of broadcasting: #' if an operation is being performed on two vectors with different size of the same #' dimension, the smaller vector will be recycled up to the size of the larger one #' along that dimension so long as it has size 1. #' #' For functions that expect base numeric arrays and for which `rvar`s cannot be #' used directly as arguments, you can use [rfun()] or [rdo()] to translate your #' code into code that executes across draws from one or more random variables #' and returns a random variable as output. Typically [rdo()] offers the most #' straightforward translation. #' #' As [rfun()] and [rdo()] incur some performance cost, you can also operate directly #' on the underlying array using the [draws_of()] function. To re-use existing #' random number generator functions to efficiently create `rvar`s, use [rvar_rng()]. #' #' @seealso [as_rvar()] to convert objects to `rvar`s. See [rdo()], [rfun()], and #' [rvar_rng()] for higher-level interfaces for creating `rvar`s. #' #' @return An object of class `"rvar"` representing a random variable. #' #' @examples #' #' set.seed(1234) #' #' # To create a "scalar" `rvar`, pass a one-dimensional array or a vector #' # whose length (here `4000`) is the desired number of draws: #' x <- rvar(rnorm(4000, mean = 1, sd = 1)) #' x #' #' # Create random vectors by adding an additional dimension: #' n <- 4 # length of output vector #' x <- rvar(array(rnorm(4000 * n, mean = rep(1:n, each = 4000), sd = 1), dim = c(4000, n))) #' x #' #' # Create a random matrix: #' rows <- 4 #' cols <- 3 #' x <- rvar(array(rnorm(4000 * rows * cols, mean = 1, sd = 1), dim = c(4000, rows, cols))) #' x #' #' # If the input sample comes from multiple chains, we can indicate that using the #' # nchains argument (here, 1000 draws each from 4 chains): #' x <- rvar(rnorm(4000, mean = 1, sd = 1), nchains = 4) #' x #' #' # Or if the input sample has chain information as its second dimension, we can #' # use with_chains to create the rvar #' x <- rvar(array(rnorm(4000, mean = 1, sd = 1), dim = c(1000, 4)), with_chains = TRUE) #' x #' #' @export rvar <- function(x = double(), dim = NULL, dimnames = NULL, nchains = 1L, with_chains = FALSE) { with_chains <- as_one_logical(with_chains) if (with_chains) { nchains <- dim(x)[[2]] %||% 1L x <- drop_chain_dim(x) } out <- new_rvar(x, .nchains = nchains) if (!is.null(dim)) { dim(out) <- dim } if (!is.null(dimnames)) { dimnames(out) <- dimnames } out } #' @importFrom vctrs new_vctr new_rvar <- function(x = double(), .nchains = 1L) { if (length(x) == 0) { x <- double() } x <- cleanup_draw_dims(as.array(x)) .ndraws <- dim(x)[[1]] .nchains <- as_one_integer(.nchains) check_nchains_compat_with_ndraws(.nchains, .ndraws) structure( list(), draws = x, nchains = .nchains, class = c("rvar", "vctrs_vctr", "list"), cache = new.env(parent = emptyenv()) ) } # manipulating raw draws array -------------------------------------------- #' Get/set array of draws underlying a random variable #' #' Gets/sets the array-representation that backs an [`rvar`]. Should be used rarely. #' #' @param x (rvar) An [`rvar`] object. #' @param value (array) An array of values to use as the backing array of `x`. #' @param with_chains (logical) Should the array of draws include a dimension for chains? #' If `FALSE` (the default), chains are not included and the array has dimension #' `c(ndraws(x), dim(x))`. If `TRUE`, chains are included and the array has #' dimension `c(niterations(x), nchains(x), dim(x))`. #' #' @details #' #' While [`rvar`]s implement fast versions of basic math operations (including #' [matrix multiplication][rvar-matmult]), sometimes you may need to bypass #' the [`rvar`] abstraction to do what you need to do more efficiently. #' `draws_of()` allows you to get / set the underlying array of draws in #' order to do that. #' #' [`rvar`]s represent draws internally using arrays of arbitrary dimension, which #' is returned by `draws_of(x)` and can be set using `draws_of(x) <- value`. #' The **first** dimension of these arrays is the index of the draws. If #' `with_chains = TRUE`, then the dimensions of the returned array are modified #' so that the first dimension is the index of the iterations and the second #' dimension is the index of the chains. #' #' @return #' #' If `with_chains = FALSE`, an array with dimensions `c(ndraws(x), dim(x))`. #' #' If `with_chains = TRUE`, an array with dimensions #' `c(niterations(x), nchains(x), dim(x))`. #' #' #' @examples #' #' x <- rvar(1:10, nchains = 2) #' x #' #' # draws_of() without arguments will return the array of draws without #' # chain information (first dimension is draw) #' draws_of(x) #' #' # draws_of() with with_chains = TRUE will reshape the returned array to #' # include chain information in the second dimension #' draws_of(x, with_chains = TRUE) #' #' # you can also set draws using draws_of(). When with_chains = FALSE the #' # existing chain information will be retained ... #' draws_of(x) <- 2:11 #' x #' #' # when with_chains = TRUE the chain information will be set by the #' # second dimension of the assigned array #' draws_of(x, with_chains = TRUE) <- array(2:11, dim = c(2,5)) #' x #' #' @export draws_of <- function(x, with_chains = FALSE) { with_chains <- as_one_logical(with_chains) draws <- attr(x, "draws") if (with_chains) { x_dim <- dim(x) dim(draws) <- c(niterations(x), nchains(x), x_dim) x_dim_i <- seq_along(x_dim) draws <- copy_dimnames(x, x_dim_i, draws, x_dim_i + 2) } draws } #' @rdname draws_of #' @export `draws_of<-` <- function(x, with_chains = FALSE, value) { with_chains <- as_one_logical(with_chains) if (with_chains) { draws <- drop_chain_dim(value) nchains_rvar(x) <- dim(value)[[2]] %||% 1L } else { draws <- value } attr(x, "draws") <- cleanup_draw_dims(draws) x <- invalidate_rvar_cache(x) x } # misc standard methods -------------------------------------------------- #' @export levels.rvar <- function(x) { # TODO: implement for factor-like rvars NULL } #' @export rep.rvar <- function(x, times = 1, length.out = NA, each = 1, ...) { # flatten before rep()ing dim(x) <- length(x) if (each != 1) { x = vec_restore(rep(vec_proxy(x), each = each), x) } draws = draws_of(x) if (is.na(length.out)) { # use `times` rep_draws = rep(draws, times) dim = dim(draws) dim[[2]] = dim[[2]] * times dim(rep_draws) = dim out <- new_rvar(rep_draws, .nchains = nchains(x)) } else { # use `length.out` rep_draws = rep_len(draws, length.out * ndraws(x)) dim(rep_draws) = c(ndraws(x), length(rep_draws) / ndraws(x)) out <- new_rvar(rep_draws, .nchains = nchains(x)) } out } #' @method rep.int rvar #' @export rep.int.rvar <- function(x, times) { rep(x, times = times) } #' @method rep_len rvar #' @export rep_len.rvar <- function(x, length.out) { rep(x, length.out = length.out) } #' @export unique.rvar <- function(x, incomparables = FALSE, MARGIN = 1, ...) { draws_margin <- check_rvar_margin(x, MARGIN) draws_of(x) <- unique(draws_of(x), incomparables = incomparables, MARGIN = draws_margin, ...) x } #' @export duplicated.rvar <- function(x, incomparables = FALSE, MARGIN = 1, ...) { draws_margin <- check_rvar_margin(x, MARGIN) duplicated(draws_of(x), incomparables = incomparables, MARGIN = draws_margin, ...) } #' @export anyDuplicated.rvar <- function(x, incomparables = FALSE, MARGIN = 1, ...) { draws_margin <- check_rvar_margin(x, MARGIN) anyDuplicated(draws_of(x), incomparables = incomparables, MARGIN = draws_margin, ...) } # check that MARGIN is a valid margin for the dimensions of rvar x # then return the corresponding margin for draws_of(x) check_rvar_margin <- function(x, MARGIN) { if (!(1 <= MARGIN && MARGIN <= length(dim(x)))) { stop_no_call("MARGIN = ", MARGIN, " is invalid for dim = ", paste0(dim(x), collapse = ",")) } MARGIN + 1 } #' @export all.equal.rvar <- function(target, current, ...) { result <- NULL if (data.class(target) != data.class(current)) { result <- c(result, paste0( "target is ", data.class(target), ", current is ", data.class(current) )) } # ignore cache in comparison .target <- unclass(target) attr(.target, "cache") <- NULL .current <- unclass(current) attr(.current, "cache") <- NULL object_result <- all.equal(.target, .current, ...) if (!isTRUE(object_result)) { result = c(result, object_result) } if (is.null(result)) TRUE else result } # helpers: validation ----------------------------------------------------------------- # Check the passed yank index (for x[[...]]) is valid check_rvar_yank_index = function(x, i, ...) { index <- dots_list(i, ..., .preserve_empty = TRUE, .ignore_empty = "none") if (any(lengths(index)) > 1) { stop_no_call("Cannot select more than one element per index with `[[` in an rvar.") } else if (any(sapply(index, function(x) is_missing(x) || is.na(x)))) { stop_no_call("Missing indices not allowed with `[[` in an rvar.") } else if (any(sapply(index, is.logical))) { stop_no_call("Logical indices not allowed with `[[` in an rvar.") } else if (any(sapply(index, function(x) x < 0))) { stop_no_call("subscript out of bounds") } index } # Check the passed subset indices (for x[...]) do not go beyond the end # of the valid dimensions check_rvar_subset_indices = function(x, ...) { ndim = max(length(dim(x)), 1) if (length(substitute(list(...))) - 1 > ndim) { stop_no_call("Cannot index past dimension ", ndim, ".") } } # find common ndraws for the ndraws of two rvars to be broadcast to ndraws2_common <- function(ndraws_x, ndraws_y) { if (ndraws_x == 1) { ndraws_y } else if (ndraws_y == 1) { ndraws_x } else if (ndraws_x == ndraws_y) { ndraws_x } else { stop_no_call( "Random variables have different number of draws (", ndraws_x, " and ", ndraws_y, ") and cannot be used together." ) } } # find common nchains for the nchains of two rvars to be set to # nchains_x or nchains_y may be NULL to indicate they are constants # and take the nchains of the other nchains2_common <- function(nchains_x, nchains_y) { # constants should give nchains of NULL for input to this function # so they are treated as having any number of chains if (is.null(nchains_x)) { nchains_y } else if (is.null(nchains_y)) { nchains_x } else if (nchains_x == nchains_y) { nchains_x } else { warn_merge_chains("match") 1L } } # check that the given number of chains is compatible with the given number of draws check_nchains_compat_with_ndraws <- function(nchains, ndraws) { # except with constants, nchains must divide the number of draws if (ndraws != 1 && isTRUE(ndraws %% nchains != 0)) { stop_no_call("Number of chains does not divide the number of draws.") } if (nchains < 1) { stop_no_call("Number of chains must be >= 1") } } # given two rvars, conform their number of chains # so they can be used together (or throw an error if they can't be) conform_rvar_nchains <- function(rvars) { # find the number of chains to use, treating constants as having any number of chains nchains_or_null <- lapply(rvars, function(x) if (ndraws(x) == 1) NULL else nchains(x)) .nchains <- Reduce(nchains2_common, nchains_or_null) %||% 1L for (i in seq_along(rvars)) { nchains_rvar(rvars[[i]]) <- .nchains } rvars } # given two rvars, conform their number of draws and chains # so they can be used together (or throw an error if they can't be) # @param keep_constants keep constants as 1-draw rvars conform_rvar_ndraws_nchains <- function(rvars, keep_constants = FALSE) { rvars <- conform_rvar_nchains(rvars) # broadcast to a common number of chains. If keep_constants = TRUE, # constants will not be broadcast. .ndraws = Reduce(ndraws2_common, lapply(rvars, ndraws)) for (i in seq_along(rvars)) { rvars[[i]] <- broadcast_draws(rvars[[i]], .ndraws, keep_constants) } rvars } # Check that the first rvar can be conformed to the dimensions of the second, # ignoring 1s check_rvar_dims_first <- function(x, y) { x_dim <- dim(x) x_dim_dropped <- as.integer(x_dim[x_dim != 1]) y_dim <- dim(y) y_dim_dropped <- as.integer(y_dim[y_dim != 1]) if (length(x_dim_dropped) == 0) { # x can be treated as scalar, do so dim(x) <- rep(1, length(dim(y))) } else if (identical(x_dim_dropped, y_dim_dropped)) { dim(x) <- dim(y) } else { stop_no_call("Cannot assign an rvar with dimension ", paste0(x_dim, collapse = ","), " to an rvar with dimension ", paste0(y_dim, collapse = ",")) } x } # helpers: arrays/lists ----------------------------------------------------------------- # convert into a list of draws for applying a function draw-wise list_of_draws <- function(x) { lapply(apply(draws_of(x), 1, list), `[[`, 1) } dim2_common <- function(dim_x, dim_y) { # find common dim for two arrays to be broadcast to ndim_x <- length(dim_x) ndim_y <- length(dim_y) if (ndim_x < ndim_y) { dim_x <- c(dim_x, rep(1, ndim_y - ndim_x)) } else { dim_y <- c(dim_y, rep(1, ndim_x - ndim_y)) } pmax(dim_x, dim_y) } dim_common <- function(dims) { Reduce(dim2_common, dims) } broadcast_array <- function(x, dim, broadcast_scalars = TRUE) { if (!broadcast_scalars && length(x) == 1) { # quick exit: not broadcasting scalars; return them as vectors dim(x) <- NULL return(x) } current_dim <- dim(x) current_dimnames <- dimnames(x) if (length(current_dim) < length(dim)) { # add dimensions of size 1 as necessary so we can broadcast those new_dim <- seq(length(current_dim) + 1, length(dim)) current_dim[new_dim] <- 1 dim(x) <- current_dim if (!is.null(current_dimnames)) { current_dimnames[new_dim] <- list(NULL) dimnames(x) <- current_dimnames } } else if (length(current_dim) > length(dim)) { stop_no_call( "Cannot broadcast array of shape [", paste(current_dim, collapse = ","), "] ", "to array of shape [", paste(dim, collapse = ","), "]:\n", "Desired shape has fewer dimensions than existing array." ) } dim_to_broadcast = which(current_dim != dim) if (length(dim_to_broadcast) == 0) { # quick exit: already has desired dim or just needed extra dims on the end return(x) } if (any(current_dim[dim_to_broadcast] != 1)) { stop_no_call( "Cannot broadcast array of shape [", paste(current_dim, collapse = ","), "] ", "to array of shape [", paste(dim, collapse = ","), "]:\n", "All dimensions must be 1 or equal." ) } # move the dims we aren't broadcasting to the front so they are recycled properly perm <- c(seq_along(dim)[-dim_to_broadcast], dim_to_broadcast) # broadcast the other dims x <- array(aperm(x, perm), dim[perm]) # move dims back to their original order x <- aperm(x, order(perm)) if (!is.null(current_dimnames)) { # restore any dimnames that we did not have to broadcast dim_to_restore <- current_dim == dim dimnames(x)[dim_to_restore] <- current_dimnames[dim_to_restore] } x } # broadcast the draws dimension of an rvar to the requested size broadcast_draws <- function(x, .ndraws, keep_constants = FALSE) { ndraws_x = ndraws(x) if ( (ndraws_x == 1 && keep_constants) || (ndraws_x == .ndraws) ) { x } else { draws <- draws_of(x) new_dim <- dim(draws) new_dim[1] <- .ndraws new_rvar(broadcast_array(draws, new_dim), .nchains = nchains(x)) } } # flatten dimensions and names of an array flatten_array = function(x, x_name = NULL) { # determine new dimension names in the form x,y,z # start with numeric names dimname_lists = lapply(dim(x), seq_len) .dimnames = dimnames(x) if (!is.null(.dimnames)) { # where character names are provided, use those instead of the numeric names dimname_lists = lapply(seq_along(dimname_lists), function(i) .dimnames[[i]] %||% dimname_lists[[i]]) } # expand out the dimname lists into the appropriate combinations and assemble into new names dimname_grid <- expand.grid(dimname_lists) new_names <- apply(dimname_grid, 1, paste0, collapse = ",") dim(x) <- prod(dim(x)) # update variable names if (is.null(x_name)) { # no base name for x provided, just use index names names(x) <- new_names } else if (length(x) > 1) { # rename the variables with their indices in brackets names(x) <- paste0(x_name, "[", new_names %||% seq_along(x), "]") } else { # just one variable, use the provided base name names(x) <- x_name } x } #' copy the dimension names (and name of the dimension) from dimension src_i #' in array src to dimension dst_i in array dst #' @noRd copy_dimnames <- function(src, src_i, dst, dst_i) { if (is.null(dimnames(dst))) { if (is.null(dimnames(src))) { return(dst) } dimnames(dst) <- list(NULL) } if (is.null(dimnames(src))) { dimnames(src) <- list(NULL) } if (is.null(names(dimnames(src)))) { names(dimnames(src)) <- rep("", length(dim(src))) } dimnames(dst)[dst_i] <- dimnames(src)[src_i] names(dimnames(dst))[dst_i] <- names(dimnames(src))[src_i] names(dimnames(dst))[is.na(names(dimnames(dst)))] <- "" dst_dimnames <- names(dimnames(dst)) empty_names <- is.na(dst_dimnames) | dst_dimnames == "" if (all(empty_names)) { names(dimnames(dst)) <- NULL } dst } #' Drop the chain dimension from an array (presumed to be the second dim) #' @noRd drop_chain_dim <- function(x) { if (length(x) == 0) { # quick exit: NULL input dim(x) <- c(1,0) return(x) } x_dim <- dim(x) if (length(x_dim) < 2) { stop_no_call("Cannot use an array of dimension less than 2 when with_chains equals TRUE") } out <- x dim(out) <- c(x_dim[[1]] * x_dim[[2]], x_dim[-c(1,2)]) x_dim_i <- seq_along(x_dim)[-c(1,2)] out <- copy_dimnames(x, x_dim_i, out, x_dim_i - 1) out } #' Clean up the dimensions of an array of draws. Ensures that dim and dimnames #' are set, that the array has at least two dimensions (first one is draws), etc. #' @noRd cleanup_draw_dims <- function(x) { if (length(x) == 0) { # canonical NULL rvar is 1 draw of nothing # this ensures that (e.g.) extending a null rvar # with x[1] = something works. dim(x) <- c(1, 0) } else if (length(dim(x)) <= 1) { # 1d vectors get treated as a single variable dim(x) <- c(length(x), 1) } # ensure dimnames is set (makes comparison easier for tests) if (length(dimnames(x)) == 0) { dimnames(x) <- list(NULL) } # ensure we have an index for draws if (length(rownames(x)) == 0) { rownames(x) <- as.character(seq_rows(x)) } x } # helpers: applying functions over rvars ---------------------------------- # apply a summary function within each draw of the rvar (dropping other dimensions) # summarise_rvar_within_draws_via_matrix should be used instead of this function # if a faster implementation of .f is available in matrix form (e.g. functions # from matrixStats); otherwise this function can be used. summarise_rvar_within_draws <- function(x, .f, ..., .transpose = FALSE, .when_empty = .f(numeric(0))) { draws <- draws_of(x) dim <- dim(draws) if (!length(x)) { # x is a NULL rvar, need to return base value for this summary function as_rvar(.when_empty) } else { draws <- apply(draws, 1, .f, ...) if (.transpose) draws <- t(draws) new_rvar(draws, .nchains = nchains(x)) } } #' apply a summary function within each draw of the rvar (dropping other dimensions) #' by first collapsing dimensions into columns of the draws matrix #' (so that .f can be a rowXXX() function) #' @param x an rvar #' @param .f a function that takes a matrix and summarises its rows, like rowMeans #' @param ... arguments passed to `.f` #' @param .when_empty the value to return when `x` has length 0 (e.g. is NULL) #' @noRd summarise_rvar_within_draws_via_matrix <- function(x, .f, ...) { .length <- length(x) if (!.length) { x <- rvar() } dim(x) <- .length new_rvar(.f(draws_of(x), ...), .nchains = nchains(x)) } # apply vectorized function to an rvar's draws rvar_apply_vec_fun <- function(.f, x, ...) { draws_of(x) <- .f(draws_of(x), ...) x } # apply a summary function across draws of the rvar (i.e., by each element) summarise_rvar_by_element <- function(x, .f, ...) { if (length(x) == 1) { # this ensures that scalar rvars are summarized to vectors rather than # to matrices with one column .f(draws_of(x), ...) } else { draws <- draws_of(x) dim <- dim(draws) apply(draws, seq_along(dim)[-1], .f, ...) } } #' apply a summary function across draws of the rvar (i.e., by each element) #' by first collapsing dimensions into columns of the draws matrix, applying the #' function, then restoring dimensions (so that .f can be a colXXX() function) #' @param x an rvar #' @param .f a function that takes a matrix and summarises its columns, like colMeans #' @param .extra_dim extra dims added by `.f` to the output, e.g. in the case of #' matrixStats::colRanges this is `2` #' @param .extra_dimnames extra dimension names for dims added by `.f` to the output #' @param ... arguments passed to `.f` #' @noRd summarise_rvar_by_element_via_matrix <- function(x, .f, .extra_dim = NULL, .extra_dimnames = NULL, ...) { .dim <- dim(x) .dimnames <- dimnames(x) .length <- length(x) dim(x) <- .length x = .f(draws_of(x), ...) if (is.null(.extra_dim) && length(.dim) <= 1) { # this ensures that vector rvars are summarized to vectors rather than # to arrays with one dimension dim(x) <- NULL names(x) <- .dimnames[[1]] } else if (isTRUE(.dim == 1)) { # scalars with extra dimensions should just return vectors dim(x) <- NULL names(x) <- .extra_dimnames[[1]] } else { dim(x) <- c(.extra_dim, .dim) dimnames(x) <- c(.extra_dimnames, .dimnames) } x } # apply a summary function across draws of the rvar (i.e., by each element) # including a chain dimension in the array passed to .f summarise_rvar_by_element_with_chains <- function(x, .f, ...) { draws <- draws_of(x, with_chains = TRUE) dim <- dim(draws) apply(draws, seq_along(dim)[-c(1,2)], .f, ...) } posterior/R/as_draws_df.R0000644000175000017500000001512414165314655015247 0ustar nileshnilesh#' The `draws_df` format #' #' @name draws_df #' @family formats #' #' @templateVar draws_format draws_df #' @templateVar base_class class(tibble::tibble()) #' @template draws_format-skeleton #' @template args-format-nchains #' #' @details Objects of class `"draws_df"` are [tibble][tibble::tibble] data #' frames. They have one column per variable as well as additional metadata #' columns `".iteration"`, `".chain"`, and `".draw"`. The difference between #' the `".iteration"` and `".draw"` columns is that the former is relative to #' the MCMC chain while the latter ignores the chain information and has all #' unique values. See **Examples**. #' #' If a `data.frame`-like object is supplied to `as_draws_df` that contains #' columns named `".iteration"` or `".chain"`, they will be treated as #' iteration and chain indices, respectively. See **Examples**. #' #' @examples #' #' # the difference between iteration and draw is clearer when contrasting #' # the head and tail of the data frame #' print(head(x1), reserved = TRUE, max_variables = 2) #' print(tail(x1), reserved = TRUE, max_variables = 2) #' #' # manually supply chain information #' xnew <- data.frame(mu = rnorm(10), .chain = rep(1:2, each = 5)) #' xnew <- as_draws_df(xnew) #' print(xnew) #' NULL #' @rdname draws_df #' @export as_draws_df <- function(x, ...) { UseMethod("as_draws_df") } #' @rdname draws_df #' @export as_draws_df.default <- function(x, ...) { x <- as_draws(x) as_draws_df(x, ...) } #' @rdname draws_df #' @export as_draws_df.data.frame <- function(x, ...) { .as_draws_df(x) } #' @rdname draws_df #' @export as_draws_df.draws_df <- function(x, ...) { x } #' @rdname draws_df #' @export as_draws_df.draws_matrix <- function(x, ...) { if (ndraws(x) == 0L) { return(empty_draws_df(variables(x))) } iteration_ids <- iteration_ids(x) chain_ids <- chain_ids(x) attr(x, "nchains") <- NULL x <- tibble::as_tibble(unclass(x)) x[[".chain"]] <- rep(chain_ids, each = max(iteration_ids)) x[[".iteration"]] <- rep(iteration_ids, max(chain_ids)) x[[".draw"]] <- seq_len(nrow(x)) class(x) <- class_draws_df() x } #' @rdname draws_df #' @export as_draws_df.draws_array <- function(x, ...) { if (ndraws(x) == 0L) { return(empty_draws_df(variables(x))) } x <- as_draws_matrix(x) as_draws_df(x) } #' @rdname draws_df #' @export as_draws_df.draws_list <- function(x, ...) { if (ndraws(x) == 0L) { return(empty_draws_df(variables(x))) } iteration_ids <- iteration_ids(x) chain_ids <- chain_ids(x) vars <- names(x[[1L]]) x <- do.call(rbind.data.frame, x) colnames(x) <- vars x <- tibble::as_tibble(x) x[[".chain"]] <- rep(chain_ids, each = max(iteration_ids)) x[[".iteration"]] <- rep(iteration_ids, max(chain_ids)) x[[".draw"]] <- seq_len(nrow(x)) class(x) <- class_draws_df() x } #' @rdname draws_df #' @export as_draws_df.draws_rvars <- function(x, ...) { as_draws_df(as_draws_array(x), ...) } #' @rdname draws_df #' @export as_draws_df.mcmc <- function(x, ...) { as_draws_df(as_draws_matrix(x), ...) } #' @rdname draws_df #' @export as_draws_df.mcmc.list <- function(x, ...) { as_draws_df(as_draws_array(x), ...) } #' Convert any \R object into a `draws_df` object #' @param x An \R object. #' @noRd .as_draws_df <- function(x) { x <- tibble::as_tibble(x, .name_repair = "unique") # prepare iteration and chain indices has_iteration_column <- ".iteration" %in% names(x) if (has_iteration_column) { iteration_ids <- x[[".iteration"]] x[[".iteration"]] <- NULL } else { iteration_ids <- seq_len(nrow(x)) } has_chain_column <- ".chain" %in% names(x) if (has_chain_column) { chain_ids <- x[[".chain"]] x[[".chain"]] <- NULL } else { chain_ids <- rep(1L, nrow(x)) } # drop draw indices since they are regenerated below x[[".draw"]] <- NULL # add reserved variables to the data check_new_variables(names(x)) x[[".chain"]] <- chain_ids x[[".iteration"]] <- iteration_ids if (has_iteration_column || has_chain_column) { x[[".chain"]] <- repair_chain_ids(x[[".chain"]]) x[[".iteration"]] <- repair_iteration_ids(x[[".iteration"]], x[[".chain"]]) } x[[".draw"]] <- compute_draw_ids(x[[".chain"]], x[[".iteration"]]) class(x) <- class_draws_df() x } #' @rdname draws_df #' @export draws_df <- function(..., .nchains = 1) { out <- validate_draws_per_variable(...) .nchains <- as_one_integer(.nchains) if (.nchains < 1) { stop_no_call("Number of chains must be positive.") } ndraws <- length(out[[1]]) if (ndraws %% .nchains != 0) { stop_no_call("Number of chains does not divide the number of draws.") } niterations <- ndraws %/% .nchains out <- as.data.frame(out, optional = TRUE) out[[".iteration"]] <- rep(seq_len(niterations), .nchains) out[[".chain"]] <- rep(seq_len(.nchains), each = niterations) as_draws_df(out) } class_draws_df <- function() { # inherits for tibbles c("draws_df", "draws", "tbl_df", "tbl", "data.frame") } #' @rdname draws_df #' @export is_draws_df <- function(x) { inherits(x, "draws_df") } # is an object looking like a 'draws_df' object? is_draws_df_like <- function(x) { is.data.frame(x) } #' @export `[.draws_df` <- function(x, i, j, drop = FALSE, ..., reserved = FALSE) { reserved <- as_one_logical(reserved) # draws_df is a tibble so drop = FALSE by default anyway out <- NextMethod("[") if (reserved) { reserved_vars <- all_reserved_variables(x) reserved_vars <- setdiff(reserved_vars, names(out)) out[, reserved_vars] <- NextMethod("[", j = reserved_vars, drop = FALSE) } else { out <- drop_draws_class_if_metadata_removed(out, warn = TRUE) } out } # This generic is not exported here as {dplyr} is only in Suggests, so # we must export it in .onLoad() for compatibility with r < 3.6. See # help("s3_register", package = "vctrs") for more information. dplyr_reconstruct.draws_df <- function(data, template) { data <- NextMethod("dplyr_reconstruct") data <- drop_draws_class_if_metadata_removed(data, warn = FALSE) data } # drop "draws_df" and "draws" classes if metadata columns were removed # from the data frame drop_draws_class_if_metadata_removed <- function(x, warn = TRUE) { if (!all(reserved_df_variables() %in% names(x))) { if (warn) warning_no_call("Dropping 'draws_df' class as required metadata was removed.") class(x) <- setdiff(class(x), c("draws_df", "draws")) } x } # create an empty draws_df object empty_draws_df <- function(variables = character(0)) { assert_character(variables, null.ok = TRUE) x <- tibble::tibble() x[variables] <- numeric(0) x[c(".chain", ".iteration", ".draw")] <- integer(0) class(x) <- class_draws_df() x } posterior/R/rvar-slice.R0000755000175000017500000001613214165314652015042 0ustar nileshnilesh#' @importFrom rlang eval_tidy is_missing missing_arg dots_list #' @export `[[.rvar` <- function(x, i, ...) { index <- check_rvar_yank_index(x, i, ...) if (length(index) == 1) { # single element selection => collapse the dims so we can select directly using i .dim = dim(x) if (length(.dim) != 1) { # we only collapse dims if necessary since this will drop dimnames (which # would prevent single-element by-name selection for 1d rvars) dim(x) <- prod(.dim) } .draws <- draws_of(x)[, i, drop = FALSE] dimnames(.draws) <- NULL out <- new_rvar(.draws, .nchains = nchains(x)) } else if (length(index) == length(dim(x))) { # multiple element selection => must have exactly the right number of dims .draws <- eval_tidy(expr(draws_of(x)[, !!!index, drop = FALSE])) # must do drop manually in case the draws dimension has only 1 draw dim(.draws) <- c(ndraws(x), 1) out <- new_rvar(.draws, .nchains = nchains(x)) } else { stop_no_call("subscript out of bounds") } out } #' @export `[[<-.rvar` <- function(x, i, ..., value) { value <- vec_cast(value, x) c(x, value) %<-% conform_rvar_ndraws_nchains(list(x, value)) value <- check_rvar_dims_first(value, new_rvar(0)) index <- check_rvar_yank_index(x, i, ...) if (length(index) == 1) { .dim = dim(x) if (length(.dim) == 1 && i > length(x)) { # unidimensional indexing allows array extension; extend the array # then do the assignment x <- x[seq_len(max(i, na.rm = TRUE))] draws_of(x)[, i] <- draws_of(value) } else { # single element selection => collapse the dims so we can select directly using i .dimnames = dimnames(draws_of(x)) # to restore later if (length(.dim) != 1) { # we only collapse dims if necessary since this will drop dimnames (which # would prevent single-element by-name selection for 1d rvars) dim(x) <- prod(.dim) } draws_of(x)[, i] <- draws_of(value) dim(x) <- .dim dimnames(draws_of(x)) <- .dimnames } } else if (length(index) == length(dim(x))) { # multiple element selection => must have exactly the right number of dims x <- eval_tidy(expr({ draws_of(x)[, !!!index] <- draws_of(value) x })) } else { stop_no_call("subscript out of bounds") } x } #' @importFrom rlang dots_list eval_tidy is_missing missing_arg expr #' @export `[.rvar` <- function(x, ..., drop = FALSE) { check_rvar_subset_indices(x, ...) .draws = draws_of(x) .dim = dim(.draws) # clean up the indices: because we have to index using the multi-index # notation x[,...] (to account for draws) and this notation has slightly # different semantics for NAs from the way that x[i] works, have to do a bit # of translation here index = dots_list(..., .ignore_empty = "none", .preserve_empty = TRUE) for (i in seq_along(index)) { if (is.numeric(index[[i]])) { # numeric indices outside the range of the corresponding dimension # should create NAs; but array indexing doesn't do this (it throws # an error), so we adjust the indices to do so. dim_i_length <- if (i == 1 && length(index) == 1) { # for x[i] style indexing of multidimensional arrays we will flatten # the array before indexing, so the max of the dim length will be # the length of x length(x) } else { .dim[[i + 1]] } index[[i]][index[[i]] > dim_i_length] <- NA_integer_ } } if (length(index) == 1) { # indexing by a single dimension, (could be numerical indexing along one # dimension --- even for multidimensional arrays; logical indexing; or matrix indexing) if (is.matrix(index[[1]]) && ncol(index[[1]]) == length(.dim) - 1) { # matrix-based indexing, like x[cbind(2,1,2)] # => translate matrix-based indices into unidimensional indices index[[1]] <- matrix_to_index(index[[1]], .dim[-1]) } if (is_missing(index[[1]])) { # if we only have one index and it is missing entirely, the call must # have been for x[], which actually means no index at all index <- list() } else if (length(dim(.draws)) > 2) { # draws have > 2 dims => array has > 1 dimension => must flatten array so # that the index can be applied along all the elements of the array dim(.draws) <- c(dim(.draws)[[1]], length(x)) } } else if (length(index) < length(dim(.draws)) - 1) { # fill in final indices with missing arguments index[seq(length(index) + 1, length(dim(.draws)) - 1)] = list(missing_arg()) } x <- eval_tidy(expr( new_rvar(.draws[, !!!index, drop = FALSE], .nchains = nchains(x)) )) if (drop) { .dim <- dim(x) if (length(.dim) > 1) { # with exactly 1 dimension left we don't want to drop anything # (otherwise names get lost), so only do this with > 1 dimension keep_dim <- .dim != 1 .dimnames <- dimnames(x) dim(x) <- .dim[keep_dim] # for comparison / testing, ensure if no dimnames have names that we # actually have those names be NULL (rather than just empty strings) new_dimnames <- .dimnames[keep_dim] if (all(names(new_dimnames) == "")) names(new_dimnames) <- NULL dimnames(x) <- new_dimnames } } x } #' @export `[<-.rvar` <- function(x, i, ..., value) { if (missing(i)) i = missing_arg() if (length(dim(x)) == 1 && !missing(i) && any(i > length(x), na.rm = TRUE)) { # unidimensional indexing allows array extension; extend the array # before we do the assignment x <- x[seq_len(max(i, na.rm = TRUE))] } value <- vec_cast(value, x) c(x, value) %<-% conform_rvar_ndraws_nchains(list(x, value)) if (missing(...)) { # index over entire array: flatten array so that the index # can be applied along all the elements of the array, then invert after assignment original_dim <- dim(draws_of(x)) original_dimnames <- dimnames(draws_of(x)) if (is.matrix(i) && ncol(i) == length(original_dim) - 1) { # matrix-based indexing, like x[cbind(2,1,2)] <- y # => translate matrix-based indices into unidimensional indices i <- matrix_to_index(i, original_dim[-1]) } #flatten and assign dim(x) <- length(x) draws_of(x)[,i] <- draws_of(value) # unflatten and restore dimnames dim(draws_of(x)) <- original_dim dimnames(draws_of(x)) <- original_dimnames } else { draws_of(x)[,i,...] <- draws_of(value) } x } # slicing helpers --------------------------------------------------------- # Given m, a matrix with ncol(m) == length(dim), where each row specifies the # index of a single cell from an array of shape == dim, return a vector of # length nrow(m) giving the unidimensional indices of that array corresponding # to the cells specified by each row in m # e.g. if we have an array x with dim(x) = c(2,3,4), we might want to # translate an index of style x[cbind(2,1,2)] into x[i] so that we can index # index x using the single index i instead of cbind(2,1,2). # matrix_to_index(cbind(2,1,2), dim(x)) does that translation. matrix_to_index <- function(m, dim) { cumdim <- cumprod(c(1, dim[-length(dim)])) as.vector((m - 1) %*% cumdim + 1) } posterior/R/as_draws_rvars.R0000755000175000017500000001655014165314652016017 0ustar nileshnilesh#' The `draws_rvars` format #' #' @name draws_rvars #' @family formats #' #' @templateVar draws_format draws_rvars #' @templateVar base_class "list" #' @template draws_format-skeleton #' @template args-format-nchains #' #' @details Objects of class `"draws_rvars"` are lists of [`rvar`] objects. #' See **Examples**. #' NULL #' @rdname draws_rvars #' @export as_draws_rvars <- function(x, ...) { UseMethod("as_draws_rvars") } #' @rdname draws_rvars #' @export as_draws_rvars.default <- function(x, ...) { x <- as_draws(x) as_draws_rvars(x, ...) } #' @rdname draws_rvars #' @export as_draws_rvars.draws_rvars <- function(x, ...) { x } #' @rdname draws_rvars #' @export as_draws_rvars.list <- function(x, ...) { if (all(vapply(x, is_rvar, logical(1)))) { .as_draws_rvars(x, ...) } else { NextMethod() } } #' @export as_draws_rvars.rvar <- function(x, ...) { .as_draws_rvars(list(x = x), ...) } #' @rdname draws_rvars #' @export as_draws_rvars.draws_matrix <- function(x, ...) { if (ndraws(x) == 0) { return(empty_draws_rvars(variables(x))) } # split x[y,z] names into base name and indices vars_indices <- strsplit(variables(x), "(\\[|\\])") vars <- sapply(vars_indices, `[[`, 1) # pull out each var into its own rvar var_names <- unique(vars) rvars_list <- lapply(var_names, function (var) { var_i <- vars == var # reset class here as otherwise the draws arrays in the output rvars # have type draws_matrix, which makes inspecting them hard var_matrix <- unclass(x[, var_i, drop = FALSE]) attr(var_matrix, "nchains") <- NULL if (ncol(var_matrix) == 1) { # single variable, no indices out <- rvar(var_matrix) dimnames(out) <- NULL } else { # variable with indices => we need to reshape the array # basically, we're going to do a bunch of work up front to figure out # a single array slice that does most of the work for us. # first, pull out the list of indices into a data frame # where each column is an index variable indices <- sapply(vars_indices[var_i], `[[`, 2) indices <- as.data.frame(do.call(rbind, strsplit(indices, ",")), stringsAsFactors = FALSE) unique_indices <- vector("list", length(indices)) .dimnames <- vector("list", length(indices)) names(unique_indices) <- names(indices) for (i in seq_along(indices)) { numeric_index <- suppressWarnings(as.numeric(indices[[i]])) if (!anyNA(numeric_index) && rlang::is_integerish(numeric_index)) { # for integer indices, we need to convert them to integers # so that we can sort them in numerical order (not string order) if (min(numeric_index) >= 1) { # integer indices >= 1 are forced to lower bound of 1 + no dimnames indices[[i]] <- as.integer(numeric_index) unique_indices[[i]] <- seq.int(1, max(numeric_index)) } else { # indices with values < 1 are sorted but otherwise left as-is, and will create dimnames indices[[i]] <- numeric_index unique_indices[[i]] <- sort(unique(numeric_index)) .dimnames[[i]] <- unique_indices[[i]] } } else { # we convert non-numeric indices to factors so that we can force them # to be ordered as they appear in the data (rather than in alphabetical order) factor_levels <- unique(indices[[i]]) indices[[i]] <- factor(indices[[i]], levels = factor_levels) # these aren't sorted so they appear in original order unique_indices[[i]] <- factor(factor_levels, levels = factor_levels) .dimnames[[i]] <- unique_indices[[i]] } } # sort indices and fill in missing indices as NA to ensure # (1) even if the order of the variables is something weird (like the # column for x[2,2] comes before x[1,1] in the matrix) the result # places those columns in the correct cells of the array # (2) if some combination of indices is missing (say x[2,1] isn't # in the input) that cell in the array gets an NA # Use expand.grid to get all cells in output array. We reverse indices # here because it helps us do the sort after the merge, where # we need to sort in reverse order of the indices (because # the value of the last index should move slowest) all_indices <- expand.grid(rev(unique_indices)) # merge with all.x = TRUE (left join) to fill in missing cells with NA indices <- merge(all_indices, cbind(indices, index = seq_len(nrow(indices))), all.x = TRUE, sort = FALSE) # need to do the sort manually after merge because when sort = TRUE, merge # sorts factors as if they were strings, and we need factors to be sorted as factors indices <- indices[do.call(order, as.list(indices[, -ncol(indices), drop = FALSE])),] # re-sort the array and fill in missing cells with NA var_matrix <- var_matrix[, indices$index, drop = FALSE] # convert to rvar and adjust dimensions out <- rvar(var_matrix) dim(out) <- unname(lengths(unique_indices)) dimnames(out) <- .dimnames } out }) names(rvars_list) <- var_names out <- .as_draws_rvars(rvars_list, ...) .nchains <- nchains(x) for (i in seq_along(out)) { nchains_rvar(out[[i]]) <- .nchains } out } #' @rdname draws_rvars #' @export as_draws_rvars.draws_array <- function(x, ...) { as_draws_rvars(as_draws_matrix(x), ...) } #' @rdname draws_rvars #' @export as_draws_rvars.draws_df <- as_draws_rvars.draws_array #' @rdname draws_rvars #' @export as_draws_rvars.draws_list <- as_draws_rvars.draws_array #' @rdname draws_rvars #' @export as_draws_rvars.mcmc <- function(x, ...) { as_draws_rvars(as_draws_matrix(x), ...) } #' @rdname draws_rvars #' @export as_draws_rvars.mcmc.list <- function(x, ...) { as_draws_rvars(as_draws_array(x), ...) } # try to convert any R object into a 'draws_rvars' object .as_draws_rvars <- function(x, ...) { x <- as.list(x) # convert all elements to rvars x <- lapply(x, as_rvar) # replace blank variable names with defaults if (is.null(names(x))) { names(x) <- default_variables(length(x)) } else { blank_names <- nchar(names(x)) == 0 names(x)[blank_names] <- default_variables(length(x))[blank_names] } check_new_variables(names(x)) x <- conform_rvar_ndraws_nchains(x) class(x) <- class_draws_rvars() x } #' @rdname draws_rvars #' @export draws_rvars <- function(..., .nchains = 1) { out <- lapply(list(...), function(x) { if (is_rvar(x)) x else rvar(x, nchains = .nchains) }) if (!rlang::is_named(out)) { stop_no_call("All variables must be named.") } .as_draws_rvars(out) } class_draws_rvars <- function() { c("draws_rvars", "draws", "list") } #' @rdname draws_rvars #' @export is_draws_rvars <- function(x) { inherits(x, "draws_rvars") } # is an object looking like a 'draws_rvars' object? is_draws_rvars_like <- function(x) { is.list(x) && all(sapply(x, is_rvar)) } #' @export `[.draws_rvars` <- function(x, i, j, ..., drop = FALSE) { out <- NextMethod("[") class(out) <- class(x) out } # create an empty draws_rvars object empty_draws_rvars <- function(variables = character(0), nchains = 0) { assert_character(variables, null.ok = TRUE) assert_number(nchains, lower = 0) out <- named_list(variables, rvar()) class(out) <- class_draws_rvars() out } posterior/R/as_draws_list.R0000644000175000017500000000754114165314652015632 0ustar nileshnilesh#' The `draws_list` format #' #' @name draws_list #' @family formats #' #' @templateVar draws_format draws_list #' @templateVar base_class "list" #' @template draws_format-skeleton #' @template args-format-nchains #' #' @details Objects of class `"draws_list"` are lists with one element per MCMC #' chain. Each of these elements is itself a named list of numeric vectors #' with one vector per variable. The length of each vector is equal to the #' number of saved iterations per chain. See **Examples**. #' NULL #' @rdname draws_list #' @export as_draws_list <- function(x, ...) { UseMethod("as_draws_list") } #' @rdname draws_list #' @export as_draws_list.default <- function(x, ...) { x <- as_draws(x) as_draws_list(x, ...) } #' @rdname draws_list #' @export as_draws_list.draws_list <- function(x, ...) { x } #' @rdname draws_list #' @export as_draws_list.draws_matrix <- function(x, ...) { x <- as_draws_df(x) as_draws_list(x, ...) } #' @rdname draws_list #' @export as_draws_list.draws_array <- function(x, ...) { x <- as_draws_df(x) as_draws_list(x, ...) } #' @rdname draws_list #' @export as_draws_list.draws_df <- function(x, ...) { if (ndraws(x) == 0) { return(empty_draws_list(variables(x))) } out <- named_list(chain_ids(x)) x <- x[order(x$.draw), ] for (i in seq_along(out)) { out[[i]] <- subset(x, chain = i) out[[i]] <- remove_reserved_df_variables(out[[i]]) out[[i]] <- as.list(out[[i]]) } class(out) <- class_draws_list() out } #' @rdname draws_list #' @export as_draws_list.draws_rvars <- function(x, ...) { as_draws_list(as_draws_array(x), ...) } #' @rdname draws_list #' @export as_draws_list.mcmc <- function(x, ...) { as_draws_list(as_draws_matrix(x), ...) } #' @rdname draws_list #' @export as_draws_list.mcmc.list <- function(x, ...) { as_draws_list(as_draws_array(x), ...) } # try to convert any R object into a 'draws_list' object .as_draws_list <- function(x) { x <- as.list(x) # check heuristically if a list of a single chain is supplied if (is.numeric(x[[1]])) { x <- list(x) } if (any(!ulapply(x, is.list))) { stop_no_call("All list elements must be lists themselves.") } if (length(unique(lengths(x))) != 1L) { stop_no_call("All list elements must have the same length.") } if (is.null(names(x[[1]]))) { # no variable names provided; using default names variables <- default_variables(length(x[[1]])) for (i in seq_along(x)) { names(x[[i]]) <- variables } } variables <- names(x[[1]]) check_new_variables(variables) niterations <- length(x[[1]][[1]]) for (i in seq_along(x)) { if (!all(names(x[[i]]) == variables)) { stop_no_call("Variables in all chains must have the same names.") } for (j in seq_along(x[[i]])) { if (length(x[[i]][[j]]) != niterations) { stop_no_call("All variables in all chains must have the same length.") } } } names(x) <- as.character(seq_along(x)) class(x) <- class_draws_list() x } #' @rdname draws_list #' @export draws_list <- function(..., .nchains = 1) { out <- draws_df(..., .nchains = .nchains) as_draws_list(out) } class_draws_list <- function() { c("draws_list", "draws", "list") } #' @rdname draws_list #' @export is_draws_list <- function(x) { inherits(x, "draws_list") } # is an object looking like a 'draws_list' object? is_draws_list_like <- function(x) { # TODO: add more sophisticated checks is.list(x) } #' @export `[.draws_list` <- function(x, i) { out <- NextMethod("[") class(out) <- class(x) out } # create an empty draws_list object empty_draws_list <- function(variables = character(0), nchains = 0) { assert_character(variables, null.ok = TRUE) assert_number(nchains, lower = 0) out <- named_list(seq_len(nchains)) for (i in seq_along(out)) { out[[i]] <- named_list(variables, numeric(0)) } class(out) <- class_draws_list() out } posterior/R/rename_variables.R0000755000175000017500000000416414165314652016274 0ustar nileshnilesh#' Rename variables in `draws` objects #' #' Rename variables in a [`draws`] object. #' #' @param .x (draws) A [`draws`] object. #' @param ... One or more expressions, separated by commas, indicating the #' variables to rename. The variable names can be unquoted #' (`new_name = old_name`) or quoted (`"new_name" = "old_name"`). For non-scalar #' variables, all elements can be renamed together (`"new_name" = "old_name"`) #' or they can be renamed individually (`"new_name[1]" = "old_name[1]"`). #' #' @return #' Returns a [`draws`] object of the same format as `.x`, with variables renamed #' according to the expressions provided in `...`. #' #' @seealso [`variables`], [`mutate_variables`] #' #' @examples #' x <- as_draws_df(example_draws()) #' variables(x) #' #' x <- rename_variables(x, mean = mu, sigma = tau) #' variables(x) #' #' x <- rename_variables(x, b = `theta[1]`) # or b = "theta[1]" #' variables(x) #' #' # rename all elements of 'theta' at once #' x <- rename_variables(x, alpha = theta) #' variables(x) #' #' @importFrom rlang quos as_name #' @export rename_variables <- function(.x, ...) { UseMethod("rename_variables") } #' @rdname rename_variables #' @export rename_variables.draws <- function(.x, ...) { old_names <- sapply(quos(...), as_name) new_names <- names(old_names) if (any(new_names == "")) { old_names_without_new_name = old_names[new_names == ""] stop_no_call( "Cannot rename a variable to an empty name.\n", "The following variables did not have a new name provided:\n", comma(old_names_without_new_name) ) } # loop over names as every old name may correspond to multiple # scalar variables if the name targets a non-scalar variable # also this allows renaming operations to be chained for (i in seq_along(old_names)) { old_names_i <- check_existing_variables(old_names[i], .x) v_regex <- paste0("^", escape_all(old_names[i])) v_indices <- sub(v_regex, "", old_names_i) new_names_i <- paste0(new_names[i], v_indices) sel <- which(variables(.x) %in% old_names_i) variables(.x)[sel] <- new_names_i } check_new_variables(variables(.x)) .x } posterior/R/as_draws_matrix.R0000644000175000017500000001264414165314655016166 0ustar nileshnilesh#' The `draws_matrix` format #' #' @name draws_matrix #' @family formats #' #' @templateVar draws_format draws_matrix #' @templateVar base_class "matrix" #' @template draws_format-skeleton #' @template args-format-nchains #' #' @details Objects of class `"draws_matrix"` are matrices (2-D arrays) with #' dimensions `"draw"` and `"variable"`. See **Examples**. #' NULL #' @rdname draws_matrix #' @export as_draws_matrix <- function(x, ...) { UseMethod("as_draws_matrix") } #' @rdname draws_matrix #' @export as_draws_matrix.default <- function(x, ...) { x <- as_draws(x) as_draws_matrix(x, ...) } #' @rdname draws_matrix #' @export as_draws_matrix.draws_matrix <- function(x, ...) { x } #' @rdname draws_matrix #' @export as_draws_matrix.draws_array <- function(x, ...) { if (ndraws(x) == 0) { return(empty_draws_matrix(variables(x), niterations(x))) } nchains <- nchains(x) old_dim <- dim(x) old_dimnames <- dimnames(x) dim(x) <- c(old_dim[1] * old_dim[2], old_dim[3]) dimnames(x) <- list( draw = as.character(seq_rows(x)), variable = old_dimnames[[3]] ) class(x) <- class_draws_matrix() attr(x, "nchains") <- nchains x } #' @rdname draws_matrix #' @export as_draws_matrix.draws_df <- function(x, ...) { if (ndraws(x) == 0) { return(empty_draws_matrix(variables(x))) } nchains <- nchains(x) draws <- x$.draw x <- remove_reserved_df_variables(x) class(x) <- class(x)[-1L] x <- .as_draws_matrix(x) rownames(x) <- draws attr(x, "nchains") <- nchains x } #' @rdname draws_matrix #' @export as_draws_matrix.draws_list <- function(x, ...) { x <- as_draws_df(x) as_draws_matrix(x, ...) } #' @rdname draws_matrix #' @export as_draws_matrix.draws_rvars <- function(x, ...) { if (ndraws(x) == 0) { return(empty_draws_matrix(variables(x))) } out <- do.call(cbind, lapply(seq_along(x), function(i) { # flatten each rvar so it only has two dimensions: draws and variables # this also collapses indices into variable names in the format "var[i,j,k,...]" x_i <- flatten_array(x[[i]], names(x)[[i]]) draws_of(x_i) })) out <- as_draws_matrix(out, ...) attr(out, "nchains") <- nchains(x) out } #' @rdname draws_matrix #' @export as_draws_matrix.mcmc <- function(x, ...) { class(x) <- "matrix" attributes(x)[c("title", "mcpar")] <- NULL .as_draws_matrix(x) } #' @rdname draws_matrix #' @export as_draws_matrix.mcmc.list <- function(x, ...) { as_draws_matrix(as_draws_array(x), ...) } # try to convert any R object into a 'draws_matrix' object .as_draws_matrix <- function(x) { .nchains <- attr(x, "nchains") %||% 1L x <- as.matrix(x) new_dimnames <- list(draw = NULL, variable = NULL) if (!is.null(dimnames(x)[[2]])) { new_dimnames[[2]] <- dimnames(x)[[2]] } else { new_dimnames[[2]] <- default_variables(NCOL(x)) } check_new_variables(new_dimnames[[2]]) new_dimnames[[1]] <- as.character(seq_rows(x)) dimnames(x) <- new_dimnames class(x) <- class_draws_matrix() attr(x, "nchains") <- .nchains x } #' @rdname draws_matrix #' @export draws_matrix <- function(..., .nchains = 1) { out <- validate_draws_per_variable(...) .nchains <- as_one_integer(.nchains) if (.nchains < 1) { stop_no_call("Number of chains must be positive.") } ndraws <- length(out[[1]]) if (ndraws %% .nchains != 0) { stop_no_call("Number of chains does not divide the number of draws.") } out <- do.call(cbind, out) attr(out, "nchains") <- .nchains as_draws_matrix(out) } class_draws_matrix <- function() { c("draws_matrix", "draws", "matrix") } #' @rdname draws_matrix #' @export is_draws_matrix <- function(x) { inherits(x, "draws_matrix") } # is an object looking like a 'draws_matrix' object? is_draws_matrix_like <- function(x) { is.matrix(x) || is.array(x) && length(dim(x)) == 2L } #' Extract parts of a `draws_matrix` object #' #' Extract parts of a `draws_matrix` object. They are strictly defined as #' matrices (draws x variable) so dropping any of the #' dimensions breaks the expected structure of the object. Accordingly, no #' dropping of dimensions is done by default even if the extracted slices are of #' length 1. If `drop` is manually set to `TRUE` and any of the dimensions is #' actually dropped, this will lead to dropping the `"draws_matrix"` class as #' well. #' #' @param x,i,j,...,drop Same as in the default extraction method but with #' `drop` being set to `FALSE` by default. #' #' @return An object of class `"draws_matrix"` unless any of the dimensions #' was dropped during the extraction. #' #' @export `[.draws_matrix` <- function(x, i, j, ..., drop = FALSE) { # TODO: allow for argument 'reserved' as in '[.draws_df' # right now this fails because NextMethod() cannot ignore arguments out <- NextMethod("[", drop = drop) if (length(dim(out)) == length(dim(x))) { class(out) <- class(x) .nchains <- nchains(x) if (missing(i)) { attr(out, "nchains") <- .nchains } else if (.nchains > 1L) { warn_merge_chains("index") } } out } #' @export variance.draws_matrix <- function(x, ...) { var(as.vector(x)) } # create an empty draws_matrix object empty_draws_matrix <- function(variables = character(0), ndraws = 0) { assert_character(variables, null.ok = TRUE) assert_number(ndraws, lower = 0) out <- matrix( numeric(0), nrow = ndraws, ncol = length(variables), dimnames = list( draw = seq_len(ndraws), variable = variables ) ) class(out) <- class_draws_matrix() out } posterior/R/thin_draws.R0000644000175000017500000000171114165314652015127 0ustar nileshnilesh#' Thin `draws` objects #' #' Thin [`draws`] objects to reduce their size and autocorrelation in the chains. #' #' @aliases thin #' @template args-methods-x #' @param thin (positive integer) The period for selecting draws. #' @template args-methods-dots #' @template return-draws #' #' @examples #' x <- example_draws() #' niterations(x) #' #' x <- thin_draws(x, thin = 5) #' niterations(x) #' #' @export thin_draws <- function(x, thin, ...) { UseMethod("thin_draws") } #' @rdname thin_draws #' @export thin_draws.draws <- function(x, thin, ...) { thin <- as_one_integer(thin) if (thin == 1L) { # no thinning requested return(x) } if (thin <= 0L) { stop_no_call("'thin' must be a positive integer.") } niterations <- niterations(x) if (thin > niterations ) { stop_no_call("'thin' must be smaller than the total number of iterations.") } iteration_ids <- seq(1, niterations, by = thin) subset_draws(x, iteration = iteration_ids) } posterior/R/rstar.R0000644000175000017500000001777614165314652014142 0ustar nileshnilesh# Copyright (C) 2020 Ben Lambert, Aki Vehtari # See LICENSE.md for more details #' Calculate R* convergence diagnostic #' #' The `rstar()` function generates a measure of convergence for MCMC draws #' based on whether it is possible to determine the Markov chain that generated #' a draw with probability greater than chance. To do so, it fits a machine #' learning classifier to a training set of MCMC draws and evaluates its #' predictive accuracy on a testing set: giving the ratio of accuracy to #' predicting a chain uniformly at random. #' #' @family diagnostics #' @param x (draws) A [`draws_df`] object or one coercible to a `draws_df` object. #' @template args-conv-split #' #' @param uncertainty (logical). Indicates whether to provide a vector of R* #' values representing uncertainty in the calculated value (if `TRUE`) or a #' single value (if `FALSE`). The default is `TRUE.` #' #' @param method (string) The machine learning classifier to use (must be #' available in the \pkg{caret} package). The default is `"rf"`, which calls #' the random forest classifier. #' #' @param hyperparameters (named list) Hyperparameter settings passed to the classifier. #' The default for the random forest classifier (`method = "rf"`) is #' `list(mtry = floor(sqt(nvariables(x))))`. #' The default for the gradient-based model (`method = "gbm"`) is #' `list(interaction.depth = 3, n.trees = 50, shrinkage = 0.1, n.minobsinnode = 10)`. #' #' @param nsimulations (positive integer) The number of R* values in the #' returned vector if `uncertainty` is `TRUE`. The default is `1000.` #' #' @param training_proportion (positive real) The proportion (in `(0,1)`) of #' iterations in used to train the classifier. The default is `0.7`. #' #' @param ... Other arguments passed to `caret::train()`. #' #' @details The `rstar()` function provides a measure of MCMC convergence based #' on whether it is possible to determine the chain that generated a #' particular draw with a probability greater than chance. To do so, it fits a #' machine learning classifier to a subset of the original MCMC draws (the #' training set) and evaluates its predictive accuracy on the remaining draws #' (the testing set). If predictive accuracy exceeds chance (i.e. predicting #' the chain that generated a draw uniformly at random), the diagnostic #' measure R* will be above 1, indicating that convergence has yet to occur. #' This statistic is recently developed, and it is currently unclear what is a #' reasonable threshold for diagnosing convergence. #' #' The statistic, R*, is stochastic, meaning that each time the test is run, #' unless the random seed is fixed, it will generally produce a different #' result. To minimize the implications of this stochasticity, it is #' recommended to repeatedly run this function to calculate a distribution of #' R*; alternatively, an approximation to this distribution can be obtained by #' setting `uncertainty = TRUE`, although this approximation of uncertainty #' will generally have a lower mean. #' #' By default, a random forest classifier is used (`method = "rf"`), which tends #' to perform best for target distributions of around 4 dimensions and above. #' For lower dimensional targets, gradient boosted models (called via #' `method = "gbm"`) tend to have a higher classification accuracy. On a given #' MCMC sample, it is recommended to try both of these classifiers. #' #' @return A numeric vector of length 1 (by default) or length `nsimulations` #' (if `uncertainty = TRUE`). #' #' @references Ben Lambert, Aki Vehtari (2020) R*: A robust MCMC convergence #' diagnostic with uncertainty using gradient-boosted machines. #' *arXiv preprint* `arXiv:2003.07900`. #' #' @examples #' \donttest{ #' if (require("caret", quietly = TRUE)) { #' x <- example_draws("eight_schools") #' print(rstar(x)) #' print(rstar(x, split = FALSE)) #' print(rstar(x, method = "gbm")) #' # can pass additional arguments to methods #' print(rstar(x, method = "gbm", verbose = FALSE)) #' #' # with uncertainty, returns a vector of R* values #' hist(rstar(x, uncertainty = TRUE)) #' hist(rstar(x, uncertainty = TRUE, nsimulations = 100)) #' #' # can use other classification methods in caret library #' print(rstar(x, method = "knn")) #' } #' } #' @export rstar <- function(x, split = TRUE, uncertainty = FALSE, method = "rf", hyperparameters = NULL, training_proportion = 0.7, nsimulations = 1000, ...) { # caret requires itself to be attached to the search list (not just loaded). # To avoid polluting the user's namespace we manually attach caret and its # two hard dependencies (ggplot2 and lattice) if they aren't already attached, # and unload any of them we had to attach when this function exits. loaded_packages <- character() on.exit(for (package in loaded_packages) { detach(paste0("package:", package), character.only = TRUE) }) for (package in setdiff(c("ggplot2", "lattice", "caret"), .packages())) { if (!suppressPackageStartupMessages(get("require")(package, character.only = TRUE, quietly = TRUE))) { stop_no_call("Package '", package, "' is required for 'rstar' to work.") } # store in reverse order since we'll unload in reverse loaded_packages <- c(package, loaded_packages) } split <- as_one_logical(split) uncertainty <- as_one_logical(uncertainty) method <- as_one_character(method) nsimulations <- as_one_integer(nsimulations) if (nsimulations < 1) { stop_no_call("'nsimulations' must be greater than or equal to 1.") } training_proportion <- as_one_numeric(training_proportion) if (training_proportion <= 0 || training_proportion >= 1) { stop_no_call("'training_proportion' must be greater than 0 and less than 1.") } # caret requires data.frame like objects x <- as_draws_df(x) if (split) { x <- split_chains(x) } # caret requires at least two variables to work if (nvariables(x) == 1) { x$.random <- rnorm(ndraws(x)) } # choose hyperparameters if (method == "rf" && is.null(hyperparameters)) { caret_grid <- data.frame(mtry = floor(sqrt(nvariables(x)))) } else if (method == "gbm" && is.null(hyperparameters)) { caret_grid <- data.frame( interaction.depth = 3, n.trees = 50, shrinkage = 0.1, n.minobsinnode = 10 ) } else { if (!(is.null(hyperparameters) || is.list(hyperparameters))) { stop_no_call("'hyperparameters' must be a list or NULL.") } caret_grid <- hyperparameters } # reserved variables should not be used for classification reserved_vars <- all_reserved_variables(x) reserved_vars <- setdiff(reserved_vars, ".chain") x <- remove_variables(x, reserved_vars) ndraws <- ndraws(x) class(x) <- "data.frame" x$.chain <- as.factor(x$.chain) # create training / testing sets random_draws <- sample(seq_len(ndraws), training_proportion * ndraws) training_data <- x[random_draws, ] testing_data <- x[-random_draws, ] # predict chain index using all other variables fit <- caret::train( .chain ~ ., data = training_data, method = method, trControl = caret::trainControl(method = 'none'), tuneGrid = caret_grid, ... ) # calculate classification accuracy and then R* # not all chains may be represented in testing_data nchains <- length(unique(testing_data$.chain)) if (uncertainty) { probs <- predict(object = fit, newdata = testing_data, type = "prob") m_accuracy <- matrix(nrow = nrow(probs), ncol = nsimulations) for (j in seq_len(NROW(probs))) { vals <- rmultinom(nsimulations, 1, prob = probs[j, ]) test <- apply(vals, 2, function(v) which(v == 1)) m_accuracy[j, ] <- ifelse(test == testing_data$.chain[j], 1, 0) } out <- colMeans(m_accuracy) * nchains } else { plda <- predict(object = fit, newdata = testing_data) res <- data.frame(predicted = plda, actual = testing_data$.chain) accuracy <- mean(res$predicted == res$actual) out <- accuracy * nchains } out } posterior/R/extract_variable_matrix.R0000644000175000017500000000410614165314652017671 0ustar nileshnilesh#' Extract matrix of a single variable #' #' Extract an iterations x chains matrix of draws of a single variable. #' This is primarily used for convergence diagnostic functions such as [rhat()]. #' #' @template args-methods-x #' @param variable (string) The name of the variable to extract. #' @template args-methods-dots #' @return A `matrix` with dimension iterations x chains. #' #' @examples #' x <- example_draws() #' mu <- extract_variable_matrix(x, variable = "mu") #' dim(mu) #' rhat(mu) #' #' @export extract_variable_matrix <- function(x, variable, ...) { UseMethod("extract_variable_matrix") } #' @rdname extract_variable_matrix #' @export extract_variable_matrix.default <- function(x, variable, ...) { x <- as_draws(x) extract_variable_matrix(x, variable, ...) } #' @rdname extract_variable_matrix #' @export extract_variable_matrix.draws <- function(x, variable, ...) { variable <- as_one_character(variable) out <- .subset_draws(x, variable = variable, reserved = FALSE) out <- as_draws_array(out) out <- drop_dims_or_classes(out, dims = 3, reset_class = TRUE) class(out) <- "matrix" out } #' @rdname extract_variable_matrix #' @export extract_variable_matrix.draws_rvars <- function(x, variable, ...) { variable <- as_one_character(variable) variable_regex <- regexec("^(.*)\\[.*\\]$", variable) if (!isTRUE(variable_regex[[1]] == -1)) { # regex match => variable with indices in the name ("x[1]", etc), which # can't be subset from draws_rvars directly, so we'll convert to a # draws_array first. root_variable is "x" when variable is "x[...]" root_variable <- regmatches(variable, variable_regex)[[1]][[2]] extract_variable_matrix(as_draws_array(x[root_variable]), variable, ...) } else if (length(x[[variable]]) > 1) { stop_no_call( 'Cannot extract non-scalar value using extract_variable_matrix():\n', ' "', variable, '" has dimensions: [', paste0(dim(x[[variable]]), collapse = ","), ']\n', ' Try including brackets ("[]") and indices in the variable name to extract a scalar value.' ) } else { NextMethod() } } posterior/R/draws-index.R0000644000175000017500000003455514165314652015226 0ustar nileshnilesh#' Index `draws` objects #' #' Index variables, iterations, chains, and draws. #' #' @name draws-index #' @template args-methods-x #' @template args-methods-dots #' @param value (character vector) For `variables(x) <- value`, the new variable #' names to use. #' #' @details #' The methods `variables()`, `iteration_ids()`, `chain_ids()`, and `draw_ids()` return #' vectors of all variables, iterations, chains, and draws, respectively. In #' contrast, the methods `nvariables()`, `niterations()`, `nchains()`, and #' `ndraws()` return the number of variables, iterations, chains, and draws, #' respectively. #' #' `variables(x) <- value` allows you to modify the vector of variable names, #' similar to how `names(x) <- value` works for vectors and lists. For renaming #' specific variables, [rename_variables()] may offer a more convenient approach. #' #' @return #' #' For `variables()`, a character vector. #' #' For `iteration_ids()`, `chain_ids()`, and `draw_ids()`, an integer vector. #' #' For `niterations()`, `nchains()`, and `ndraws()`, a scalar integer. #' #' @examples #' x <- example_draws() #' #' variables(x) #' nvariables(x) #' variables(x) <- letters[1:nvariables(x)] #' #' iteration_ids(x) #' niterations(x) #' #' chain_ids(x) #' nchains(x) #' #' draw_ids(x) #' ndraws(x) #' NULL #' @rdname draws-index #' @export variables <- function(x, ...) { UseMethod("variables") } #' @export variables.NULL <- function(x, ...) { NULL } #' @export variables.draws_matrix <- function(x, reserved = FALSE, ...) { remove_reserved_variable_names(colnames(x), reserved) } #' @export variables.draws_array <- function(x, reserved = FALSE, ...) { remove_reserved_variable_names(dimnames(x)[[3L]], reserved) } #' @export variables.draws_df <- function(x, reserved = FALSE, ...) { # reserved_df_variables are special data.frame columns # which should never be included as variables out <- names(x)[!names(x) %in% reserved_df_variables()] remove_reserved_variable_names(out, reserved) } #' @export variables.draws_list <- function(x, reserved = FALSE, ...) { if (!length(x)) { return(character(0)) } remove_reserved_variable_names(names(x[[1]]), reserved) } #' @export variables.draws_rvars <- function(x, reserved = FALSE, ...) { remove_reserved_variable_names(names(x), reserved) } # remove reserved variable names remove_reserved_variable_names <- function(variables, reserved) { reserved <- as_one_logical(reserved) if (!reserved && length(variables)) { # can't use setdiff() here as in the edge case where someone # manually creates duplicate columns it will give incorrect results variables <- variables[!variables %in% reserved_variables()] } variables } #' @rdname draws-index #' @export `variables<-` <- function(x, value) { UseMethod("variables<-") } #' @export `variables<-.draws_matrix` <- function(x, value) { check_new_variables(value) colnames(x) <- value x } #' @export `variables<-.draws_array` <- function(x, value) { check_new_variables(value) dimnames(x)[[3L]] <- value x } #' @export `variables<-.draws_df` <- function(x, value) { check_new_variables(value) names(x)[!names(x) %in% reserved_df_variables()] <- value x } #' @export `variables<-.draws_list` <- function(x, value) { check_new_variables(value) for (i in seq_along(x)) { names(x[[i]]) <- value } x } #' @export `variables<-.draws_rvars` <- function(x, value) { check_new_variables(value) names(x) <- value x } #' @rdname draws-index #' @export iteration_ids <- function(x) { UseMethod("iteration_ids") } #' @export iteration_ids.NULL <- function(x) { NULL } #' @export iteration_ids.draws_matrix <- function(x) { if (nchains(x) > 1) { out <- seq_len(niterations(x)) } else { out <- draw_ids(x) } out } #' @export iteration_ids.draws_array <- function(x) { out <- rownames(x) %||% seq_rows(x) as.integer(out) } #' @export iteration_ids.draws_df <- function(x) { as.integer(unique(x$.iteration)) } #' @export iteration_ids.draws_list <- function(x) { seq_along(x[[1]][[1]]) } #' @export iteration_ids.draws_rvars <- function(x) { iteration_ids(x[[1]]) } #' @export iteration_ids.rvar <- function(x) { if (nchains(x) > 1) { out <- seq_len(niterations(x)) } else { out <- draw_ids(x) } out } #' @rdname draws-index #' @export chain_ids <- function(x) { UseMethod("chain_ids") } #' @export chain_ids.NULL <- function(x) { NULL } #' @export chain_ids.draws_matrix <- function(x) { seq_len(nchains(x)) } #' @export chain_ids.draws_array <- function(x) { out <- colnames(x) %||% seq_cols(x) as.integer(out) } #' @export chain_ids.draws_df <- function(x) { as.integer(unique(x$.chain)) } #' @export chain_ids.draws_list <- function(x) { out <- names(x) %||% seq_rows(x) as.integer(out) } #' @export chain_ids.draws_rvars <- function(x) { chain_ids(x[[1]]) } #' @export chain_ids.draws_rvars <- function(x) { seq_len(nchains(x)) } #' @rdname draws-index #' @export draw_ids <- function(x) { UseMethod("draw_ids") } #' @export draw_ids.NULL <- function(x) { NULL } #' @export draw_ids.draws_matrix <- function(x) { as.integer(rownames(x) %||% seq_rows(x)) } #' @export draw_ids.draws_array <- function(x) { iteration_ids <- iteration_ids(x) niterations <- niterations(x) chain_ids <- chain_ids(x) ulapply(chain_ids, function(c) niterations * (c - 1L) + iteration_ids) } #' @export draw_ids.draws_df <- function(x) { as.integer(unique(x$.draw)) } #' @export draw_ids.draws_list <- function(x) { iteration_ids <- iteration_ids(x) niterations <- niterations(x) chain_ids <- chain_ids(x) ulapply(chain_ids, function(c) niterations * (c - 1L) + iteration_ids) } #' @export draw_ids.draws_rvars <- function(x) { draw_ids(x[[1]]) } #' @export draw_ids.rvar <- function(x) { draws <- draws_of(x) out <- rownames(draws) %||% seq_rows(draws) as.integer(out) } #' @rdname draws-index #' @export nvariables <- function(x, ...) { UseMethod("nvariables") } #' @export nvariables.NULL <- function(x, ...) { 0 } #' @export nvariables.draws <- function(x, ...) { length(variables(x, ...)) } #' @rdname draws-index #' @export niterations <- function(x) { UseMethod("niterations") } #' @export niterations.NULL <- function(x) { 0 } #' @export niterations.draws_matrix <- function(x) { NROW(x) / nchains(x) } #' @export niterations.draws_array <- function(x) { NROW(x) } #' @export niterations.draws_df <- function(x) { length(iteration_ids(x)) } #' @export niterations.draws_list <- function(x) { if (!length(x) || !length(x[[1]])) { return(0) } length(x[[1]][[1]]) } #' @export niterations.draws_rvars <- function(x) { if (!length(x)) 0 else niterations(x[[1]]) } #' @export niterations.rvar <- function(x) { ndraws(x) / nchains(x) } #' @rdname draws-index #' @export nchains <- function(x) { UseMethod("nchains") } #' @export nchains.NULL <- function(x) { 0 } #' @export nchains.draws_matrix <- function(x) { attr(x, "nchains") %||% 1L } #' @export nchains.draws_array <- function(x) { NCOL(x) } #' @export nchains.draws_df <- function(x) { length(chain_ids(x)) } #' @export nchains.draws_list <- function(x) { length(x) } #' @export nchains.draws_rvars <- function(x) { if (!length(x)) 0 else nchains(x[[1]]) } #' @export nchains.rvar <- function(x) { attr(x, "nchains") %||% 1L } # for internal use only currently: if you are setting the nchains # attribute on an rvar, ALWAYS use this function so that the proxy # cache is invalidated `nchains_rvar<-` <- function(x, value) { attr(x, "nchains") <- value invalidate_rvar_cache(x) } #' @rdname draws-index #' @export ndraws <- function(x) { UseMethod("ndraws") } #' @export ndraws.NULL <- function(x) { 0 } #' @export ndraws.draws_matrix <- function(x) { NROW(x) } #' @export ndraws.draws_array <- function(x) { niterations(x) * nchains(x) } #' @export ndraws.draws_df <- function(x) { NROW(x) } #' @export ndraws.draws_list <- function(x) { niterations(x) * nchains(x) } #' @export ndraws.draws_rvars <- function(x) { if (!length(x)) 0 else ndraws(x[[1]]) } #' @export ndraws.rvar <- function(x) { # as.vector() to drop names in case there are index names as.vector(NROW(draws_of(x))) } # internal ---------------------------------------------------------------- # check validity of existing variable names: e.g., that # all `variables` exist in `x` and that no `variables`are reserved words # Additionally, this returns the cannonical name, so e.g. "theta" will get # converted to c("theta[1]", "theta[2]", ...) if those variables exist. # @param regex should 'variables' be treated as regular expressions? # @param scalar_only should only scalar variables be matched? check_existing_variables <- function(variables, x, regex = FALSE, scalar_only = FALSE) { check_draws_object(x) if (is.null(variables)) { return(NULL) } regex <- as_one_logical(regex) scalar_only <- as_one_logical(scalar_only) variables <- unique(as.character(variables)) all_variables <- variables(x, reserved = TRUE) if (regex) { tmp <- named_list(variables) for (i in seq_along(variables)) { tmp[[i]] <- grep(variables[i], all_variables) } # regular expressions are not required to match anything missing_variables <- NULL variables <- as.character(all_variables[unique(unlist(tmp))]) } else if (!scalar_only) { # need to find variables that are matched by either a scalar or vector # variable in x and what the matching variable is, while keeping original # order of input `variables` # find scalar variables (1-to-1 match between all_variables and variables) scalar_input_ixs <- match(all_variables, variables) # find vector variable matches (match all_variables with the indexing stripped) all_variables_base <- all_variables # exclude already matched scalar variables all_variables_base[!is.na(scalar_input_ixs)] <- NA_character_ all_variables_base <- gsub("\\[.*\\]$", "", all_variables_base, perl = TRUE) vector_input_ixs <- match(all_variables_base, variables) # compose the vector of indices of matched input variables input_ixs <- c(scalar_input_ixs[!is.na(scalar_input_ixs)], vector_input_ixs[!is.na(vector_input_ixs)]) # compose the vector of indices of matched all_variables all_var_ixs <- seq_along(all_variables) all_var_matched_ixs <- c(all_var_ixs[!is.na(scalar_input_ixs)], all_var_ixs[!is.na(vector_input_ixs)]) # select missed input variables missing_vars_mask <- rep_len(TRUE, length(variables)) missing_vars_mask[input_ixs] <- FALSE missing_variables <- variables[missing_vars_mask] # select matched all_variables maintaining the input variables order variables <- all_variables[all_var_matched_ixs[order(input_ixs, all_var_matched_ixs)]] } else { missing_variables <- setdiff(variables, all_variables) } variables <- check_reserved_variables(variables) if (length(missing_variables)) { stop_no_call("The following variables are missing in the draws object: ", comma(missing_variables)) } invisible(variables) } # check validity of new variables: e.g., that there are # no duplicates in `variables` and that they do not use # reserved words check_new_variables <- function(variables) { # use anyDuplicated() for the check since it is faster than any(duplicated(x)) and # we shouldn't expect to take this branch often (since it is an error) if (anyDuplicated(variables)) { duplicates = unique(variables[duplicated(variables)]) stop_no_call( "Duplicate variable names are not allowed in draws objects.\n", "The following variable names are duplicates:\n", comma(duplicates) ) } check_reserved_variables(variables) } # check variables do not make use of reserved words check_reserved_variables <- function(variables) { assert_character(variables) # for now only check reserved columns used in 'draws_df' objects # other reserved variables such as '.log_weight' may be overwritten # this has the advantage that power users can directly add such variables used_reserved_variables <- intersect(reserved_df_variables(), variables) if (length(used_reserved_variables)) { stop_no_call("Variable names ", comma(used_reserved_variables), " are reserved.") } invisible(variables) } # check validity of iteration indices # @param unique should the returned IDs be unique? check_iteration_ids <- function(iteration_ids, x, unique = TRUE) { check_draws_object(x) if (is.null(iteration_ids)) { return(NULL) } unique <- as_one_logical(unique) iteration_ids <- as.integer(iteration_ids) if (unique) { iteration_ids <- unique(iteration_ids) } iteration_ids <- sort(iteration_ids) if (any(iteration_ids < 1L)) { stop_no_call("Iteration indices should be positive.") } niterations <- niterations(x) max_iteration <- SW(max(iteration_ids)) if (max_iteration > niterations) { stop_no_call("Tried to subset iterations up to '", max_iteration, "' ", "but the object only has '", niterations, "' iterations.") } invisible(iteration_ids) } # check validity of chain indices # @param unique should the returned IDs be unique? check_chain_ids <- function(chain_ids, x, unique = TRUE) { check_draws_object(x) if (is.null(chain_ids)) { return(NULL) } unique <- as_one_logical(unique) chain_ids <- as.integer(chain_ids) if (unique) { chain_ids <- unique(chain_ids) } chain_ids <- sort(chain_ids) if (any(chain_ids < 1L)) { stop_no_call("Chain indices should be positive.") } nchains <- nchains(x) max_chain <- SW(max(chain_ids)) if (max_chain > nchains) { stop_no_call("Tried to subset chains up to '", max_chain, "' ", "but the object only has '", nchains, "' chains.") } invisible(chain_ids) } # check validity of draw indices # @param unique should the returned IDs be unique? check_draw_ids <- function(draw_ids, x, unique = TRUE) { check_draws_object(x) if (is.null(draw_ids)) { return(NULL) } unique <- as_one_logical(unique) draw_ids <- as.integer(draw_ids) if (unique) { draw_ids <- unique(draw_ids) } draw_ids <- sort(draw_ids) if (any(draw_ids < 1L)) { stop_no_call("Draw indices should be positive.") } ndraws <- ndraws(x) max_draw <- SW(max(draw_ids)) if (max_draw > ndraws) { stop_no_call("Tried to subset draws up to '", max_draw, "' ", "but the object only has '", ndraws, "' draws.") } invisible(draw_ids) } posterior/R/bind_draws.R0000644000175000017500000002032014165314652015076 0ustar nileshnilesh#' Bind `draws` objects together #' #' Bind multiple [`draws`] objects together to form a single `draws` object. #' #' @param x (draws) A [`draws`] object. The draws format of `x` will define the #' format of the returned draws object. #' @param ... (draws) Additional [`draws`] objects to bind to `x`. #' @param along (string) The dimension along which draws objects should be bound #' together. Possible values are `"variable"` (the default), `"chain"`, #' `"iteration"`, and `"draw"`. Not all options are supported for all input #' formats. #' @template return-draws #' #' @examples #' x1 <- draws_matrix(alpha = rnorm(5), beta = rnorm(5)) #' x2 <- draws_matrix(alpha = rnorm(5), beta = rnorm(5)) #' ndraws(x1) #' ndraws(x2) #' x3 <- bind_draws(x1, x2, along = "draw") #' ndraws(x3) #' #' x4 <- draws_matrix(theta = rexp(5)) #' x5 <- bind_draws(x1, x4, along = "variable") #' variables(x5) #' #' @importFrom abind abind #' @export bind_draws <- function(x, ...) { UseMethod("bind_draws") } #' @rdname bind_draws #' @export bind_draws.draws_matrix <- function(x, ..., along = "variable") { along <- validate_along(along) dots <- list(...) if (!length(dots)) { return(as_draws_matrix(x)) } dots <- c(list(x), dots) dots <- remove_null(dots) dots <- lapply(dots, as_draws_matrix) dots <- lapply(dots, repair_draws) if (along == "variable") { check_same_fun_output(dots, chain_ids) check_same_fun_output(dots, iteration_ids) out <- do.call(abind, c(dots, along = 2L)) attr(out, "nchains") <- nchains(dots[[1]]) } else if (along == "chain") { check_same_fun_output(dots, variables) check_same_fun_output(dots, iteration_ids) out <- do.call(abind, c(dots, along = 1L)) attr(out, "nchains") <- sum(sapply(dots, nchains)) } else if (along == "iteration") { stop_no_call("Cannot bind 'draws_matrix' objects along 'iteration'.") } else if (along %in% c("draw")) { check_same_fun_output(dots, variables) out <- do.call(abind, c(dots, along = 1L)) attr(out, "nchains") <- 1L } as_draws_matrix(out) } #' @rdname bind_draws #' @export bind_draws.draws_array <- function(x, ..., along = "variable") { along <- validate_along(along) dots <- list(...) if (!length(dots)) { return(as_draws_array(x)) } dots <- c(list(x), dots) dots <- remove_null(dots) dots <- lapply(dots, as_draws_array) dots <- lapply(dots, repair_draws) if (along == "variable") { check_same_fun_output(dots, chain_ids) check_same_fun_output(dots, iteration_ids) out <- do.call(abind, c(dots, along = 3L)) } else if (along == "chain") { check_same_fun_output(dots, variables) check_same_fun_output(dots, iteration_ids) out <- do.call(abind, c(dots, along = 2L)) } else if (along == "iteration") { check_same_fun_output(dots, variables) check_same_fun_output(dots, chain_ids) out <- do.call(abind, c(dots, along = 1L)) } else if (along == "draw") { stop_no_call("Cannot bind 'draws_array' objects along 'draw'.") } as_draws_array(out) } #' @rdname bind_draws #' @export bind_draws.draws_df <- function(x, ..., along = "variable") { along <- validate_along(along) dots <- list(...) if (!length(dots)) { return(as_draws_df(x)) } dots <- c(list(x), dots) dots <- remove_null(dots) dots <- lapply(dots, as_draws_df) dots <- lapply(dots, repair_draws) if (along == "variable") { check_same_fun_output(dots, chain_ids) check_same_fun_output(dots, iteration_ids) reserved_df_values <- as.data.frame(dots[[1]])[, c(".chain", ".iteration")] dots <- lapply(dots, remove_reserved_df_variables) out <- do.call(cbind, dots) out <- cbind(out, reserved_df_values) } else if (along == "chain") { check_same_fun_output(dots, variables) check_same_fun_output(dots, iteration_ids) cumsum_chains <- c(0, cumsum(ulapply(dots, nchains))) for (i in seq_along(dots)) { dots[[i]]$.chain <- cumsum_chains[i] + dots[[i]]$.chain dots[[i]]$.chain <- as.integer(dots[[i]]$.chain) } out <- do.call(rbind, dots) } else if (along == "iteration") { check_same_fun_output(dots, variables) check_same_fun_output(dots, chain_ids) cumsum_iterations <- c(0, cumsum(ulapply(dots, niterations))) for (i in seq_along(dots)) { dots[[i]]$.iteration <- cumsum_iterations[i] + dots[[i]]$.iteration dots[[i]]$.iteration <- as.integer(dots[[i]]$.iteration) } out <- do.call(rbind, dots) } else if (along == "draw") { check_same_fun_output(dots, variables) out <- do.call(rbind, dots) # binding along 'draw' implies dropping chain information out$.chain <- 1L out$.iteration <- seq_rows(out) } out$.draw <- NULL .as_draws_df(out) } #' @rdname bind_draws #' @export bind_draws.draws_list <- function(x, ..., along = "variable") { along <- validate_along(along) dots <- list(...) if (!length(dots)) { return(as_draws_list(x)) } dots <- c(list(x), dots) dots <- remove_null(dots) dots <- lapply(dots, as_draws_list) dots <- lapply(dots, repair_draws) if (along == "variable") { check_same_fun_output(dots, chain_ids) check_same_fun_output(dots, iteration_ids) chains <- seq_along(dots[[1]]) out <- vector("list", length(chains)) for (i in chains) { out[[i]] <- ulapply(dots, "[[", i, recursive = FALSE) } } else if (along == "chain") { check_same_fun_output(dots, variables) check_same_fun_output(dots, iteration_ids) out <- do.call(c, dots) } else if (along == "iteration") { check_same_fun_output(dots, variables) check_same_fun_output(dots, chain_ids) chains <- seq_along(dots[[1]]) variables <- variables(dots[[1]]) out <- vector("list", length(chains)) for (i in chains) { tmp <- lapply(dots, "[[", i) out[[i]] <- named_list(variables) for (v in variables) { out[[i]][[v]] <- ulapply(tmp, "[[", v) } } } else if (along == "draw") { stop_no_call("Cannot bind 'draws_list' objects along 'draw'.") } as_draws_list(out) } #' @rdname bind_draws #' @importFrom abind abind #' @export bind_draws.draws_rvars <- function(x, ..., along = "variable") { along <- validate_along(along) dots <- list(...) if (!length(dots)) { return(as_draws_rvars(x)) } dots <- c(list(x), dots) dots <- remove_null(dots) dots <- lapply(dots, as_draws_rvars) dots <- lapply(dots, repair_draws) if (along == "variable") { check_same_fun_output(dots, chain_ids) check_same_fun_output(dots, iteration_ids) out <- do.call(c, dots) } else if (along == "iteration") { stop_no_call("Cannot bind 'draws_rvars' objects along 'iteration'.") } else if (along %in% c("chain", "draw")) { check_same_fun_output(dots, variables) if (along == "chain") { check_same_fun_output(dots, iteration_ids) nchains <- sum(sapply(dots, nchains)) } else { # binding along 'draw' implies dropping chain information dots <- lapply(dots, merge_chains) nchains <- 1 } # bind all the corresponding variables together along draws out <- lapply(seq_along(dots[[1]]), function(var_i) { vars <- lapply(dots, `[[`, var_i) var_draws <- lapply(vars, draws_of) out <- rvar(abind(var_draws, along = 1), nchains = nchains) out }) names(out) <- names(dots[[1]]) } as_draws_rvars(out) } #' @export bind_draws.NULL <- function(x, ..., along = "variable") { dots <- list(...) dots <- remove_null(dots) if (!length(dots)) { stop_no_call("All objects passed to 'bind_draws' are NULL.") } do.call(bind_draws, dots) } # check if function output is the same across objects # @param ls list of objects # @param fun a function to be evaluated on the objects # @param TRUE if the function output matches for all objects check_same_fun_output <- function(ls, fun) { assert_list(ls) if (is.function(fun)) { fun_name <- deparse_pretty(substitute(fun)) } else { fun_name <- as_one_character(fun) fun <- get(fun, mode = "function") } ids <- lapply(ls, fun) if (sum(!duplicated(ids)) > 1L) { stop_no_call("'", fun_name, "' of bound objects do not match.") } invisible(TRUE) } # validate the 'along' argument of 'bind_draws' validate_along <- function(along) { options <- c("variable", "chain", "iteration", "draw") match.arg(along, options) } posterior/R/remove_variables.R0000644000175000017500000000324414165314652016315 0ustar nileshnilesh# remove variables from a draws object remove_variables <- function(x, ...) { UseMethod("remove_variables") } #' @export remove_variables.list <- function(x, variables, ...) { variables <- as.character(variables) variables <- intersect(variables, names(x)) for (v in variables) { x[[v]] <- NULL } x } #' @export remove_variables.draws_matrix <- function(x, variables, ...) { variables <- as.character(variables) if (!length(variables)) { return(x) } x[, !colnames(x) %in% variables] } #' @export remove_variables.draws_array <- function(x, variables, ...) { variables <- as.character(variables) if (!length(variables)) { return(x) } x[, , !dimnames(x)[[3]] %in% variables] } #' @export remove_variables.draws_df <- function(x, variables, ...) { variables <- as.character(variables) for (v in variables) { x[[v]] <- NULL } x } #' @export remove_variables.draws_list <- function(x, variables, ...) { variables <- as.character(variables) if (!length(variables)) { return(x) } for (i in seq_along(x)) { for (v in variables) { x[[i]][[v]] <- NULL } } x } #' @export remove_variables.draws_rvars <- function(x, variables, ...) { variables <- as.character(variables) if (!length(variables)) { return(x) } x[!names(x) %in% variables] } # internal ---------------------------------------------------------------- # remove all reserved variables remove_reserved_variables <- function(x, ...) { remove_variables(x, reserved_variables(x)) } # remove reserved variables specific for the 'draws_df' format remove_reserved_df_variables <- function(x, ...) { remove_variables(x, reserved_df_variables()) } posterior/R/rvar-dim.R0000755000175000017500000000165214165314652014515 0ustar nileshnilesh#' @export length.rvar <- function(x) { prod(dim(x)) } #' @export dim.rvar <- function(x) { dim(draws_of(x))[-1] } #' @export `dim<-.rvar` <- function(x, value) { if (length(value) == 0) { # vectors have NULL dim; for us that means # dim of c(ndraws(x), length(x)) value = length(x) } # must keep old rowname around and restore them, since changing dim will drop them old_rownames <- rownames(draws_of(x)) dim(draws_of(x)) <- c(ndraws(x), value) rownames(draws_of(x)) <- old_rownames x } #' @export dimnames.rvar <- function(x) { .dimnames <- dimnames(draws_of(x)) .dimnames[-1] } #' @export `dimnames<-.rvar` <- function(x, value) { dimnames(draws_of(x)) <- c(list(rownames(draws_of(x))), value) x } #' @export names.rvar <- function(x) { .dimnames <- dimnames(draws_of(x)) .dimnames[[2]] } #' @export `names<-.rvar` <- function(x, value) { dimnames(draws_of(x))[2] <- list(value) x } posterior/R/as_draws_array.R0000644000175000017500000001436514165314655016002 0ustar nileshnilesh#' The `draws_array` format #' #' @name draws_array #' @family formats #' #' @templateVar draws_format draws_array #' @templateVar base_class "array" #' @template draws_format-skeleton #' @template args-format-nchains #' #' @details Objects of class `"draws_array"` are 3-D arrays with dimensions #' `"iteration"`, `"chain"`, and `"variable"`. See **Examples**. #' NULL #' @rdname draws_array #' @export as_draws_array <- function(x, ...) { UseMethod("as_draws_array") } #' @rdname draws_array #' @export as_draws_array.default <- function(x, ...) { x <- as_draws(x) as_draws_array(x, ...) } #' @rdname draws_array #' @export as_draws_array.draws_array <- function(x, ...) { x } #' @rdname draws_array #' @export as_draws_array.draws_matrix <- function(x, ...) { old_dim <- dim(x) old_dimnames <- dimnames(x) iteration_ids <- iteration_ids(x) chain_ids <- chain_ids(x) dim(x) <- c(niterations(x), nchains(x), old_dim[2]) dimnames(x) <- list( iteration = iteration_ids, chain = chain_ids, variable = old_dimnames[[2]] ) class(x) <- class_draws_array() attr(x, "nchains") <- NULL x } #' @rdname draws_array #' @export as_draws_array.draws_df <- function(x, ...) { if (ndraws(x) == 0) { return(empty_draws_array(variables(x))) } iterations <- iteration_ids(x) chains <- chain_ids(x) out <- vector("list", length(chains)) for (i in seq_along(out)) { if (length(chains) == 1) { out[[i]] <- x } else { out[[i]] <- x[x$.chain == i, ] } out[[i]] <- remove_reserved_df_variables(out[[i]]) out[[i]] <- as.matrix(out[[i]]) } out <- as_array_matrix_list(out) dimnames(out) <- list( iteration = iterations, chain = chains, variable = dimnames(out)[[3]] ) class(out) <- class_draws_array() out } #' @rdname draws_array #' @export as_draws_array.draws_list <- function(x, ...) { x <- as_draws_df(x) as_draws_array(x, ...) } #' @rdname draws_array #' @export as_draws_array.draws_rvars <- function(x, ...) { if (ndraws(x) == 0) { return(empty_draws_array(variables(x))) } draws <- do.call(cbind, lapply(seq_along(x), function(i) { # flatten each rvar so it only has two dimensions: draws and variables # this also collapses indices into variable names in the format "var[i,j,k,...]" x_i <- flatten_array(x[[i]], names(x)[[i]]) draws_of(x_i) })) # add chain info back into the draws array # ([draws, variables] -> [iterations, chains, variables]) .dimnames <- dimnames(draws) dim(draws) <- c(niterations(x), nchains(x), dim(draws)[-1]) dimnames(draws) <- c(list(NULL, NULL), .dimnames[-1]) as_draws_array(draws, ...) } #' @rdname draws_array #' @export as_draws_array.mcmc <- function(x, ...) { as_draws_array(as_draws_matrix(x), ...) } #' @rdname draws_array #' @export as_draws_array.mcmc.list <- function(x, ...) { class(x) <- "list" .as_draws_array(as_array_matrix_list(x)) } # try to convert any R object into a 'draws_array' object .as_draws_array <- function(x) { x <- as.array(x) new_dimnames <- list(iteration = NULL, chain = NULL, variable = NULL) if (!is.null(dimnames(x)[[3]])) { new_dimnames[[3]] <- dimnames(x)[[3]] } else { new_dimnames[[3]] <- default_variables(dim(x)[3]) } check_new_variables(new_dimnames[[3]]) new_dimnames[[1]] <- as.character(seq_rows(x)) new_dimnames[[2]] <- as.character(seq_cols(x)) dimnames(x) <- new_dimnames class(x) <- class_draws_array() x } #' @rdname draws_array #' @export draws_array <- function(..., .nchains = 1) { out <- validate_draws_per_variable(...) .nchains <- as_one_integer(.nchains) if (.nchains < 1) { stop_no_call("Number of chains must be positive.") } ndraws <- length(out[[1]]) if (ndraws %% .nchains != 0) { stop_no_call("Number of chains does not divide the number of draws.") } niterations <- ndraws / .nchains variables <- names(out) out <- unlist(out) out <- array(out, dim = c(niterations, .nchains, length(variables))) dimnames(out) <- list(NULL, NULL, variables) as_draws_array(out) } class_draws_array <- function() { c("draws_array", "draws", "array") } #' @rdname draws_array #' @export is_draws_array <- function(x) { inherits(x, "draws_array") } # is an object looking like a 'draws_array' object? is_draws_array_like <- function(x) { is.array(x) && length(dim(x)) == 3L } #' Extract parts of a `draws_array` object #' #' Extract parts of a `draws_array` object. They are strictly defined as arrays #' of 3 dimensions (iteration x chain x variable) so dropping any of the #' dimensions breaks the expected structure of the object. Accordingly, no #' dropping of dimensions is done by default even if the extracted slices are of #' length 1. If `drop` is manually set to `TRUE` and any of the dimensions is #' actually dropped, this will lead to dropping the `"draws_array"` class as #' well. #' #' @param x,i,j,...,drop Same as in the default extraction method but with #' `drop` being set to `FALSE` by default. #' #' @return An object of class `"draws_array"` unless any of the dimensions #' was dropped during the extraction. #' #' @export `[.draws_array` <- function(x, i, j, ..., drop = FALSE) { # TODO: allow for argument 'reserved' as in '[.draws_df' # right now this fails because NextMethod() cannot ignore arguments out <- NextMethod("[", drop = drop) if (length(dim(out)) == length(dim(x))) { class(out) <- class(x) } out } #' @export variance.draws_array <- function(x, ...) { var(as.vector(x)) } # convert a list of matrices to an array as_array_matrix_list <- function(x) { stopifnot(is.list(x)) if (length(x) == 1) { tmp <- dimnames(x[[1]]) x <- x[[1]] dim(x) <- c(dim(x), 1) dimnames(x) <- tmp } else { x <- abind::abind(x, along = 3L) } x <- aperm(x, c(1, 3, 2)) } # create an empty draws_array object empty_draws_array <- function(variables = character(0), nchains = 0, niterations = 0) { assert_character(variables, null.ok = TRUE) assert_number(nchains, lower = 0) assert_number(niterations, lower = 0) out <- array( numeric(0), dim = c(niterations, nchains, length(variables)), dimnames = list( iteration = seq_len(niterations), chain = seq_len(nchains), variable = variables ) ) class(out) <- class_draws_array() out } posterior/LICENSE0000644000175000017500000000023414165314652013445 0ustar nileshnileshYEAR: 2021 COPYRIGHT HOLDER: posterior package authors; Stan Developers and their Assignees; Trustees of Columbia University ORGANIZATION: copyright holder posterior/inst/0000755000175000017500000000000014165340154013412 5ustar nileshnileshposterior/inst/CITATION0000644000175000017500000000201714165340035014545 0ustar nileshnileshyear <- sub("-.*", "", meta$Date) note <- sprintf("R package version %s", meta$Version) authors <- meta$`Authors@R` authors <- eval(str2expression(authors)) authors <- grep("\\[cre|\\[aut", authors, value = TRUE) bibentry(bibtype = "Misc", title = "posterior: Tools for Working with Posterior Distributions", author = authors, year = year, note = note, url = "https://mc-stan.org/posterior/", header = "To cite the posterior R package:" ) bibentry(bibtype = "Article", title = "Rank-normalization, folding, and localization: An improved Rhat for assessing convergence of MCMC (with discussion)", author = c(person("Aki", "Vehtari"), person("Andrew", "Gelman"), person("Daniel", "Simpson"), person("Bob", "Carpenter"), person("Paul-Christian", "Bürkner")), year = "2021", journal = "Bayesian Analysis", header = "To cite the MCMC convergence diagnostics:" ) posterior/inst/doc/0000755000175000017500000000000014165340154014157 5ustar nileshnileshposterior/inst/doc/posterior.Rmd0000644000175000017500000003502514165314652016662 0ustar nileshnilesh--- title: "The posterior R package" author: "Paul Bürkner, Jonah Gabry, Matthew Kay, and Aki Vehtari" output: rmarkdown::html_vignette: toc: true toc_depth: 3 vignette: > %\VignetteIndexEntry{The posterior R package} %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} --- ## Introduction The posterior R package is intended to provide useful tools for both users and developers of packages for fitting Bayesian models or working with output from Bayesian models. The primary goals of the package are to: * Efficiently convert between many different useful formats of draws (samples) from posterior or prior distributions. * Provide consistent methods for operations commonly performed on draws, for example, subsetting, binding, or mutating draws. * Provide various summaries of draws in convenient formats. * Provide lightweight implementations of state of the art posterior inference diagnostics. ## Installation You can install the latest official release version via ```{r install, eval=FALSE} install.packages("posterior") ``` or the latest development version from GitHub via ```{r install_github, eval=FALSE} # install.packages("remotes") remotes::install_github("stan-dev/posterior") ``` ## Example ```{r setup} library("posterior") ``` To demonstrate how to work with the posterior package, throughout the rest of this vignette we will use example posterior draws obtained from the eight schools hierarchical meta-analysis model described in Gelman et al. (2013). The variables are an estimate per school (`theta[1]` through `theta[8]`) as well as an overall mean (`mu`) and standard deviation across schools (`tau`). ```{r example-drawss} eight_schools_array <- example_draws("eight_schools") print(eight_schools_array, max_variables = 3) ``` The structure of this object is explained in the next section. ## Draws formats ### Available formats Because different formats are preferable in different situations, posterior supports multiple formats and easy conversion between them. The currently supported formats are: * `draws_array`: An iterations by chains by variables array. * `draws_matrix`: A draws (iterations x chains) by variables array. * `draws_df`: A draws by variables data frame with addition meta columns `.chain`, `.iteration`, `.draw`. * `draws_list`: A list with one sublist per chain. Each sublist is a named list with one vector of iterations per variable. * `draws_rvars`: A list of random variable `rvar` objects, one per variable. See `vignette("rvar")` for an introduction to this new data type. These formats are essentially base R object classes and can be used as such. For example, a `draws_matrix` object is just a `matrix` with a little more consistency (e.g., no dropping of dimensions with one level when indexing) and additional methods. The exception to this is the `draws_rvars` format, which contains `rvar` objects that behave somewhat like arrays but are really a unique data type. See the separate vignette on the `rvar` and `draws_rvars` data types for details. The draws for our example come as a `draws_array` object with `r niterations(eight_schools_array)` iterations, `r nchains(eight_schools_array)` chains, and `r nvariables(eight_schools_array)` variables: ```{r draws_array-structure} str(eight_schools_array) ``` ### Converting between formats Each of the formats has a method `as_draws_` (e.g., `as_draws_list()`) for creating an object of the class from any of the other formats. As a demonstration we can convert the example `draws_array` to a `draws_df`, a data frame with additional meta information. To convert to a `draws_df` we use `as_draws_df()`. ```{r draws_df} eight_schools_df <- as_draws_df(eight_schools_array) str(eight_schools_df) print(eight_schools_df) ``` ### Converting regular R objects to `draws` formats The example draws already come in a format natively supported by posterior, but we can of course also import the draws from other sources like common base R objects. #### Example: create draws_matrix from a matrix In addition to converting other `draws` objects to the `draws_matrix` format, the `as_draws_matrix()` function will convert a regular matrix to a `draws_matrix`. ```{r draws_matrix-from-matrix} x <- matrix(rnorm(50), nrow = 10, ncol = 5) colnames(x) <- paste0("V", 1:5) x <- as_draws_matrix(x) print(x) ``` Because the matrix was converted to a `draws_matrix`, all of the methods for working with `draws` objects described in subsequent sections of this vignette will now be available. Instead of `as_draws_matrix()` we also could have just used `as_draws()`, which attempts to find the closest available format to the input object. In this case the result would be a `draws_matrix` object either way. #### Example: create draws_matrix from multiple vectors In addition to the `as_draws_matrix()` converter function there is also a `draws_matrix()` constructor function that can be used to create draws matrix from multiple vectors. ```{r draws_matrix-from-vectors} x <- draws_matrix(alpha = rnorm(50), beta = rnorm(50)) print(x) ``` Analogous functions exist for the other draws formats and are used similarly. ## Manipulating `draws` objects The posterior package provides many methods for manipulating draws objects in useful ways. In this section we demonstrate several of the most commonly used methods. These methods, like the other methods in posterior, are available for every supported draws format. ### Subsetting Subsetting `draws` objects can be done according to various aspects of the draws (iterations, chains, or variables). The posterior package provides a convenient interface for this purpose via `subset_draws()`. For example, here is the code to extract the first five iterations of the first two chains of the variable `mu`. ```{r subset-df} sub_df <- subset_draws(eight_schools_df, variable = "mu", chain = 1:2, iteration = 1:5) str(sub_df) ``` The same call to `subset_draws()` can be used regardless of the draws format. For example, here is the same code except replacing the `draws_df` object with the `draws_array` object. ```{r subset-array} sub_arr <- subset_draws(eight_schools_array, variable = "mu", chain = 1:2, iteration = 1:5) str(sub_arr) ``` We can check that these two calls to `subset_draws()` (the first with the data frame, the second with the array) produce the same result. ```{r subset-compare, results='hold'} identical(sub_df, as_draws_df(sub_arr)) identical(as_draws_array(sub_df), sub_arr) ``` It is also possible to use standard R subsetting syntax with `draws` objects. The following is equivalent to the use of `subset_draws()` with the array above. ```{r subset-standard} eight_schools_array[1:5, 1:2, "mu"] ``` The major difference between how posterior behaves when indexing and how base R behaves is that posterior will _not_ drop dimensions with only one level. That is, even though there is only one variable left after subsetting, the result of the subsetting above is still a `draws_array` and not a `draws_matrix`. ### Mutating (transformations of variables) The magic of having obtained draws from the joint posterior (or prior) distribution of a set of variables is that these draws can also be used to obtain draws from any other variable that is a function of the original variables. That is, if we are interested in the posterior distribution of, say, `phi = (mu + tau)^2` all we have to do is to perform the transformation for each of the individual draws to obtain draws from the posterior distribution of the transformed variable. This procedure is handled by `mutate_variables()`. ```{r mutate} x <- mutate_variables(eight_schools_df, phi = (mu + tau)^2) x <- subset_draws(x, c("mu", "tau", "phi")) print(x) ``` ### Renaming To rename variables use `rename_variables()`. Here we rename the scalar `mu` to `mean` and the vector `theta` to `alpha`. ```{r rename} # mu is a scalar, theta is a vector x <- rename_variables(eight_schools_df, mean = mu, alpha = theta) variables(x) ``` In the call to `rename_variables()` above, `mu` and `theta` can be quoted or unquoted. It is also possible to rename individual elements of non-scalar parameters, for example we can rename just the first element of `alpha`: ```{r rename-element} x <- rename_variables(x, a1 = `alpha[1]`) variables(x) ``` ### Binding The `bind_draws()` method can be used to combine `draws` objects along different dimensions. As an example, suppose we have several different `draws_matrix` objects: ```{r objects-to-bind} x1 <- draws_matrix(alpha = rnorm(5), beta = rnorm(5)) x2 <- draws_matrix(alpha = rnorm(5), beta = rnorm(5)) x3 <- draws_matrix(theta = rexp(5)) ``` We can bind `x1` and `x3` together along the `'variable'` dimension to get a single `draws_matrix` with the variables from both `x1` and `x3`: ```{r bind-variable} x4 <- bind_draws(x1, x3, along = "variable") print(x4) ``` Because `x1` and `x2` have the same variables, we can bind them along the `'draw'` dimension to create a single `draws_matrix` with more draws: ```{r bind-draw} x5 <- bind_draws(x1, x2, along = "draw") print(x5) ``` As with all posterior methods, `bind_draws()` can be used with all draws formats and depending on the format different dimensions are available to bind on. For example, we can bind `draws_array` objects together by `iteration`, `chain`, or `variable`, but a 2-D `draws_matrix` with the chains combined can only by bound by `draw` and `variable`. ## Summaries and diagnostics ### summarise_draws() basic usage Computing summaries of posterior or prior draws and convergence diagnostics for posterior draws are some of the most common tasks when working with Bayesian models fit using Markov Chain Monte Carlo (MCMC) methods. The posterior package provides a flexible interface for this purpose via `summarise_draws()` (or `summarize_draws()`), which can be passed any of the formats supported by the package. ```{r summary} # summarise_draws or summarize_draws summarise_draws(eight_schools_df) ``` The result is a data frame with one row per variable and one column per summary statistic or convergence diagnostic. The summaries `rhat`, `ess_bulk`, and `ess_tail` are described in Vehtari et al. (2020). We can choose which summaries to compute by passing additional arguments, either functions or names of functions. For instance, if we only wanted the mean and its corresponding Monte Carlo Standard Error (MCSE) we could use either of these options: ```{r summary-with-measures} # the function mcse_mean is provided by the posterior package s1 <- summarise_draws(eight_schools_df, "mean", "mcse_mean") s2 <- summarise_draws(eight_schools_df, mean, mcse_mean) identical(s1, s2) print(s1) ``` ### Changing column names The column names in the output can be changed by providing the functions as name-value pairs, where the name is the name to use in the output and the value is a function name or definition. For example, here we change the names `mean` and `sd` to `posterior_mean` and `posterior_sd`. ```{r change-summary-names} summarise_draws(eight_schools_df, posterior_mean = mean, posterior_sd = sd) ``` ### Using custom functions For a function to work with `summarise_draws()`, it needs to take a vector or matrix of numeric values and return a single numeric value or a named vector of numeric values. Additional arguments to the function can be specified in a list passed to the `.args` argument. ```{r summary-.args} weighted_mean <- function(x, wts) { sum(x * wts)/sum(wts) } summarise_draws( eight_schools_df, weighted_mean, .args = list(wts = rexp(ndraws(eight_schools_df))) ) ``` ### Specifying functions using lambda-like syntax It is also possible to specify a summary function using a one-sided formula that follows the conventions supported by `rlang::as_function()`. For example, the function ```{r standard-quantile, eval = FALSE} function(x) quantile(x, probs = c(0.4, 0.6)) ``` can be simplified to ```{r lambda-quantile, eval = FALSE} # for multiple arguments `.x` and `.y` can be used, see ?rlang::as_function ~quantile(., probs = c(0.4, 0.6)) ``` Both can be used with `summarise_draws()` and produce the same output: ```{r lambda-syntax} summarise_draws(eight_schools_df, function(x) quantile(x, probs = c(0.4, 0.6))) summarise_draws(eight_schools_df, ~quantile(.x, probs = c(0.4, 0.6))) ``` See `help("as_function", "rlang")` for details on specifying these functions. ### Other diagnostics In addition to the default diagnostic functions used by `summarise_draws()` (`rhat()`, `ess_bulk()`, `ess_tail()`), posterior also provides additional diagnostics like effective sample sizes and Monte Carlo standard errors for quantiles and standard deviations, an experimental new diagnostic called R*, and others. For a list of available diagnostics and links to their individual help pages see `help("diagnostics", "posterior")`. If you have suggestions for additional diagnostics that should be implemented in posterior, please open an issue at . ## Other methods for working with `draws` objects In addition to the methods demonstrated in this vignette, posterior has various other methods available for working with `draws` objects. The following is a (potentially incomplete) list. |**Method**|**Description**| |:----------|:---------------| | `order_draws()` | Order `draws` objects according to iteration and chain number | | `repair_draws()`| Repair indices of `draws` objects so that iterations chains, and draws are continuously and consistently numbered | |`resample_draws()` | Resample `draws` objects according to provided weights | | `thin_draws()` | Thin `draws` objects to reduce size and autocorrelation | | `weight_draws()`| Add weights to draws objects, with one weight per draw, for use in subsequent weighting operations | | `extract_variable()` | Extract a vector of draws of a single variable | | `extract_variable_matrix()` | Extract an iterations x chains matrix of draws of a single variable | | `merge_chains()` | Merge chains of `draws` objects into a single chain. | | `split_chains()` | Split chains of `draws` objects by halving the number of iterations per chain and doubling the number of chains. | If you have suggestions for additional methods that would be useful for working with `draws` objects, please open an issue at . ## References Gelman A., Carlin J. B., Stern H. S., David B. Dunson D. B., Aki Vehtari A., & Rubin D. B. (2013). *Bayesian Data Analysis, Third Edition*. Chapman and Hall/CRC. Vehtari A., Gelman A., Simpson D., Carpenter B., & Bürkner P. C. (2020). Rank-normalization, folding, and localization: An improved Rhat for assessing convergence of MCMC. *Bayesian Analysis*. posterior/inst/doc/rvar.Rmd0000755000175000017500000004331614165314652015613 0ustar nileshnilesh--- title: "rvar: The Random Variable Datatype" author: "Matthew Kay" date: "`r Sys.Date()`" output: html_vignette: toc: yes vignette: > %\VignetteIndexEntry{rvar: The Random Variable Datatype} %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} --- ## Introduction This vignette describes the `rvar()` datatype, a multidimensional, sample-based representation of random variables designed to act as much like base R arrays as possible (e.g., by supporting many math operators and functions). This format is also the basis of the `draws_rvars()` format. The `rvar()` datatype is inspired by the [rv](https://cran.r-project.org/package=rv) package and [Kerman and Gelman (2007)](https://doi.org/10.1007%2Fs11222-007-9020-4), though with a slightly different backing format (multidimensional arrays). It is also designed to interoperate with vectorized distributions in the [distributional](https://pkg.mitchelloharawild.com/distributional/) package, to be able to be used inside `data.frame()`s and `tibble()`s, and to be used with distribution visualizations in the [ggdist](https://mjskay.github.io/ggdist/) package. ```{r setup, include = FALSE} library(posterior) set.seed(1234) ``` ## The `rvars` datatype The `rvar()` datatype is a wrapper around a multidimensional array where the first dimension is the number of draws in the random variable. The most direct way to create a random variable is to pass such an array to the `rvar()` function. For example, to create a "scalar" `rvar`, one would pass a one-dimensional array or a vector whose length (here `4000`) is the desired number of draws: ```{r x_rvar_rnorm} x <- rvar(rnorm(4000, mean = 1, sd = 1)) x ``` The default display of an `rvar` shows the mean and standard deviation of each element of the array. We can create random vectors by adding an additional dimension beyond just the draws dimension to the input array: ```{r x_rvar_array} n <- 4 # length of output vector x <- rvar(array(rnorm(4000*n, mean = 1, sd = 1), dim = c(4000, n))) x ``` Or we can create a random matrix: ```{r x_matrix} rows <- 4 cols <- 3 x <- rvar(array(rnorm(4000 * rows * cols, mean = 1, sd = 1), dim = c(4000, rows, cols))) x ``` Or any array up to an arbitrary number of dimensions. The array backing an `rvar` can be accessed (and modified, with caution) via `draws_of()`: ```{r str_draws} str(draws_of(x)) ``` While the above examples assume all draws come from a single chain, `rvar`s can also contain samples from multiple chains. For example, if your array of draws has iterations as the first dimension and chains as the second dimension, you can use `with_chains = TRUE` to create an `rvar` that includes chain information: ```{r x_matrix_with_chains} iterations <- 1000 chains <- 4 rows <- 4 cols <- 3 x_array <- array( rnorm(iterations * chains * rows * cols, mean = 1, sd = 1), dim = c(iterations, chains, rows, cols) ) x <- rvar(x_array, with_chains = TRUE) x ``` Manual construction and modification of `rvar`s in this way is not always recommended unless you need it for performance reasons: several other higher-level interfaces to constructing and manipulating `rvar`s are described below. ## The `draws_rvars` datatype The `draws_rvars()` datatype, like all `draws` datatypes in posterior, contains multiple variables in a joint sample from some distribution (e.g. a posterior or prior distribution). You can construct `draws_rvars()` objects directly using the `draws_rvars()` function. The input `rvar`s must have the same number of chains and iterations, but can otherwise have different shapes: ```{r draws_rvars} d <- draws_rvars(x = x, y = rvar(rnorm(iterations * chains), nchains = 4)) d ``` Existing objects can also be converted to the `draws_rvars()` format using `as_draws_rvars()`. Below is the `example_draws("multi_normal")` dataset converted into the `draws_rvars()` format. This dataset has 100 iterations from 4 chains from the posterior of a a 3-dimensional multivariate normal model. The `mu` variable is a mean vector of length 3 and the `Sigma` variable is a $3 \times 3$ covariance matrix: ```{r post} post <- as_draws_rvars(example_draws("multi_normal")) post ``` The `draws_rvars()` datatype works much the same way that other `draws` formats do; see the main package vignette at `vignette("posterior")` for an introduction to `draws` objects. One difference is that `draws_rvars` counts variables differently, because it allows variables to be multidimensional. For example, the `post` object above contains two variables, `mu` and `Sigma`: ```{r variables_draws_rvars} variables(post) ``` But converted to a `draws_list()`, it contains one variable for each combination of the dimensions of its variables: ```{r variables_draws_list} variables(as_draws_list(post)) ``` ## Math with `rvar`s The `rvar()` datatype implements most math operations, including basic arithmetic, functions in the *Math* and *Summary* groups, like `log()` and `exp()` (see `help("groupGeneric")` for a list), and more. Binary operators can be performed between multiple `rvar`s or between `rvar`s and `numeric`s. A simple example: ```{r mu_plus_1} mu <- post$mu Sigma <- post$Sigma mu + 1 ``` Matrix multiplication is also implemented (using a tensor product under the hood). Because the normal matrix multiplication operator in R (`%*%`) cannot be properly implemented for S3 datatypes, `rvar` uses `%**%` instead. A trivial example: ```{r matrix_mult} Sigma %**% diag(1:3) ``` The set of mathematical functions and operators supported by `rvar`s includes: | Group | Functions and operators | |:----------------------------|:------------------------| | Arithmetic operators | `+`, `-`, `*`, `/`, `^`, `%%`, `%/%` | | Logical operators | `&`, `|`, `!` | | Comparison operators | `==`, `!=`, `<`, `<=`, `>=`, `>` | | Matrix multiplication | `%**%` | | Basic functions | `abs()`, `sign()`
`sqrt()`
`floor()`, `ceiling()`, `trunc()`, `round()`, `signif()` | | Logarithms and exponentials | `exp()`, `expm1()`
`log()`, `log10()`, `log2()`, `log1p()` | | Trigonometric functions | `cos()`, `sin()`, `tan()`
`cospi()`, `sinpi()`, `tanpi()`
`acos()`, `asin()`, `atan()`| | Hyperbolic functions | `cosh()`, `sinh()`, `tanh()`
`acosh()`, `asinh()`, `atanh()` | | Special functions | `lgamma()`, `gamma()`, `digamma()`, `trigamma()` | | Cumulative functions | `cumsum()`, `cumprod()`, `cummax()`, `cummin()` | | Array transposition | `t()`, `aperm()` | | Matrix decomposition | `chol()` | ## Expectations and summary functions The `E()` function is an alias of `mean()`, producing means within each cell of an `rvar`. For example, given `mu`: ```{r mu} mu ``` We can get the expectation of each cell of `mu`: ```{r E_mu} E(mu) ``` Expectations of logical expressions are probabilities, and can be computed either with `E()` / `mean()` or with `Pr()`. `Pr()` is provided as notational sugar, but also checks that the input is a logical variable before taking the mean: ```{r Pr} Pr(mu > 0) ``` More generally, the `rvar` data type provides two types of summary functions: 1. Summary functions that mimic base-R vector summary functions, except applied to `rvar` vectors. These apply their summaries **over** elements of the input vectors **within** each draw, generally returning an `rvar` of length 1. These functions are prefixed with `rvar_` as a reminder that they return `rvar`s. Here is an example of `rvar_mean()`: ```{r rvar_mean_mu} rvar_mean(mu) ``` 2. Summary functions that summarise **within** elements of input vectors and **over** draws. These summary functions generally return base arrays (`numeric` or `logical`) of the same shape as the input `rvar`, and are especially useful for diagnostic summaries. These summary functions are not prefixed with `rvar_` as they do not return `rvar`s. Here is an example of `mean()`: ```{r mean_mu} mean(mu) ``` You should expect the same values from these functions (though in a different shape) when you use them with `summarise_draws()`, for example: ```{r summarise_draws_mu_mean} summarise_draws(mu, mean) ``` Here is a table of both types of summary functions: | | 1. Summarise *within* draws,
*over* elements | 2. Summarise *over* draws,
*within* elements
| |--------------------------|:------------------------------------------------|:----------------------------------------------------| | **Output format**
of `res = f(x)` | `rvar` of length 1 | `array` of same shape as input `rvar` | | **Help page** | `help("rvar-summaries-within-draws")` | `help("rvar-summaries-over-draws")` | | Numeric summaries | `rvar_median()`
`rvar_sum()`, `rvar_prod()`
`rvar_min()`, `rvar_max()`| `median()`
`sum()`, `prod()`
`min()`, `max()`| | Mean | `rvar_mean()`
*N/A* | `mean()`, `E()`
`Pr()`: enforces that input is `logical` | | Spread | `rvar_sd()`
`rvar_var()`
`rvar_mad()` | `sd()`
`var()`, `variance()`
`mad()`| | Range | `rvar_range()`
**Note:** `length(res) == 2` | `range()`
**Note:** `dim(res) == c(2, dim(x))` | | Quantiles | `rvar_quantile()`
**Note:** `length(res) == length(probs)` | `quantile()`
**Note:** `dim(res) == c(length(probs), dim(x))` | | Logical summaries | `rvar_all()`, `rvar_any()` | `all()`, `any()` | | Special value predicates | `rvar_is_finite()`
`rvar_is_infinite()`
`rvar_is_nan()`
`rvar_is_na()`
**Note:** `dim(res) == dim(x)`. These functions act within draws but do not summarise over elements. | `is.finite()`
`is.infinite()`
`is.nan()`
`is.na()`
**Note:** `res[i] == TRUE` if `x[i]` has any draws matching predicate (except for `is.finite()`, where all draws in `x[i]` must match) | | Diagnostics | *N/A* | `ess_basic()`, `ess_bulk()`, `ess_quantile()`, `ess_sd()`, `ess_tail()`,
`mcse_mean()`, `mcse_quantile()`, `mcse_sd()`
`rhat()`, `rhat_basic()`| ## Constants Constant `rvar`s can be constructed by converting numeric vectors or arrays into `rvar`s using `as_rvar()`, which will return an `rvar` with one draw and the same dimensions as its input: ```{r const} const <- as_rvar(1:3) const ``` While normally `rvar`s must have the same number of draws to be used in the same expression, `rvar`s with one draw are treated like constants, and can be combined with other `rvar`s: ```{r mu_plus_const} mu + const ``` ## Using existing R functions and expressions with `rvar`s While `rvar`s attempt to emulate as much of the functionality of base R arrays as possible, there are situations in which an existing R function may not work directly with an `rvar`. There are several approaches to solving this problem. For example, say you wish to generate samples from the following expression for $\mu$, $\sigma$, and $x$: $$ \begin{align} \left[\begin{matrix}\mu_1 \\ \vdots \\ \mu_4 \end{matrix}\right] &\sim \textrm{Normal}\left(\left[\begin{matrix}1 \\ \vdots \\ 4 \end{matrix}\right],1\right)\\ \sigma &\sim \textrm{Gamma}(1,1)\\ \left[\begin{matrix}x_1 \\ \vdots \\ x_4 \end{matrix}\right] &\sim \textrm{Normal}\left(\left[\begin{matrix}\mu_1 \\ \vdots \\ \mu_4 \end{matrix}\right], \sigma\right) \end{align} $$ There are three different approaches you might take to doing this: converting existing R functions with `rfun()`, executing expressions of random variables with `rdo()`, or evaluating random number generator functions using `rvar_rng()`. ### Converting functions with `rfun()` The `rfun()` wrapper converts an existing R function into a new function that `rvar`s can be passed to it as arguments, and which will return `rvar`s. We can use `rfun()` to convert the base `rnorm()` and `rgamma()` random number generating functions into functions that accept and return `rvar`s: ```{r rfun_defs} rvar_norm <- rfun(rnorm) rvar_gamma <- rfun(rgamma) ``` Then we can translate the above example into code using those functions: ```{r rfun_ex} mu <- rvar_norm(4, mean = 1:4, sd = 1) sigma <- rvar_gamma(1, shape = 1, rate = 1) x <- rvar_norm(4, mu, sigma) x ``` While `rfun()`-converted functions work well for prototyping, they will generally speaking be slower than functions designed specifically for `rvar`s. Thus, you may find you need to adopt other strategies (like `rvar_rng()`, described below; or re-writing functions to support `rvar` directly using math operators and/or the `draws_of()` function). ### Evaluating expressions with `rdo()` An alternative to `rfun()` is to use `rdo()`, which can be passed nearly-arbitrary R expressions. The expression will be executed multiple times to construct an `rvar`. E.g., we can write an expression for `mu` like in the above example: ```{r mu_rdo} mu <- rdo(rnorm(4, mean = 1:4, sd = 1)) mu ``` We can also control the number of draws using the `ndraws` argument: ```{r mu_rdo_ndraws} mu <- rdo(rnorm(4, mean = 1:4, sd = 1), ndraws = 1000) mu ``` `rdo()` expressions can also contain other `rvar`s, so long as all `rvar`s in the expression have the same number of draws. Thus, we can re-write the example above that used `rfun()` as follows: ```{r rdo_ex} mu <- rdo(rnorm(4, mean = 1:4, sd = 1)) sigma <- rdo(rgamma(1, shape = 1, rate = 1)) x <- rdo(rnorm(4, mu, sigma)) x ``` Like `rfun()`, `rdo()` is not necessarily fast, so you may find it more useful for prototyping than production code. ### Evaluating random number generators with `rvar_rng()` `rvar_rng()` is an alternative to `rfun()`/`rdo()` designed specifically to work with random number generating functions that follow the typical API of such functions in base R. Such functions, like `rnorm()`, `rgamma()`, `rbinom()`, etc all following this interface: - They have a first argument, `n`, giving the number of draws to take from the distribution. - Their arguments for distribution parameters (`mean`, `sd`, `shape`, `rate`, etc.) are vectorized. - They return a single vector of length `n`, representing `n` draws from the distribution. You can use any function with this interface with `rvar_rng()`, and it will adapt it to be able to take `rvar` arguments and return an `rvar`, as follows: ```{r rvar_r_ex} mu <- rvar_rng(rnorm, 4, mean = 1:4, sd = 1) sigma <- rvar_rng(rgamma, 1, shape = 1, rate = 1) x <- rvar_rng(rnorm, 4, mu, sigma) x ``` In contrast to the `rfun()` and `rdo()` examples above, `rvar_rng()` takes advantage of the existing vectorization of the underlying random number generating function to execute quickly. ## Broadcasting Broadcasting for `rvar`s does not follow R's vector recycling rules. Instead, when two variables with different dimensions are being used with basic arithmetic functions, dimensions are added until both variables have the same number of dimensions. If two variables $x$ and $y$ differ on the length of dimension $d$, they can be broadcast to the same size so long as one of the variables has dimension $d$ of size 1. Then that variable will be broadcast up to the same size as the other variable along that dimension. If two variables disagree on the size of a dimension and neither has size 1, it is an error. For example, consider this random matrix: ```{r X_matrix} X <- rdo(rnorm(12, 1:12), dim = c(4,3)) X ``` And this vector of length 3: ```{r y_vector} y <- rdo(rnorm(3, 3:1)) y ``` If we attempt to add `X` and `y`, it will produce an error as vectors are by default treated as column vectors, and `y` has length 3 while columns of `X` have length 4: ```{r X_plus_y, error = TRUE} X + y ``` By contrast, R arrays of the same shape will simply recycle `y` until it is the same length as `X` (regardless of the dimensions). Thus will produce a result, though likely not the intended result: ```{r mean_X_plus_y} mean(X) + mean(y) ``` On the other hand, if y were a row vector... ```{r row_y} row_y = t(y) row_y ``` ...it would have the same number of columns as `X` and contain only one row, so it can be broadcast along rows of `X`: ```{r X_plus_row_y} X + row_y ``` ## Applying functions over `rvar`s The `rvar` data type supplies an implementation of `as.list()`, which should give compatibility with the base R family of functions for applying functions over arrays: `apply()`, `lapply()`, `vapply()`, `sapply()`, etc. You can also manually use `as.list()` to convert an `rvar` into a list along its first dimension, which may be necessary for compatibility with some functions (like `purrr:map()`). For example, given this multidimensional `rvar`... ```{r multidim_array} set.seed(3456) x <- rvar_rng(rnorm, 24, mean = 1:24) dim(x) <- c(2,3,4) x ``` ... you can apply functions along the margins using `apply()` (here, a silly example): ```{r apply} apply(x, c(1,2), length) ``` One exception is that while `apply()` will work with an `rvar` input if your function returns base data types (like numerics), it will not give you simplified `rvar` arrays if your function returns an `rvar`. Thus, we supply the `rvar_apply()` function, which takes in either base arrays or `rvar` arrays and returns `rvar` arrays, and which also uses the `rvar` broadcasting rules to combine the results of the applied function. For example, you can use `rvar_apply()` with `rvar_mean()` to compute the distributions of means along one margin of an array: ```{r rvar_apply_one_dim} rvar_apply(x, 1, rvar_mean) ``` Or along multiple dimensions: ```{r rvar_apply_multi_dim} rvar_apply(x, c(2,3), rvar_mean) ``` ## Using `rvar`s in data frames and in ggplot2 `rvar`s can be used as columns in `data.frame()` or `tibble()` objects: ```{r data_frame_with_y} data.frame(x = c("a","b","c"), y) ``` This makes them convenient for adding predictions to a data frame alongside the data used to generate the predictions. `rvar`s can then be visualized with ggplot2 using the `stat_dist_...` family of geometries in the [ggdist](https://mjskay.github.io/ggdist/) package. posterior/inst/doc/posterior.R0000644000175000017500000001027514165340152016333 0ustar nileshnilesh## ----install, eval=FALSE------------------------------------------------------ # install.packages("posterior") ## ----install_github, eval=FALSE----------------------------------------------- # # install.packages("remotes") # remotes::install_github("stan-dev/posterior") ## ----setup-------------------------------------------------------------------- library("posterior") ## ----example-drawss----------------------------------------------------------- eight_schools_array <- example_draws("eight_schools") print(eight_schools_array, max_variables = 3) ## ----draws_array-structure---------------------------------------------------- str(eight_schools_array) ## ----draws_df----------------------------------------------------------------- eight_schools_df <- as_draws_df(eight_schools_array) str(eight_schools_df) print(eight_schools_df) ## ----draws_matrix-from-matrix------------------------------------------------- x <- matrix(rnorm(50), nrow = 10, ncol = 5) colnames(x) <- paste0("V", 1:5) x <- as_draws_matrix(x) print(x) ## ----draws_matrix-from-vectors------------------------------------------------ x <- draws_matrix(alpha = rnorm(50), beta = rnorm(50)) print(x) ## ----subset-df---------------------------------------------------------------- sub_df <- subset_draws(eight_schools_df, variable = "mu", chain = 1:2, iteration = 1:5) str(sub_df) ## ----subset-array------------------------------------------------------------- sub_arr <- subset_draws(eight_schools_array, variable = "mu", chain = 1:2, iteration = 1:5) str(sub_arr) ## ----subset-compare, results='hold'------------------------------------------- identical(sub_df, as_draws_df(sub_arr)) identical(as_draws_array(sub_df), sub_arr) ## ----subset-standard---------------------------------------------------------- eight_schools_array[1:5, 1:2, "mu"] ## ----mutate------------------------------------------------------------------- x <- mutate_variables(eight_schools_df, phi = (mu + tau)^2) x <- subset_draws(x, c("mu", "tau", "phi")) print(x) ## ----rename------------------------------------------------------------------- # mu is a scalar, theta is a vector x <- rename_variables(eight_schools_df, mean = mu, alpha = theta) variables(x) ## ----rename-element----------------------------------------------------------- x <- rename_variables(x, a1 = `alpha[1]`) variables(x) ## ----objects-to-bind---------------------------------------------------------- x1 <- draws_matrix(alpha = rnorm(5), beta = rnorm(5)) x2 <- draws_matrix(alpha = rnorm(5), beta = rnorm(5)) x3 <- draws_matrix(theta = rexp(5)) ## ----bind-variable------------------------------------------------------------ x4 <- bind_draws(x1, x3, along = "variable") print(x4) ## ----bind-draw---------------------------------------------------------------- x5 <- bind_draws(x1, x2, along = "draw") print(x5) ## ----summary------------------------------------------------------------------ # summarise_draws or summarize_draws summarise_draws(eight_schools_df) ## ----summary-with-measures---------------------------------------------------- # the function mcse_mean is provided by the posterior package s1 <- summarise_draws(eight_schools_df, "mean", "mcse_mean") s2 <- summarise_draws(eight_schools_df, mean, mcse_mean) identical(s1, s2) print(s1) ## ----change-summary-names----------------------------------------------------- summarise_draws(eight_schools_df, posterior_mean = mean, posterior_sd = sd) ## ----summary-.args------------------------------------------------------------ weighted_mean <- function(x, wts) { sum(x * wts)/sum(wts) } summarise_draws( eight_schools_df, weighted_mean, .args = list(wts = rexp(ndraws(eight_schools_df))) ) ## ----standard-quantile, eval = FALSE------------------------------------------ # function(x) quantile(x, probs = c(0.4, 0.6)) ## ----lambda-quantile, eval = FALSE-------------------------------------------- # # for multiple arguments `.x` and `.y` can be used, see ?rlang::as_function # ~quantile(., probs = c(0.4, 0.6)) ## ----lambda-syntax------------------------------------------------------------ summarise_draws(eight_schools_df, function(x) quantile(x, probs = c(0.4, 0.6))) summarise_draws(eight_schools_df, ~quantile(.x, probs = c(0.4, 0.6))) posterior/inst/doc/posterior.html0000644000175000017500000014764714165340153017115 0ustar nileshnilesh The posterior R package

The posterior R package

Paul Bürkner, Jonah Gabry, Matthew Kay, and Aki Vehtari

Introduction

The posterior R package is intended to provide useful tools for both users and developers of packages for fitting Bayesian models or working with output from Bayesian models. The primary goals of the package are to:

  • Efficiently convert between many different useful formats of draws (samples) from posterior or prior distributions.
  • Provide consistent methods for operations commonly performed on draws, for example, subsetting, binding, or mutating draws.
  • Provide various summaries of draws in convenient formats.
  • Provide lightweight implementations of state of the art posterior inference diagnostics.

Installation

You can install the latest official release version via

install.packages("posterior")

or the latest development version from GitHub via

# install.packages("remotes")
remotes::install_github("stan-dev/posterior")

Example

library("posterior")
## This is posterior version 1.2.0
## 
## Attaching package: 'posterior'
## The following objects are masked from 'package:stats':
## 
##     mad, sd, var

To demonstrate how to work with the posterior package, throughout the rest of this vignette we will use example posterior draws obtained from the eight schools hierarchical meta-analysis model described in Gelman et al. (2013). The variables are an estimate per school (theta[1] through theta[8]) as well as an overall mean (mu) and standard deviation across schools (tau).

eight_schools_array <- example_draws("eight_schools")
print(eight_schools_array, max_variables = 3)
## # A draws_array: 100 iterations, 4 chains, and 10 variables
## , , variable = mu
## 
##          chain
## iteration   1    2     3   4
##         1 2.0  3.0  1.79 6.5
##         2 1.5  8.2  5.99 9.1
##         3 5.8 -1.2  2.56 0.2
##         4 6.8 10.9  2.79 3.7
##         5 1.8  9.8 -0.03 5.5
## 
## , , variable = tau
## 
##          chain
## iteration   1    2    3   4
##         1 2.8 2.80  8.7 3.8
##         2 7.0 2.76  2.9 6.8
##         3 9.7 0.57  8.4 5.3
##         4 4.8 2.45  4.4 1.6
##         5 2.8 2.80 11.0 3.0
## 
## , , variable = theta[1]
## 
##          chain
## iteration     1     2    3     4
##         1  3.96  6.26 13.3  5.78
##         2  0.12  9.32  6.3  2.09
##         3 21.25 -0.97 10.6 15.72
##         4 14.70 12.45  5.4  2.69
##         5  5.96  9.75  8.2 -0.91
## 
## # ... with 95 more iterations, and 7 more variables

The structure of this object is explained in the next section.

Draws formats

Available formats

Because different formats are preferable in different situations, posterior supports multiple formats and easy conversion between them. The currently supported formats are:

  • draws_array: An iterations by chains by variables array.
  • draws_matrix: A draws (iterations x chains) by variables array.
  • draws_df: A draws by variables data frame with addition meta columns .chain, .iteration, .draw.
  • draws_list: A list with one sublist per chain. Each sublist is a named list with one vector of iterations per variable.
  • draws_rvars: A list of random variable rvar objects, one per variable. See vignette("rvar") for an introduction to this new data type.

These formats are essentially base R object classes and can be used as such. For example, a draws_matrix object is just a matrix with a little more consistency (e.g., no dropping of dimensions with one level when indexing) and additional methods. The exception to this is the draws_rvars format, which contains rvar objects that behave somewhat like arrays but are really a unique data type. See the separate vignette on the rvar and draws_rvars data types for details.

The draws for our example come as a draws_array object with 100 iterations, 4 chains, and 10 variables:

str(eight_schools_array)
##  'draws_array' num [1:100, 1:4, 1:10] 2.01 1.46 5.81 6.85 1.81 ...
##  - attr(*, "dimnames")=List of 3
##   ..$ iteration: chr [1:100] "1" "2" "3" "4" ...
##   ..$ chain    : chr [1:4] "1" "2" "3" "4"
##   ..$ variable : chr [1:10] "mu" "tau" "theta[1]" "theta[2]" ...

Converting between formats

Each of the formats has a method as_draws_<format> (e.g., as_draws_list()) for creating an object of the class from any of the other formats. As a demonstration we can convert the example draws_array to a draws_df, a data frame with additional meta information. To convert to a draws_df we use as_draws_df().

eight_schools_df <- as_draws_df(eight_schools_array)
str(eight_schools_df)
## draws_df [400 × 13] (S3: draws_df/draws/tbl_df/tbl/data.frame)
##  $ mu        : num [1:400] 2.01 1.46 5.81 6.85 1.81 ...
##  $ tau       : num [1:400] 2.77 6.98 9.68 4.79 2.85 ...
##  $ theta[1]  : num [1:400] 3.962 0.124 21.251 14.7 5.96 ...
##  $ theta[2]  : num [1:400] 0.271 -0.069 14.931 8.586 1.156 ...
##  $ theta[3]  : num [1:400] -0.743 0.952 1.829 2.675 3.109 ...
##  $ theta[4]  : num [1:400] 2.1 7.28 1.38 4.39 1.99 ...
##  $ theta[5]  : num [1:400] 0.923 -0.062 0.531 4.758 0.769 ...
##  $ theta[6]  : num [1:400] 1.65 11.26 7.16 8.1 4.66 ...
##  $ theta[7]  : num [1:400] 3.32 9.62 14.8 9.49 1.21 ...
##  $ theta[8]  : num [1:400] 4.85 -8.64 -1.74 5.28 -4.54 ...
##  $ .chain    : int [1:400] 1 1 1 1 1 1 1 1 1 1 ...
##  $ .iteration: int [1:400] 1 2 3 4 5 6 7 8 9 10 ...
##  $ .draw     : int [1:400] 1 2 3 4 5 6 7 8 9 10 ...
print(eight_schools_df)
## # A draws_df: 100 iterations, 4 chains, and 10 variables
##      mu tau theta[1] theta[2] theta[3] theta[4] theta[5] theta[6]
## 1  2.01 2.8     3.96    0.271    -0.74      2.1    0.923      1.7
## 2  1.46 7.0     0.12   -0.069     0.95      7.3   -0.062     11.3
## 3  5.81 9.7    21.25   14.931     1.83      1.4    0.531      7.2
## 4  6.85 4.8    14.70    8.586     2.67      4.4    4.758      8.1
## 5  1.81 2.8     5.96    1.156     3.11      2.0    0.769      4.7
## 6  3.84 4.1     5.76    9.909    -1.00      5.3    5.889     -1.7
## 7  5.47 4.0     4.03    4.151    10.15      6.6    3.741     -2.2
## 8  1.20 1.5    -0.28    1.846     0.47      4.3    1.467      3.3
## 9  0.15 3.9     1.81    0.661     0.86      4.5   -1.025      1.1
## 10 7.17 1.8     6.08    8.102     7.68      5.6    7.106      8.5
## # ... with 390 more draws, and 2 more variables
## # ... hidden reserved variables {'.chain', '.iteration', '.draw'}

Converting regular R objects to draws formats

The example draws already come in a format natively supported by posterior, but we can of course also import the draws from other sources like common base R objects.

Example: create draws_matrix from a matrix

In addition to converting other draws objects to the draws_matrix format, the as_draws_matrix() function will convert a regular matrix to a draws_matrix.

x <- matrix(rnorm(50), nrow = 10, ncol = 5)
colnames(x) <- paste0("V", 1:5)
x <- as_draws_matrix(x)
print(x)
## # A draws_matrix: 10 iterations, 1 chains, and 5 variables
##     variable
## draw    V1    V2     V3     V4     V5
##   1  -1.22  1.19 -0.023 -0.188 -0.411
##   2   0.42 -0.62  0.706 -0.928 -0.405
##   3   0.71 -0.97 -2.393  0.971  0.090
##   4   1.01  0.71  1.075  1.217  0.573
##   5   1.03  1.78 -1.011  0.977  0.068
##   6   2.35  1.45 -0.439 -1.772  1.945
##   7  -0.51 -0.49 -0.761  0.440  1.402
##   8  -0.49  0.49 -1.068 -0.097 -0.126
##   9  -1.22 -1.41 -0.264 -0.078 -0.877
##   10  0.91 -0.49 -0.705  0.190  0.496

Because the matrix was converted to a draws_matrix, all of the methods for working with draws objects described in subsequent sections of this vignette will now be available.

Instead of as_draws_matrix() we also could have just used as_draws(), which attempts to find the closest available format to the input object. In this case the result would be a draws_matrix object either way.

Example: create draws_matrix from multiple vectors

In addition to the as_draws_matrix() converter function there is also a draws_matrix() constructor function that can be used to create draws matrix from multiple vectors.

x <- draws_matrix(alpha = rnorm(50), beta = rnorm(50))
print(x)
## # A draws_matrix: 50 iterations, 1 chains, and 2 variables
##     variable
## draw alpha   beta
##   1   0.55 -0.494
##   2   0.39 -0.693
##   3  -1.18  0.484
##   4   0.48  0.677
##   5  -1.70  1.026
##   6   0.40 -0.177
##   7  -1.00 -0.595
##   8  -0.90  1.177
##   9  -1.81 -1.235
##   10 -1.24 -0.062
## # ... with 40 more draws

Analogous functions exist for the other draws formats and are used similarly.

Manipulating draws objects

The posterior package provides many methods for manipulating draws objects in useful ways. In this section we demonstrate several of the most commonly used methods. These methods, like the other methods in posterior, are available for every supported draws format.

Subsetting

Subsetting draws objects can be done according to various aspects of the draws (iterations, chains, or variables). The posterior package provides a convenient interface for this purpose via subset_draws(). For example, here is the code to extract the first five iterations of the first two chains of the variable mu.

sub_df <- subset_draws(eight_schools_df, variable = "mu", chain = 1:2, iteration = 1:5)
str(sub_df)
## draws_df [10 × 4] (S3: draws_df/draws/tbl_df/tbl/data.frame)
##  $ mu        : num [1:10] 2.01 1.46 5.81 6.85 1.81 ...
##  $ .chain    : int [1:10] 1 1 1 1 1 2 2 2 2 2
##  $ .iteration: int [1:10] 1 2 3 4 5 1 2 3 4 5
##  $ .draw     : int [1:10] 1 2 3 4 5 6 7 8 9 10

The same call to subset_draws() can be used regardless of the draws format. For example, here is the same code except replacing the draws_df object with the draws_array object.

sub_arr <- subset_draws(eight_schools_array, variable = "mu", chain = 1:2, iteration = 1:5)
str(sub_arr)
##  'draws_array' num [1:5, 1:2, 1] 2.01 1.46 5.81 6.85 1.81 ...
##  - attr(*, "dimnames")=List of 3
##   ..$ iteration: chr [1:5] "1" "2" "3" "4" ...
##   ..$ chain    : chr [1:2] "1" "2"
##   ..$ variable : chr "mu"

We can check that these two calls to subset_draws() (the first with the data frame, the second with the array) produce the same result.

identical(sub_df, as_draws_df(sub_arr))
identical(as_draws_array(sub_df), sub_arr)
## [1] TRUE
## [1] TRUE

It is also possible to use standard R subsetting syntax with draws objects. The following is equivalent to the use of subset_draws() with the array above.

eight_schools_array[1:5, 1:2, "mu"]
## # A draws_array: 5 iterations, 2 chains, and 1 variables
## , , variable = mu
## 
##          chain
## iteration   1    2
##         1 2.0  3.0
##         2 1.5  8.2
##         3 5.8 -1.2
##         4 6.8 10.9
##         5 1.8  9.8

The major difference between how posterior behaves when indexing and how base R behaves is that posterior will not drop dimensions with only one level. That is, even though there is only one variable left after subsetting, the result of the subsetting above is still a draws_array and not a draws_matrix.

Mutating (transformations of variables)

The magic of having obtained draws from the joint posterior (or prior) distribution of a set of variables is that these draws can also be used to obtain draws from any other variable that is a function of the original variables. That is, if we are interested in the posterior distribution of, say, phi = (mu + tau)^2 all we have to do is to perform the transformation for each of the individual draws to obtain draws from the posterior distribution of the transformed variable. This procedure is handled by mutate_variables().

x <- mutate_variables(eight_schools_df, phi = (mu + tau)^2)
x <- subset_draws(x, c("mu", "tau", "phi"))
print(x)
## # A draws_df: 100 iterations, 4 chains, and 3 variables
##      mu tau   phi
## 1  2.01 2.8  22.8
## 2  1.46 7.0  71.2
## 3  5.81 9.7 240.0
## 4  6.85 4.8 135.4
## 5  1.81 2.8  21.7
## 6  3.84 4.1  62.8
## 7  5.47 4.0  88.8
## 8  1.20 1.5   7.1
## 9  0.15 3.9  16.6
## 10 7.17 1.8  79.9
## # ... with 390 more draws
## # ... hidden reserved variables {'.chain', '.iteration', '.draw'}

Renaming

To rename variables use rename_variables(). Here we rename the scalar mu to mean and the vector theta to alpha.

# mu is a scalar, theta is a vector
x <- rename_variables(eight_schools_df, mean = mu, alpha = theta)
variables(x)
##  [1] "mean"     "tau"      "alpha[1]" "alpha[2]" "alpha[3]" "alpha[4]"
##  [7] "alpha[5]" "alpha[6]" "alpha[7]" "alpha[8]"

In the call to rename_variables() above, mu and theta can be quoted or unquoted.

It is also possible to rename individual elements of non-scalar parameters, for example we can rename just the first element of alpha:

x <- rename_variables(x, a1 = `alpha[1]`)
variables(x)
##  [1] "mean"     "tau"      "a1"       "alpha[2]" "alpha[3]" "alpha[4]"
##  [7] "alpha[5]" "alpha[6]" "alpha[7]" "alpha[8]"

Binding

The bind_draws() method can be used to combine draws objects along different dimensions. As an example, suppose we have several different draws_matrix objects:

x1 <- draws_matrix(alpha = rnorm(5), beta = rnorm(5))
x2 <- draws_matrix(alpha = rnorm(5), beta = rnorm(5))
x3 <- draws_matrix(theta = rexp(5))

We can bind x1 and x3 together along the 'variable' dimension to get a single draws_matrix with the variables from both x1 and x3:

x4 <- bind_draws(x1, x3, along = "variable")
print(x4)
## # A draws_matrix: 5 iterations, 1 chains, and 3 variables
##     variable
## draw alpha   beta   theta
##    1 -0.53 -1.669 0.42366
##    2 -0.44  0.319 0.63572
##    3  0.14  0.022 1.10042
##    4 -0.80 -0.921 2.26186
##    5 -0.07  0.147 0.00092

Because x1 and x2 have the same variables, we can bind them along the 'draw' dimension to create a single draws_matrix with more draws:

x5 <- bind_draws(x1, x2, along = "draw")
print(x5)
## # A draws_matrix: 10 iterations, 1 chains, and 2 variables
##     variable
## draw   alpha   beta
##   1  -0.5335 -1.669
##   2  -0.4444  0.319
##   3   0.1359  0.022
##   4  -0.7998 -0.921
##   5  -0.0697  0.147
##   6  -1.8118  0.972
##   7   0.2988  0.942
##   8   1.0243 -0.342
##   9  -0.0105  3.009
##   10 -0.0034 -0.602

As with all posterior methods, bind_draws() can be used with all draws formats and depending on the format different dimensions are available to bind on. For example, we can bind draws_array objects together by iteration, chain, or variable, but a 2-D draws_matrix with the chains combined can only by bound by draw and variable.

Summaries and diagnostics

summarise_draws() basic usage

Computing summaries of posterior or prior draws and convergence diagnostics for posterior draws are some of the most common tasks when working with Bayesian models fit using Markov Chain Monte Carlo (MCMC) methods. The posterior package provides a flexible interface for this purpose via summarise_draws() (or summarize_draws()), which can be passed any of the formats supported by the package.

# summarise_draws or summarize_draws
summarise_draws(eight_schools_df)
## # A tibble: 10 × 10
##    variable  mean median    sd   mad      q5   q95  rhat ess_bulk ess_tail
##    <chr>    <dbl>  <dbl> <dbl> <dbl>   <dbl> <dbl> <dbl>    <dbl>    <dbl>
##  1 mu        4.18   4.16  3.40  3.57  -0.854  9.39  1.02     558.     322.
##  2 tau       4.16   3.07  3.58  2.89   0.309 11.0   1.01     246.     202.
##  3 theta[1]  6.75   5.97  6.30  4.87  -1.23  18.9   1.01     400.     254.
##  4 theta[2]  5.25   5.13  4.63  4.25  -1.97  12.5   1.02     564.     372.
##  5 theta[3]  3.04   3.99  6.80  4.94 -10.3   11.9   1.01     312.     205.
##  6 theta[4]  4.86   4.99  4.92  4.51  -3.57  12.2   1.02     695.     252.
##  7 theta[5]  3.22   3.72  5.08  4.38  -5.93  10.8   1.01     523.     306.
##  8 theta[6]  3.99   4.14  5.16  4.81  -4.32  11.5   1.02     548.     205.
##  9 theta[7]  6.50   5.90  5.26  4.54  -1.19  15.4   1.00     434.     308.
## 10 theta[8]  4.57   4.64  5.25  4.89  -3.79  12.2   1.02     355.     146.

The result is a data frame with one row per variable and one column per summary statistic or convergence diagnostic. The summaries rhat, ess_bulk, and ess_tail are described in Vehtari et al. (2020). We can choose which summaries to compute by passing additional arguments, either functions or names of functions. For instance, if we only wanted the mean and its corresponding Monte Carlo Standard Error (MCSE) we could use either of these options:

# the function mcse_mean is provided by the posterior package
s1 <- summarise_draws(eight_schools_df, "mean", "mcse_mean") 
s2 <- summarise_draws(eight_schools_df, mean, mcse_mean) 
identical(s1, s2)
## [1] TRUE
print(s1)
## # A tibble: 10 × 3
##    variable  mean mcse_mean
##    <chr>    <dbl>     <dbl>
##  1 mu        4.18     0.150
##  2 tau       4.16     0.213
##  3 theta[1]  6.75     0.319
##  4 theta[2]  5.25     0.202
##  5 theta[3]  3.04     0.447
##  6 theta[4]  4.86     0.189
##  7 theta[5]  3.22     0.232
##  8 theta[6]  3.99     0.222
##  9 theta[7]  6.50     0.250
## 10 theta[8]  4.57     0.273

Changing column names

The column names in the output can be changed by providing the functions as name-value pairs, where the name is the name to use in the output and the value is a function name or definition. For example, here we change the names mean and sd to posterior_mean and posterior_sd.

summarise_draws(eight_schools_df, posterior_mean = mean, posterior_sd = sd)
## # A tibble: 10 × 3
##    variable posterior_mean posterior_sd
##    <chr>             <dbl>        <dbl>
##  1 mu                 4.18         3.40
##  2 tau                4.16         3.58
##  3 theta[1]           6.75         6.30
##  4 theta[2]           5.25         4.63
##  5 theta[3]           3.04         6.80
##  6 theta[4]           4.86         4.92
##  7 theta[5]           3.22         5.08
##  8 theta[6]           3.99         5.16
##  9 theta[7]           6.50         5.26
## 10 theta[8]           4.57         5.25

Using custom functions

For a function to work with summarise_draws(), it needs to take a vector or matrix of numeric values and return a single numeric value or a named vector of numeric values. Additional arguments to the function can be specified in a list passed to the .args argument.

weighted_mean <- function(x, wts) {
  sum(x * wts)/sum(wts)
}
summarise_draws(
  eight_schools_df, 
  weighted_mean, 
  .args = list(wts = rexp(ndraws(eight_schools_df)))
)
## # A tibble: 10 × 2
##    variable weighted_mean
##    <chr>            <dbl>
##  1 mu                3.91
##  2 tau               4.27
##  3 theta[1]          6.66
##  4 theta[2]          5.11
##  5 theta[3]          2.28
##  6 theta[4]          4.69
##  7 theta[5]          2.80
##  8 theta[6]          4.03
##  9 theta[7]          6.75
## 10 theta[8]          4.58

Specifying functions using lambda-like syntax

It is also possible to specify a summary function using a one-sided formula that follows the conventions supported by rlang::as_function(). For example, the function

function(x) quantile(x, probs = c(0.4, 0.6))

can be simplified to

# for multiple arguments `.x` and `.y` can be used, see ?rlang::as_function
~quantile(., probs = c(0.4, 0.6))

Both can be used with summarise_draws() and produce the same output:

summarise_draws(eight_schools_df, function(x) quantile(x, probs = c(0.4, 0.6)))
## # A tibble: 10 × 3
##    variable `40%` `60%`
##    <chr>    <dbl> <dbl>
##  1 mu        3.41  5.35
##  2 tau       2.47  3.96
##  3 theta[1]  4.95  7.01
##  4 theta[2]  4.32  6.13
##  5 theta[3]  2.54  5.33
##  6 theta[4]  3.78  6.11
##  7 theta[5]  2.69  4.69
##  8 theta[6]  2.92  5.47
##  9 theta[7]  4.81  7.33
## 10 theta[8]  3.50  5.92
summarise_draws(eight_schools_df, ~quantile(.x, probs = c(0.4, 0.6)))
## # A tibble: 10 × 3
##    variable `40%` `60%`
##    <chr>    <dbl> <dbl>
##  1 mu        3.41  5.35
##  2 tau       2.47  3.96
##  3 theta[1]  4.95  7.01
##  4 theta[2]  4.32  6.13
##  5 theta[3]  2.54  5.33
##  6 theta[4]  3.78  6.11
##  7 theta[5]  2.69  4.69
##  8 theta[6]  2.92  5.47
##  9 theta[7]  4.81  7.33
## 10 theta[8]  3.50  5.92

See help("as_function", "rlang") for details on specifying these functions.

Other diagnostics

In addition to the default diagnostic functions used by summarise_draws() (rhat(), ess_bulk(), ess_tail()), posterior also provides additional diagnostics like effective sample sizes and Monte Carlo standard errors for quantiles and standard deviations, an experimental new diagnostic called R*, and others. For a list of available diagnostics and links to their individual help pages see help("diagnostics", "posterior").

If you have suggestions for additional diagnostics that should be implemented in posterior, please open an issue at https://github.com/stan-dev/posterior/issues.

Other methods for working with draws objects

In addition to the methods demonstrated in this vignette, posterior has various other methods available for working with draws objects. The following is a (potentially incomplete) list.

Method Description
order_draws() Order draws objects according to iteration and chain number
repair_draws() Repair indices of draws objects so that iterations chains, and draws are continuously and consistently numbered
resample_draws() Resample draws objects according to provided weights
thin_draws() Thin draws objects to reduce size and autocorrelation
weight_draws() Add weights to draws objects, with one weight per draw, for use in subsequent weighting operations
extract_variable() Extract a vector of draws of a single variable
extract_variable_matrix() Extract an iterations x chains matrix of draws of a single variable
merge_chains() Merge chains of draws objects into a single chain.
split_chains() Split chains of draws objects by halving the number of iterations per chain and doubling the number of chains.

If you have suggestions for additional methods that would be useful for working with draws objects, please open an issue at https://github.com/stan-dev/posterior/issues.

References

Gelman A., Carlin J. B., Stern H. S., David B. Dunson D. B., Aki Vehtari A., & Rubin D. B. (2013). Bayesian Data Analysis, Third Edition. Chapman and Hall/CRC.

Vehtari A., Gelman A., Simpson D., Carpenter B., & Bürkner P. C. (2020). Rank-normalization, folding, and localization: An improved Rhat for assessing convergence of MCMC. Bayesian Analysis.

posterior/inst/doc/rvar.R0000644000175000017500000001121214165340154015251 0ustar nileshnilesh## ----setup, include = FALSE--------------------------------------------------- library(posterior) set.seed(1234) ## ----x_rvar_rnorm------------------------------------------------------------- x <- rvar(rnorm(4000, mean = 1, sd = 1)) x ## ----x_rvar_array------------------------------------------------------------- n <- 4 # length of output vector x <- rvar(array(rnorm(4000*n, mean = 1, sd = 1), dim = c(4000, n))) x ## ----x_matrix----------------------------------------------------------------- rows <- 4 cols <- 3 x <- rvar(array(rnorm(4000 * rows * cols, mean = 1, sd = 1), dim = c(4000, rows, cols))) x ## ----str_draws---------------------------------------------------------------- str(draws_of(x)) ## ----x_matrix_with_chains----------------------------------------------------- iterations <- 1000 chains <- 4 rows <- 4 cols <- 3 x_array <- array( rnorm(iterations * chains * rows * cols, mean = 1, sd = 1), dim = c(iterations, chains, rows, cols) ) x <- rvar(x_array, with_chains = TRUE) x ## ----draws_rvars-------------------------------------------------------------- d <- draws_rvars(x = x, y = rvar(rnorm(iterations * chains), nchains = 4)) d ## ----post--------------------------------------------------------------------- post <- as_draws_rvars(example_draws("multi_normal")) post ## ----variables_draws_rvars---------------------------------------------------- variables(post) ## ----variables_draws_list----------------------------------------------------- variables(as_draws_list(post)) ## ----mu_plus_1---------------------------------------------------------------- mu <- post$mu Sigma <- post$Sigma mu + 1 ## ----matrix_mult-------------------------------------------------------------- Sigma %**% diag(1:3) ## ----mu----------------------------------------------------------------------- mu ## ----E_mu--------------------------------------------------------------------- E(mu) ## ----Pr----------------------------------------------------------------------- Pr(mu > 0) ## ----rvar_mean_mu------------------------------------------------------------- rvar_mean(mu) ## ----mean_mu------------------------------------------------------------------ mean(mu) ## ----summarise_draws_mu_mean-------------------------------------------------- summarise_draws(mu, mean) ## ----const-------------------------------------------------------------------- const <- as_rvar(1:3) const ## ----mu_plus_const------------------------------------------------------------ mu + const ## ----rfun_defs---------------------------------------------------------------- rvar_norm <- rfun(rnorm) rvar_gamma <- rfun(rgamma) ## ----rfun_ex------------------------------------------------------------------ mu <- rvar_norm(4, mean = 1:4, sd = 1) sigma <- rvar_gamma(1, shape = 1, rate = 1) x <- rvar_norm(4, mu, sigma) x ## ----mu_rdo------------------------------------------------------------------- mu <- rdo(rnorm(4, mean = 1:4, sd = 1)) mu ## ----mu_rdo_ndraws------------------------------------------------------------ mu <- rdo(rnorm(4, mean = 1:4, sd = 1), ndraws = 1000) mu ## ----rdo_ex------------------------------------------------------------------- mu <- rdo(rnorm(4, mean = 1:4, sd = 1)) sigma <- rdo(rgamma(1, shape = 1, rate = 1)) x <- rdo(rnorm(4, mu, sigma)) x ## ----rvar_r_ex---------------------------------------------------------------- mu <- rvar_rng(rnorm, 4, mean = 1:4, sd = 1) sigma <- rvar_rng(rgamma, 1, shape = 1, rate = 1) x <- rvar_rng(rnorm, 4, mu, sigma) x ## ----X_matrix----------------------------------------------------------------- X <- rdo(rnorm(12, 1:12), dim = c(4,3)) X ## ----y_vector----------------------------------------------------------------- y <- rdo(rnorm(3, 3:1)) y ## ----X_plus_y, error = TRUE--------------------------------------------------- X + y ## ----mean_X_plus_y------------------------------------------------------------ mean(X) + mean(y) ## ----row_y-------------------------------------------------------------------- row_y = t(y) row_y ## ----X_plus_row_y------------------------------------------------------------- X + row_y ## ----multidim_array----------------------------------------------------------- set.seed(3456) x <- rvar_rng(rnorm, 24, mean = 1:24) dim(x) <- c(2,3,4) x ## ----apply-------------------------------------------------------------------- apply(x, c(1,2), length) ## ----rvar_apply_one_dim------------------------------------------------------- rvar_apply(x, 1, rvar_mean) ## ----rvar_apply_multi_dim----------------------------------------------------- rvar_apply(x, c(2,3), rvar_mean) ## ----data_frame_with_y-------------------------------------------------------- data.frame(x = c("a","b","c"), y) posterior/inst/doc/rvar.html0000644000175000017500000016140614165340154016027 0ustar nileshnilesh rvar: The Random Variable Datatype

rvar: The Random Variable Datatype

Matthew Kay

2022-01-05

Introduction

This vignette describes the rvar() datatype, a multidimensional, sample-based representation of random variables designed to act as much like base R arrays as possible (e.g., by supporting many math operators and functions). This format is also the basis of the draws_rvars() format.

The rvar() datatype is inspired by the rv package and Kerman and Gelman (2007), though with a slightly different backing format (multidimensional arrays). It is also designed to interoperate with vectorized distributions in the distributional package, to be able to be used inside data.frame()s and tibble()s, and to be used with distribution visualizations in the ggdist package.

The rvars datatype

The rvar() datatype is a wrapper around a multidimensional array where the first dimension is the number of draws in the random variable. The most direct way to create a random variable is to pass such an array to the rvar() function.

For example, to create a “scalar” rvar, one would pass a one-dimensional array or a vector whose length (here 4000) is the desired number of draws:

x <- rvar(rnorm(4000, mean = 1, sd = 1))
x
## rvar<4000>[1] mean ± sd:
## [1] 1 ± 1

The default display of an rvar shows the mean and standard deviation of each element of the array.

We can create random vectors by adding an additional dimension beyond just the draws dimension to the input array:

n <- 4   # length of output vector
x <- rvar(array(rnorm(4000*n, mean = 1, sd = 1), dim = c(4000, n)))
x
## rvar<4000>[4] mean ± sd:
## [1] 1.01 ± 0.99  1.02 ± 0.99  0.98 ± 1.00  0.99 ± 1.02

Or we can create a random matrix:

rows <- 4
cols <- 3
x <- rvar(array(rnorm(4000 * rows * cols, mean = 1, sd = 1), dim = c(4000, rows, cols)))
x
## rvar<4000>[4,3] mean ± sd:
##      [,1]         [,2]         [,3]        
## [1,] 1.00 ± 0.98  1.00 ± 1.00  0.97 ± 1.00 
## [2,] 1.00 ± 1.01  1.01 ± 1.02  0.99 ± 0.99 
## [3,] 1.02 ± 1.01  0.99 ± 1.00  1.00 ± 0.99 
## [4,] 1.01 ± 1.01  1.02 ± 1.00  1.00 ± 1.01

Or any array up to an arbitrary number of dimensions. The array backing an rvar can be accessed (and modified, with caution) via draws_of():

str(draws_of(x))
##  num [1:4000, 1:4, 1:3] -0.6879 0.0448 0.3519 1.261 -0.2197 ...
##  - attr(*, "dimnames")=List of 3
##   ..$ : chr [1:4000] "1" "2" "3" "4" ...
##   ..$ : NULL
##   ..$ : NULL

While the above examples assume all draws come from a single chain, rvars can also contain samples from multiple chains. For example, if your array of draws has iterations as the first dimension and chains as the second dimension, you can use with_chains = TRUE to create an rvar that includes chain information:

iterations <- 1000
chains <- 4
rows <- 4
cols <- 3
x_array <- array(
  rnorm(iterations * chains * rows * cols, mean = 1, sd = 1),
  dim = c(iterations, chains, rows, cols)
)
x <- rvar(x_array, with_chains = TRUE)
x
## rvar<1000,4>[4,3] mean ± sd:
##      [,1]         [,2]         [,3]        
## [1,] 0.97 ± 1.00  1.00 ± 0.99  1.02 ± 0.99 
## [2,] 1.02 ± 1.00  0.99 ± 1.01  1.01 ± 0.99 
## [3,] 1.00 ± 1.00  1.00 ± 1.00  1.01 ± 1.00 
## [4,] 1.03 ± 0.99  1.05 ± 1.00  0.98 ± 1.00

Manual construction and modification of rvars in this way is not always recommended unless you need it for performance reasons: several other higher-level interfaces to constructing and manipulating rvars are described below.

The draws_rvars datatype

The draws_rvars() datatype, like all draws datatypes in posterior, contains multiple variables in a joint sample from some distribution (e.g. a posterior or prior distribution).

You can construct draws_rvars() objects directly using the draws_rvars() function. The input rvars must have the same number of chains and iterations, but can otherwise have different shapes:

d <- draws_rvars(x = x, y = rvar(rnorm(iterations * chains), nchains = 4))
d
## # A draws_rvars: 1000 iterations, 4 chains, and 2 variables
## $x: rvar<1000,4>[4,3] mean ± sd:
##      [,1]         [,2]         [,3]        
## [1,] 0.97 ± 1.00  1.00 ± 0.99  1.02 ± 0.99 
## [2,] 1.02 ± 1.00  0.99 ± 1.01  1.01 ± 0.99 
## [3,] 1.00 ± 1.00  1.00 ± 1.00  1.01 ± 1.00 
## [4,] 1.03 ± 0.99  1.05 ± 1.00  0.98 ± 1.00 
## 
## $y: rvar<1000,4>[1] mean ± sd:
## [1] 0.0034 ± 1

Existing objects can also be converted to the draws_rvars() format using as_draws_rvars(). Below is the example_draws("multi_normal") dataset converted into the draws_rvars() format. This dataset has 100 iterations from 4 chains from the posterior of a a 3-dimensional multivariate normal model. The mu variable is a mean vector of length 3 and the Sigma variable is a \(3 \times 3\) covariance matrix:

post <- as_draws_rvars(example_draws("multi_normal"))
post
## # A draws_rvars: 100 iterations, 4 chains, and 2 variables
## $mu: rvar<100,4>[3] mean ± sd:
## [1] 0.051 ± 0.11  0.111 ± 0.20  0.186 ± 0.31 
## 
## $Sigma: rvar<100,4>[3,3] mean ± sd:
##      [,1]          [,2]          [,3]         
## [1,]  1.28 ± 0.17   0.53 ± 0.20  -0.40 ± 0.28 
## [2,]  0.53 ± 0.20   3.67 ± 0.45  -2.10 ± 0.48 
## [3,] -0.40 ± 0.28  -2.10 ± 0.48   8.12 ± 0.95

The draws_rvars() datatype works much the same way that other draws formats do; see the main package vignette at vignette("posterior") for an introduction to draws objects. One difference is that draws_rvars counts variables differently, because it allows variables to be multidimensional. For example, the post object above contains two variables, mu and Sigma:

variables(post)
## [1] "mu"    "Sigma"

But converted to a draws_list(), it contains one variable for each combination of the dimensions of its variables:

variables(as_draws_list(post))
##  [1] "mu[1]"      "mu[2]"      "mu[3]"      "Sigma[1,1]" "Sigma[2,1]"
##  [6] "Sigma[3,1]" "Sigma[1,2]" "Sigma[2,2]" "Sigma[3,2]" "Sigma[1,3]"
## [11] "Sigma[2,3]" "Sigma[3,3]"

Math with rvars

The rvar() datatype implements most math operations, including basic arithmetic, functions in the Math and Summary groups, like log() and exp() (see help("groupGeneric") for a list), and more. Binary operators can be performed between multiple rvars or between rvars and numerics. A simple example:

mu <- post$mu
Sigma <- post$Sigma

mu + 1
## rvar<100,4>[3] mean ± sd:
## [1] 1.1 ± 0.11  1.1 ± 0.20  1.2 ± 0.31

Matrix multiplication is also implemented (using a tensor product under the hood). Because the normal matrix multiplication operator in R (%*%) cannot be properly implemented for S3 datatypes, rvar uses %**% instead. A trivial example:

Sigma %**% diag(1:3)
## rvar<100,4>[3,3] mean ± sd:
##      [,1]          [,2]          [,3]         
## [1,]  1.28 ± 0.17   1.05 ± 0.40  -1.21 ± 0.85 
## [2,]  0.53 ± 0.20   7.33 ± 0.89  -6.30 ± 1.44 
## [3,] -0.40 ± 0.28  -4.20 ± 0.96  24.35 ± 2.84

The set of mathematical functions and operators supported by rvars includes:

Group Functions and operators
Arithmetic operators +, -, *, /, ^, %%, %/%
Logical operators &, |, !
Comparison operators ==, !=, <, <=, >=, >
Matrix multiplication %**%
Basic functions abs(), sign()
sqrt()
floor(), ceiling(), trunc(), round(), signif()
Logarithms and exponentials exp(), expm1()
log(), log10(), log2(), log1p()
Trigonometric functions cos(), sin(), tan()
cospi(), sinpi(), tanpi()
acos(), asin(), atan()
Hyperbolic functions cosh(), sinh(), tanh()
acosh(), asinh(), atanh()
Special functions lgamma(), gamma(), digamma(), trigamma()
Cumulative functions cumsum(), cumprod(), cummax(), cummin()
Array transposition t(), aperm()
Matrix decomposition chol()

Expectations and summary functions

The E() function is an alias of mean(), producing means within each cell of an rvar. For example, given mu:

mu
## rvar<100,4>[3] mean ± sd:
## [1] 0.051 ± 0.11  0.111 ± 0.20  0.186 ± 0.31

We can get the expectation of each cell of mu:

E(mu)
## [1] 0.05139284 0.11132363 0.18581977

Expectations of logical expressions are probabilities, and can be computed either with E() / mean() or with Pr(). Pr() is provided as notational sugar, but also checks that the input is a logical variable before taking the mean:

Pr(mu > 0)
## [1] 0.6600 0.6900 0.7025

More generally, the rvar data type provides two types of summary functions:

  1. Summary functions that mimic base-R vector summary functions, except applied to rvar vectors. These apply their summaries over elements of the input vectors within each draw, generally returning an rvar of length 1. These functions are prefixed with rvar_ as a reminder that they return rvars. Here is an example of rvar_mean():

    rvar_mean(mu)
    ## rvar<100,4>[1] mean ± sd:
    ## [1] 0.12 ± 0.11
  2. Summary functions that summarise within elements of input vectors and over draws. These summary functions generally return base arrays (numeric or logical) of the same shape as the input rvar, and are especially useful for diagnostic summaries. These summary functions are not prefixed with rvar_ as they do not return rvars. Here is an example of mean():

    mean(mu)
    ## [1] 0.05139284 0.11132363 0.18581977

    You should expect the same values from these functions (though in a different shape) when you use them with summarise_draws(), for example:

    summarise_draws(mu, mean)
    ## # A tibble: 3 × 2
    ##   variable   mean
    ##   <chr>     <dbl>
    ## 1 mu[1]    0.0514
    ## 2 mu[2]    0.111 
    ## 3 mu[3]    0.186

Here is a table of both types of summary functions:

1. Summarise within draws,
over elements
2. Summarise over draws,
within elements
Output format
of res = f(x)
rvar of length 1 array of same shape as input rvar
Help page help("rvar-summaries-within-draws") help("rvar-summaries-over-draws")
Numeric summaries rvar_median()
rvar_sum(), rvar_prod()
rvar_min(), rvar_max()
median()
sum(), prod()
min(), max()
Mean rvar_mean()
N/A
mean(), E()
Pr(): enforces that input is logical
Spread rvar_sd()
rvar_var()
rvar_mad()
sd()
var(), variance()
mad()
Range rvar_range()
Note: length(res) == 2
range()
Note: dim(res) == c(2, dim(x))
Quantiles rvar_quantile()
Note: length(res) == length(probs)
quantile()
Note: dim(res) == c(length(probs), dim(x))
Logical summaries rvar_all(), rvar_any() all(), any()
Special value predicates rvar_is_finite()
rvar_is_infinite()
rvar_is_nan()
rvar_is_na()
Note: dim(res) == dim(x). These functions act within draws but do not summarise over elements.
is.finite()
is.infinite()
is.nan()
is.na()
Note: res[i] == TRUE if x[i] has any draws matching predicate (except for is.finite(), where all draws in x[i] must match)
Diagnostics N/A ess_basic(), ess_bulk(), ess_quantile(), ess_sd(), ess_tail(),
mcse_mean(), mcse_quantile(), mcse_sd()
rhat(), rhat_basic()

Constants

Constant rvars can be constructed by converting numeric vectors or arrays into rvars using as_rvar(), which will return an rvar with one draw and the same dimensions as its input:

const <- as_rvar(1:3)
const
## rvar<1>[3] mean ± sd:
## [1] 1 ± NA  2 ± NA  3 ± NA

While normally rvars must have the same number of draws to be used in the same expression, rvars with one draw are treated like constants, and can be combined with other rvars:

mu + const
## rvar<100,4>[3] mean ± sd:
## [1] 1.1 ± 0.11  2.1 ± 0.20  3.2 ± 0.31

Using existing R functions and expressions with rvars

While rvars attempt to emulate as much of the functionality of base R arrays as possible, there are situations in which an existing R function may not work directly with an rvar. There are several approaches to solving this problem.

For example, say you wish to generate samples from the following expression for \(\mu\), \(\sigma\), and \(x\):

\[ \begin{align} \left[\begin{matrix}\mu_1 \\ \vdots \\ \mu_4 \end{matrix}\right] &\sim \textrm{Normal}\left(\left[\begin{matrix}1 \\ \vdots \\ 4 \end{matrix}\right],1\right)\\ \sigma &\sim \textrm{Gamma}(1,1)\\ \left[\begin{matrix}x_1 \\ \vdots \\ x_4 \end{matrix}\right] &\sim \textrm{Normal}\left(\left[\begin{matrix}\mu_1 \\ \vdots \\ \mu_4 \end{matrix}\right], \sigma\right) \end{align} \]

There are three different approaches you might take to doing this: converting existing R functions with rfun(), executing expressions of random variables with rdo(), or evaluating random number generator functions using rvar_rng().

Converting functions with rfun()

The rfun() wrapper converts an existing R function into a new function that rvars can be passed to it as arguments, and which will return rvars. We can use rfun() to convert the base rnorm() and rgamma() random number generating functions into functions that accept and return rvars:

rvar_norm <- rfun(rnorm)
rvar_gamma <- rfun(rgamma)

Then we can translate the above example into code using those functions:

mu <- rvar_norm(4, mean = 1:4, sd = 1)
sigma <- rvar_gamma(1, shape = 1, rate = 1)
x <- rvar_norm(4, mu, sigma)
x
## rvar<4000>[4] mean ± sd:
## [1] 0.99 ± 1.7  1.98 ± 1.7  2.99 ± 1.8  4.01 ± 1.7

While rfun()-converted functions work well for prototyping, they will generally speaking be slower than functions designed specifically for rvars. Thus, you may find you need to adopt other strategies (like rvar_rng(), described below; or re-writing functions to support rvar directly using math operators and/or the draws_of() function).

Evaluating expressions with rdo()

An alternative to rfun() is to use rdo(), which can be passed nearly-arbitrary R expressions. The expression will be executed multiple times to construct an rvar. E.g., we can write an expression for mu like in the above example:

mu <- rdo(rnorm(4, mean = 1:4, sd = 1))
mu
## rvar<4000>[4] mean ± sd:
## [1] 1 ± 1.01  2 ± 1.01  3 ± 0.99  4 ± 1.02

We can also control the number of draws using the ndraws argument:

mu <- rdo(rnorm(4, mean = 1:4, sd = 1), ndraws = 1000)
mu
## rvar<1000>[4] mean ± sd:
## [1] 0.98 ± 0.98  2.03 ± 1.03  2.98 ± 0.98  4.03 ± 1.02

rdo() expressions can also contain other rvars, so long as all rvars in the expression have the same number of draws. Thus, we can re-write the example above that used rfun() as follows:

mu <- rdo(rnorm(4, mean = 1:4, sd = 1))
sigma <- rdo(rgamma(1, shape = 1, rate = 1))
x <- rdo(rnorm(4, mu, sigma))
x
## rvar<4000>[4] mean ± sd:
## [1] 1 ± 1.7  2 ± 1.7  3 ± 1.7  4 ± 1.7

Like rfun(), rdo() is not necessarily fast, so you may find it more useful for prototyping than production code.

Evaluating random number generators with rvar_rng()

rvar_rng() is an alternative to rfun()/rdo() designed specifically to work with random number generating functions that follow the typical API of such functions in base R. Such functions, like rnorm(), rgamma(), rbinom(), etc all following this interface:

  • They have a first argument, n, giving the number of draws to take from the distribution.
  • Their arguments for distribution parameters (mean, sd, shape, rate, etc.) are vectorized.
  • They return a single vector of length n, representing n draws from the distribution.

You can use any function with this interface with rvar_rng(), and it will adapt it to be able to take rvar arguments and return an rvar, as follows:

mu <- rvar_rng(rnorm, 4, mean = 1:4, sd = 1)
sigma <- rvar_rng(rgamma, 1, shape = 1, rate = 1)
x <- rvar_rng(rnorm, 4, mu, sigma)
x
## rvar<4000>[4] mean ± sd:
## [1] 1 ± 1.7  2 ± 1.8  3 ± 1.7  4 ± 1.7

In contrast to the rfun() and rdo() examples above, rvar_rng() takes advantage of the existing vectorization of the underlying random number generating function to execute quickly.

Broadcasting

Broadcasting for rvars does not follow R’s vector recycling rules. Instead, when two variables with different dimensions are being used with basic arithmetic functions, dimensions are added until both variables have the same number of dimensions. If two variables \(x\) and \(y\) differ on the length of dimension \(d\), they can be broadcast to the same size so long as one of the variables has dimension \(d\) of size 1. Then that variable will be broadcast up to the same size as the other variable along that dimension. If two variables disagree on the size of a dimension and neither has size 1, it is an error.

For example, consider this random matrix:

X <- rdo(rnorm(12, 1:12), dim = c(4,3))
X
## rvar<4000>[4,3] mean ± sd:
##      [,1]       [,2]       [,3]      
## [1,]  1 ± 0.99   5 ± 1.00   9 ± 1.02 
## [2,]  2 ± 1.01   6 ± 0.99  10 ± 1.01 
## [3,]  3 ± 1.00   7 ± 1.01  11 ± 1.00 
## [4,]  4 ± 1.01   8 ± 1.02  12 ± 1.01

And this vector of length 3:

y <- rdo(rnorm(3, 3:1))
y
## rvar<4000>[3] mean ± sd:
## [1] 3 ± 1  2 ± 1  1 ± 1

If we attempt to add X and y, it will produce an error as vectors are by default treated as column vectors, and y has length 3 while columns of X have length 4:

X + y
## Error: Cannot broadcast array of shape [4000,3,1] to array of shape [4000,4,3]:
## All dimensions must be 1 or equal.

By contrast, R arrays of the same shape will simply recycle y until it is the same length as X (regardless of the dimensions). Thus will produce a result, though likely not the intended result:

mean(X) + mean(y)
##          [,1]     [,2]     [,3]
## [1,] 4.010833 6.970957 10.01651
## [2,] 3.972172 7.033491 12.97111
## [3,] 4.019509 9.979396 12.97034
## [4,] 6.990685 9.978003 13.01769

On the other hand, if y were a row vector…

row_y = t(y)
row_y
## rvar<4000>[1,3] mean ± sd:
##      [,1]   [,2]   [,3]  
## [1,] 3 ± 1  2 ± 1  1 ± 1

…it would have the same number of columns as X and contain only one row, so it can be broadcast along rows of X:

X + row_y
## rvar<4000>[4,3] mean ± sd:
##      [,1]      [,2]      [,3]     
## [1,]  4 ± 1.4   7 ± 1.4  10 ± 1.4 
## [2,]  5 ± 1.4   8 ± 1.4  11 ± 1.4 
## [3,]  6 ± 1.4   9 ± 1.4  12 ± 1.4 
## [4,]  7 ± 1.4  10 ± 1.5  13 ± 1.4

Applying functions over rvars

The rvar data type supplies an implementation of as.list(), which should give compatibility with the base R family of functions for applying functions over arrays: apply(), lapply(), vapply(), sapply(), etc. You can also manually use as.list() to convert an rvar into a list along its first dimension, which may be necessary for compatibility with some functions (like purrr:map()).

For example, given this multidimensional rvar

set.seed(3456)
x <- rvar_rng(rnorm, 24, mean = 1:24)
dim(x) <- c(2,3,4)
x
## rvar<4000>[2,3,4] mean ± sd:
## , , 1
## 
##      [,1]       [,2]       [,3]      
## [1,]  1 ± 1.00   3 ± 0.98   5 ± 1.00 
## [2,]  2 ± 1.00   4 ± 1.00   6 ± 1.01 
## 
## , , 2
## 
##      [,1]       [,2]       [,3]      
## [1,]  7 ± 1.00   9 ± 1.00  11 ± 1.03 
## [2,]  8 ± 0.98  10 ± 0.99  12 ± 1.00 
## 
## , , 3
## 
##      [,1]       [,2]       [,3]      
## [1,] 13 ± 1.00  15 ± 1.00  17 ± 0.99 
## [2,] 14 ± 1.01  16 ± 1.00  18 ± 1.00 
## 
## , , 4
## 
##      [,1]       [,2]       [,3]      
## [1,] 19 ± 0.99  21 ± 0.99  23 ± 0.99 
## [2,] 20 ± 1.00  22 ± 1.00  24 ± 1.00

… you can apply functions along the margins using apply() (here, a silly example):

apply(x, c(1,2), length)
##      [,1] [,2] [,3]
## [1,]    4    4    4
## [2,]    4    4    4

One exception is that while apply() will work with an rvar input if your function returns base data types (like numerics), it will not give you simplified rvar arrays if your function returns an rvar. Thus, we supply the rvar_apply() function, which takes in either base arrays or rvar arrays and returns rvar arrays, and which also uses the rvar broadcasting rules to combine the results of the applied function.

For example, you can use rvar_apply() with rvar_mean() to compute the distributions of means along one margin of an array:

rvar_apply(x, 1, rvar_mean)
## rvar<4000>[2] mean ± sd:
## [1] 12 ± 0.29  13 ± 0.29

Or along multiple dimensions:

rvar_apply(x, c(2,3), rvar_mean)
## rvar<4000>[3,4] mean ± sd:
##      [,1]         [,2]         [,3]         [,4]        
## [1,]  1.5 ± 0.70   7.5 ± 0.69  13.5 ± 0.71  19.5 ± 0.70 
## [2,]  3.5 ± 0.70   9.5 ± 0.71  15.5 ± 0.72  21.5 ± 0.70 
## [3,]  5.5 ± 0.71  11.5 ± 0.72  17.5 ± 0.71  23.5 ± 0.70

Using rvars in data frames and in ggplot2

rvars can be used as columns in data.frame() or tibble() objects:

data.frame(x = c("a","b","c"), y)
##   x                    y
## 1 a 2.997187 ± 1.0017769
## 2 b 1.983319 ± 0.9998891
## 3 c 1.028725 ± 1.0021676

This makes them convenient for adding predictions to a data frame alongside the data used to generate the predictions. rvars can then be visualized with ggplot2 using the stat_dist_... family of geometries in the ggdist package.

posterior/NAMESPACE0000755000175000017500000002703214165321136013662 0ustar nileshnilesh# Generated by roxygen2: do not edit by hand S3method("[",draws_array) S3method("[",draws_df) S3method("[",draws_list) S3method("[",draws_matrix) S3method("[",draws_rvars) S3method("[",rvar) S3method("[<-",rvar) S3method("[[",rvar) S3method("[[<-",rvar) S3method("dim<-",rvar) S3method("dimnames<-",rvar) S3method("names<-",rvar) S3method("variables<-",draws_array) S3method("variables<-",draws_df) S3method("variables<-",draws_list) S3method("variables<-",draws_matrix) S3method("variables<-",draws_rvars) S3method(.subset_draws,draws_array) S3method(.subset_draws,draws_df) S3method(.subset_draws,draws_list) S3method(.subset_draws,draws_matrix) S3method(.subset_draws,draws_rvars) S3method(Math,rvar) S3method(Ops,rvar) S3method(Pr,default) S3method(Pr,logical) S3method(Pr,rvar) S3method(Summary,rvar) S3method(all,equal.rvar) S3method(all,rvar) S3method(any,rvar) S3method(anyDuplicated,rvar) S3method(anyNA,rvar) S3method(aperm,rvar) S3method(as.data.frame,rvar) S3method(as.list,rvar) S3method(as.vector,rvar) S3method(as_draws,default) S3method(as_draws,draws) S3method(as_draws,rvar) S3method(as_draws_array,default) S3method(as_draws_array,draws_array) S3method(as_draws_array,draws_df) S3method(as_draws_array,draws_list) S3method(as_draws_array,draws_matrix) S3method(as_draws_array,draws_rvars) S3method(as_draws_array,mcmc) S3method(as_draws_array,mcmc.list) S3method(as_draws_df,data.frame) S3method(as_draws_df,default) S3method(as_draws_df,draws_array) S3method(as_draws_df,draws_df) S3method(as_draws_df,draws_list) S3method(as_draws_df,draws_matrix) S3method(as_draws_df,draws_rvars) S3method(as_draws_df,mcmc) S3method(as_draws_df,mcmc.list) S3method(as_draws_list,default) S3method(as_draws_list,draws_array) S3method(as_draws_list,draws_df) S3method(as_draws_list,draws_list) S3method(as_draws_list,draws_matrix) S3method(as_draws_list,draws_rvars) S3method(as_draws_list,mcmc) S3method(as_draws_list,mcmc.list) S3method(as_draws_matrix,default) S3method(as_draws_matrix,draws_array) S3method(as_draws_matrix,draws_df) S3method(as_draws_matrix,draws_list) S3method(as_draws_matrix,draws_matrix) S3method(as_draws_matrix,draws_rvars) S3method(as_draws_matrix,mcmc) S3method(as_draws_matrix,mcmc.list) S3method(as_draws_rvars,default) S3method(as_draws_rvars,draws_array) S3method(as_draws_rvars,draws_df) S3method(as_draws_rvars,draws_list) S3method(as_draws_rvars,draws_matrix) S3method(as_draws_rvars,draws_rvars) S3method(as_draws_rvars,list) S3method(as_draws_rvars,mcmc) S3method(as_draws_rvars,mcmc.list) S3method(as_draws_rvars,rvar) S3method(as_tibble,rvar) S3method(bind_draws,"NULL") S3method(bind_draws,draws_array) S3method(bind_draws,draws_df) S3method(bind_draws,draws_list) S3method(bind_draws,draws_matrix) S3method(bind_draws,draws_rvars) S3method(c,rvar) S3method(cbind,rvar) S3method(cdf,rvar) S3method(chain_ids,"NULL") S3method(chain_ids,draws_array) S3method(chain_ids,draws_df) S3method(chain_ids,draws_list) S3method(chain_ids,draws_matrix) S3method(chain_ids,draws_rvars) S3method(chol,rvar) S3method(density,rvar) S3method(dim,rvar) S3method(dimnames,rvar) S3method(draw_ids,"NULL") S3method(draw_ids,draws_array) S3method(draw_ids,draws_df) S3method(draw_ids,draws_list) S3method(draw_ids,draws_matrix) S3method(draw_ids,draws_rvars) S3method(draw_ids,rvar) S3method(duplicated,rvar) S3method(ess_basic,default) S3method(ess_basic,rvar) S3method(ess_bulk,default) S3method(ess_bulk,rvar) S3method(ess_mean,default) S3method(ess_mean,rvar) S3method(ess_quantile,default) S3method(ess_quantile,rvar) S3method(ess_sd,default) S3method(ess_sd,rvar) S3method(ess_tail,default) S3method(ess_tail,rvar) S3method(extract_variable,default) S3method(extract_variable,draws) S3method(extract_variable,draws_rvars) S3method(extract_variable_matrix,default) S3method(extract_variable_matrix,draws) S3method(extract_variable_matrix,draws_rvars) S3method(format,rvar) S3method(format_glimpse,rvar) S3method(is.array,rvar) S3method(is.finite,rvar) S3method(is.infinite,rvar) S3method(is.matrix,rvar) S3method(is.na,rvar) S3method(is.nan,rvar) S3method(iteration_ids,"NULL") S3method(iteration_ids,draws_array) S3method(iteration_ids,draws_df) S3method(iteration_ids,draws_list) S3method(iteration_ids,draws_matrix) S3method(iteration_ids,draws_rvars) S3method(iteration_ids,rvar) S3method(length,rvar) S3method(levels,rvar) S3method(mad,default) S3method(mad,rvar) S3method(max,rvar) S3method(mcse_mean,default) S3method(mcse_mean,rvar) S3method(mcse_quantile,default) S3method(mcse_quantile,rvar) S3method(mcse_sd,default) S3method(mcse_sd,rvar) S3method(mean,rvar) S3method(median,rvar) S3method(merge_chains,draws_array) S3method(merge_chains,draws_df) S3method(merge_chains,draws_list) S3method(merge_chains,draws_matrix) S3method(merge_chains,draws_rvars) S3method(merge_chains,rvar) S3method(min,rvar) S3method(mutate_variables,draws_array) S3method(mutate_variables,draws_df) S3method(mutate_variables,draws_list) S3method(mutate_variables,draws_matrix) S3method(mutate_variables,draws_rvars) S3method(names,rvar) S3method(nchains,"NULL") S3method(nchains,draws_array) S3method(nchains,draws_df) S3method(nchains,draws_list) S3method(nchains,draws_matrix) S3method(nchains,draws_rvars) S3method(nchains,rvar) S3method(ndraws,"NULL") S3method(ndraws,draws_array) S3method(ndraws,draws_df) S3method(ndraws,draws_list) S3method(ndraws,draws_matrix) S3method(ndraws,draws_rvars) S3method(ndraws,rvar) S3method(niterations,"NULL") S3method(niterations,draws_array) S3method(niterations,draws_df) S3method(niterations,draws_list) S3method(niterations,draws_matrix) S3method(niterations,draws_rvars) S3method(niterations,rvar) S3method(nvariables,"NULL") S3method(nvariables,draws) S3method(order_draws,draws_array) S3method(order_draws,draws_df) S3method(order_draws,draws_list) S3method(order_draws,draws_matrix) S3method(order_draws,draws_rvars) S3method(order_draws,rvar) S3method(pillar_shaft,rvar) S3method(print,draws_array) S3method(print,draws_df) S3method(print,draws_list) S3method(print,draws_matrix) S3method(print,draws_rvars) S3method(print,rvar) S3method(prod,rvar) S3method(quantile,rvar) S3method(quantile2,default) S3method(quantile2,rvar) S3method(range,rvar) S3method(rbind,rvar) S3method(remove_variables,draws_array) S3method(remove_variables,draws_df) S3method(remove_variables,draws_list) S3method(remove_variables,draws_matrix) S3method(remove_variables,draws_rvars) S3method(remove_variables,list) S3method(rename_variables,draws) S3method(rep,rvar) S3method(rep.int,rvar) S3method(rep_len,rvar) S3method(repair_draws,draws_array) S3method(repair_draws,draws_df) S3method(repair_draws,draws_list) S3method(repair_draws,draws_matrix) S3method(repair_draws,draws_rvars) S3method(repair_draws,rvar) S3method(resample_draws,draws) S3method(reserved_variables,default) S3method(reserved_variables,draws_array) S3method(reserved_variables,draws_df) S3method(reserved_variables,draws_list) S3method(reserved_variables,draws_matrix) S3method(reserved_variables,draws_rvars) S3method(rhat,default) S3method(rhat,rvar) S3method(rhat_basic,default) S3method(rhat_basic,rvar) S3method(sd,default) S3method(sd,rvar) S3method(split_chains,draws) S3method(str,rvar) S3method(subset,draws) S3method(subset_draws,draws_array) S3method(subset_draws,draws_df) S3method(subset_draws,draws_list) S3method(subset_draws,draws_matrix) S3method(subset_draws,draws_rvars) S3method(sum,rvar) S3method(summarise_draws,default) S3method(summarise_draws,draws) S3method(summarise_draws,rvar) S3method(summary,draws) S3method(summary,rvar) S3method(t,rvar) S3method(thin_draws,draws) S3method(unique,rvar) S3method(var,default) S3method(var,rvar) S3method(variables,"NULL") S3method(variables,draws_array) S3method(variables,draws_df) S3method(variables,draws_list) S3method(variables,draws_matrix) S3method(variables,draws_rvars) S3method(variance,draws_array) S3method(variance,draws_matrix) S3method(variance,rvar) S3method(vec_cast,character.rvar) S3method(vec_cast,distribution.rvar) S3method(vec_cast,rvar.distribution) S3method(vec_cast,rvar.double) S3method(vec_cast,rvar.integer) S3method(vec_cast,rvar.logical) S3method(vec_cast,rvar.rvar) S3method(vec_proxy,rvar) S3method(vec_ptype,rvar) S3method(vec_ptype2,distribution.rvar) S3method(vec_ptype2,double.rvar) S3method(vec_ptype2,integer.rvar) S3method(vec_ptype2,logical.rvar) S3method(vec_ptype2,rvar.distribution) S3method(vec_ptype2,rvar.double) S3method(vec_ptype2,rvar.integer) S3method(vec_ptype2,rvar.logical) S3method(vec_ptype2,rvar.rvar) S3method(vec_ptype_abbr,rvar) S3method(vec_ptype_full,rvar) S3method(vec_restore,rvar) S3method(weight_draws,draws_array) S3method(weight_draws,draws_df) S3method(weight_draws,draws_list) S3method(weight_draws,draws_matrix) S3method(weight_draws,draws_rvars) S3method(weights,draws) export("%**%") export("draws_of<-") export("variables<-") export(E) export(Pr) export(as_draws) export(as_draws_array) export(as_draws_df) export(as_draws_list) export(as_draws_matrix) export(as_draws_rvars) export(as_rvar) export(autocorrelation) export(autocovariance) export(bind_draws) export(cdf) export(chain_ids) export(default_convergence_measures) export(default_mcse_measures) export(default_summary_measures) export(draw_ids) export(draws_array) export(draws_df) export(draws_list) export(draws_matrix) export(draws_of) export(draws_rvars) export(ess_basic) export(ess_bulk) export(ess_mean) export(ess_median) export(ess_quantile) export(ess_sd) export(ess_tail) export(example_draws) export(extract_variable) export(extract_variable_matrix) export(is_draws) export(is_draws_array) export(is_draws_df) export(is_draws_list) export(is_draws_matrix) export(is_draws_rvars) export(is_rvar) export(iteration_ids) export(mad) export(mcse_mean) export(mcse_median) export(mcse_quantile) export(mcse_sd) export(merge_chains) export(mutate_variables) export(nchains) export(ndraws) export(niterations) export(nvariables) export(order_draws) export(quantile2) export(r_scale) export(rdo) export(rename_variables) export(repair_draws) export(resample_draws) export(reserved_variables) export(rfun) export(rhat) export(rhat_basic) export(rstar) export(rvar) export(rvar_all) export(rvar_any) export(rvar_apply) export(rvar_is_finite) export(rvar_is_infinite) export(rvar_is_na) export(rvar_is_nan) export(rvar_mad) export(rvar_max) export(rvar_mean) export(rvar_median) export(rvar_min) export(rvar_prod) export(rvar_quantile) export(rvar_range) export(rvar_rng) export(rvar_sd) export(rvar_sum) export(rvar_var) export(sd) export(split_chains) export(subset_draws) export(summarise_draws) export(summarize_draws) export(thin_draws) export(u_scale) export(var) export(variables) export(variance) export(weight_draws) export(z_scale) import(checkmate) import(stats) importFrom(abind,abind) importFrom(distributional,cdf) importFrom(distributional,variance) importFrom(pillar,format_glimpse) importFrom(pillar,new_pillar_shaft_simple) importFrom(pillar,pillar_shaft) importFrom(rlang,as_label) importFrom(rlang,as_name) importFrom(rlang,caller_env) importFrom(rlang,dots_list) importFrom(rlang,enquo) importFrom(rlang,enquos) importFrom(rlang,eval_tidy) importFrom(rlang,expr) importFrom(rlang,is_missing) importFrom(rlang,missing_arg) importFrom(rlang,quo_get_env) importFrom(rlang,quo_get_expr) importFrom(rlang,quos) importFrom(tensorA,as.tensor) importFrom(tensorA,chol.tensor) importFrom(tensorA,mul.tensor) importFrom(tibble,as_tibble) importFrom(utils,lsf.str) importFrom(utils,str) importFrom(vctrs,new_vctr) importFrom(vctrs,vec_cast) importFrom(vctrs,vec_chop) importFrom(vctrs,vec_proxy) importFrom(vctrs,vec_ptype) importFrom(vctrs,vec_ptype2) importFrom(vctrs,vec_ptype_abbr) importFrom(vctrs,vec_ptype_full) importFrom(vctrs,vec_restore) importFrom(vctrs,vec_slice)