├── .gitattributes
├── .gitignore
├── .nojekyll
├── README.html
├── README.md
├── _bookdown.yml
├── _output.yml
├── bayesian-basics.Rmd
├── bayesian-beta-regression.Rmd
├── bayesian-cfa.Rmd
├── bayesian-irt.Rmd
├── bayesian-linear-regression.Rmd
├── bayesian-mixed-mediation.Rmd
├── bayesian-mixed-model.Rmd
├── bayesian-multinomial-model.Rmd
├── bayesian-non-parametric.Rmd
├── bayesian-stochastic-volatility.Rmd
├── bayesian-t-test.Rmd
├── bayesian-topic-model.Rmd
├── bayesian-variational.Rmd
├── bayesian.Rmd
├── cfa.Rmd
├── cox.Rmd
├── css
    └── book.css
├── cubic-spline.Rmd
├── data
    ├── engel.csv
    └── mle_est.csv
├── docs
    ├── bayes-non-parametric.html
    ├── bayesian-basics.html
    ├── bayesian-beta-regression.html
    ├── bayesian-cfa.html
    ├── bayesian-irt.html
    ├── bayesian-linear-regression.html
    ├── bayesian-mixed-mediation.html
    ├── bayesian-mixed-model.html
    ├── bayesian-multinomial-model.html
    ├── bayesian-non-parametric.html
    ├── bayesian-stochastic-volatility.html
    ├── bayesian-t-test.html
    ├── bayesian-topic-model.html
    ├── bayesian-variational.html
    ├── bayesian.html
    ├── cfa.html
    ├── cox.html
    ├── css
    │   └── book.css
    ├── cubic-spline.html
    ├── elm.html
    ├── em.html
    ├── gaussian-process.html
    ├── gradient-descent.html
    ├── hamiltonian-monte-carlo.html
    ├── heckman-selection.html
    ├── hmm.html
    ├── hurdle.html
    ├── img
    │   ├── 198R.png
    │   ├── R.ico
    │   ├── mc_logo.png
    │   ├── nineteeneightyR.png
    │   ├── title_plot.png
    │   └── title_plot.svg
    ├── index.html
    ├── introduction.html
    ├── lasso.html
    ├── libs
    │   ├── DiagrammeR-styles-0.2
    │   │   └── styles.css
    │   ├── accessible-code-block-0.0.1
    │   │   └── empty-anchor.js
    │   ├── anchor-sections-1.0
    │   │   ├── anchor-sections.css
    │   │   └── anchor-sections.js
    │   ├── crosstalk-1.1.0.1
    │   │   ├── css
    │   │   │   └── crosstalk.css
    │   │   └── js
    │   │   │   └── crosstalk.min.js
    │   ├── gitbook-2.6.7
    │   │   ├── css
    │   │   │   ├── fontawesome
    │   │   │   │   └── fontawesome-webfont.ttf
    │   │   │   ├── plugin-bookdown.css
    │   │   │   ├── plugin-clipboard.css
    │   │   │   ├── plugin-fontsettings.css
    │   │   │   ├── plugin-highlight.css
    │   │   │   ├── plugin-search.css
    │   │   │   ├── plugin-table.css
    │   │   │   └── style.css
    │   │   └── js
    │   │   │   ├── app.min.js
    │   │   │   ├── clipboard.min.js
    │   │   │   ├── jquery.highlight.js
    │   │   │   ├── lunr.js
    │   │   │   ├── plugin-bookdown.js
    │   │   │   ├── plugin-clipboard.js
    │   │   │   ├── plugin-fontsettings.js
    │   │   │   ├── plugin-search.js
    │   │   │   └── plugin-sharing.js
    │   ├── grViz-binding-1.0.6.1
    │   │   └── grViz.js
    │   ├── header-attrs-2.5
    │   │   └── header-attrs.js
    │   ├── header-attrs-2.6
    │   │   └── header-attrs.js
    │   ├── htmlwidgets-1.5.2
    │   │   └── htmlwidgets.js
    │   ├── jquery-2.2.3
    │   │   └── jquery.min.js
    │   ├── kePrint-0.0.1
    │   │   └── kePrint.js
    │   ├── lightable-0.0.1
    │   │   └── lightable.css
    │   ├── plotly-binding-4.9.2.1
    │   │   └── plotly.js
    │   ├── plotly-htmlwidgets-css-1.52.2
    │   │   └── plotly-htmlwidgets.css
    │   ├── plotly-main-1.52.2
    │   │   └── plotly-latest.min.js
    │   ├── typedarray-0.1
    │   │   └── typedarray.min.js
    │   └── viz-1.8.2
    │   │   └── viz.js
    ├── linear-regression.html
    ├── logistic-regression.html
    ├── marginal-structural.html
    ├── markov.html
    ├── maximum-likelihood.html
    ├── metropolis-hastings.html
    ├── mixed-model-ML.html
    ├── mixed-model-one-factor.html
    ├── mixed-model-two-factor.html
    ├── mixed-models.html
    ├── model-demos_files
    │   └── figure-html
    │   │   ├── bayes-basics-binomPostPred-show-1.svg
    │   │   ├── bayes-basics-prior2post_1-1.svg
    │   │   ├── bayes-basics-prior2post_2-1.svg
    │   │   ├── bayes-basics-prior2post_3-1.svg
    │   │   ├── bayes-beta-ppcheck-1.svg
    │   │   ├── bayes-beta-setup-1.svg
    │   │   ├── bayes-linreg-pp-1.svg
    │   │   ├── bayes-med-vis-1.svg
    │   │   ├── bayes-mixed-pp-1.svg
    │   │   ├── bayes-sv-vis2-1.svg
    │   │   ├── bayes-sv-vis2-2.svg
    │   │   ├── bayes-t-pp-check-1.svg
    │   │   ├── bayes-t-vis-1.svg
    │   │   ├── bayes-t-vis-2.svg
    │   │   ├── bayes-t-vis-Best-1.svg
    │   │   ├── cfa-setup-1.svg
    │   │   ├── cs-penal-vis-1.svg
    │   │   ├── cs-penal-vis-show-1.svg
    │   │   ├── cs-unpenal-vis-1.svg
    │   │   ├── elm-compare1-1.svg
    │   │   ├── elm-compare2-1.svg
    │   │   ├── elm-compare3-1.svg
    │   │   ├── elm-est1-1.svg
    │   │   ├── elm-setup1-1.svg
    │   │   ├── em-pca-vis-1.png
    │   │   ├── em-pca-vis-1.svg
    │   │   ├── em-pca-vis-2.svg
    │   │   ├── em-pca-vis-3.svg
    │   │   ├── em-ppca-miss-vis-recon-1.png
    │   │   ├── em-ppca-miss-vis-recon-1.svg
    │   │   ├── em-ppca-miss-vis-recon-2.png
    │   │   ├── em-ppca-miss-vis-recon-2.svg
    │   │   ├── em-ppca-miss-vis-scores-1.png
    │   │   ├── em-ppca-miss-vis-scores-1.svg
    │   │   ├── em-ppca-miss-vis-scores-2.svg
    │   │   ├── em-ppca-vis-recon-1.png
    │   │   ├── em-ppca-vis-recon-1.svg
    │   │   ├── em-ppca-vis-recon-2.png
    │   │   ├── em-ppca-vis-recon-2.svg
    │   │   ├── em-ppca-vis-scores-1.png
    │   │   ├── em-ppca-vis-scores-1.svg
    │   │   ├── em-ppca-vis-scores-2.svg
    │   │   ├── em-ssm-vis-1.png
    │   │   ├── em-ssm-vis-1.svg
    │   │   ├── gaussEM-compare-wait-1.svg
    │   │   ├── gaussEM-compare-wait-2.svg
    │   │   ├── gaussEM-compare-wait-3.svg
    │   │   ├── gaussEM-vis-1.png
    │   │   ├── gaussEM-vis-1.svg
    │   │   ├── gaussEM-vis-2.png
    │   │   ├── gaussEM-vis-2.svg
    │   │   ├── gd-result-1.svg
    │   │   ├── gp-noisy-pp-plot-1.svg
    │   │   ├── gp-noisy-prior-plot-1.svg
    │   │   ├── gp-noisy-prior-pp-plot-1.svg
    │   │   ├── gp-pp-plot-1.svg
    │   │   ├── gp-prior-plot-1.svg
    │   │   ├── gp-prior-pp-plot-1.svg
    │   │   ├── heckman-vis-1.svg
    │   │   ├── markov-chain-demo-1.svg
    │   │   ├── markov-vis-1.svg
    │   │   ├── maxLikeillustration-1.svg
    │   │   ├── mixmv-vis1-1.png
    │   │   ├── mixmv-vis1-1.svg
    │   │   ├── mixmv-vis1-2.png
    │   │   ├── mixmv-vis1-2.svg
    │   │   ├── mixmv-vis1-3.png
    │   │   ├── mixmv-vis1-3.svg
    │   │   ├── ml-illustration-1.svg
    │   │   ├── ml-misc-1.svg
    │   │   ├── ml-plotNormMLEpath-1.svg
    │   │   ├── mlmisc-1.svg
    │   │   ├── msm-setup-1.svg
    │   │   ├── nn-sigmoid-vis-1.svg
    │   │   ├── plotNormMLEpath-1.svg
    │   │   ├── probit-em-vis-1.svg
    │   │   ├── probit-em-vis-show-1.png
    │   │   ├── probit-em-vis-show-1.svg
    │   │   ├── qr-vis-1.svg
    │   │   ├── rk-ridge-plot-1.png
    │   │   ├── rk-ridge-plot-1.svg
    │   │   ├── rk-ridge-plot-show-1.svg
    │   │   ├── rk-spline-comparison-1.png
    │   │   ├── rk-spline-comparison-1.svg
    │   │   ├── rk-spline-gcv-plot-1.svg
    │   │   ├── sgd-variant-vis-1.svg
    │   │   ├── sgd-visualize-1.svg
    │   │   ├── sgd-visualize-2-1.svg
    │   │   ├── tm-bayes-diagnostics-1.svg
    │   │   ├── tm-bayes-diagnostics-2.svg
    │   │   ├── unnamed-chunk-1-1.svg
    │   │   ├── vbreg-supp-vis-1.svg
    │   │   ├── vbreg-vis-1.svg
    │   │   ├── vbreg-vis-2.svg
    │   │   └── vis-crp-1.svg
    ├── multinomial.html
    ├── naive-bayes.html
    ├── nelder-mead.html
    ├── neural-net.html
    ├── neural-network.html
    ├── newton-irls.html
    ├── nn.html
    ├── ordinal.html
    ├── penalized-maximum-likelihood.html
    ├── probit.html
    ├── quantile-regression.html
    ├── reference-keys.txt
    ├── ridge.html
    ├── rkhs.html
    ├── search_index.json
    ├── stochastic-gradient-descent.html
    ├── supplemental.html
    ├── tobit.html
    └── zi.html
├── elm.Rmd
├── em-mixture-mv.Rmd
├── em-mixture.Rmd
├── em-pca.Rmd
├── em-ppca.Rmd
├── em-probit.Rmd
├── em-ssm.Rmd
├── em.Rmd
├── gaussian-process.Rmd
├── gradient-descent.Rmd
├── hamiltonian-monte-carlo.Rmd
├── heckman-selection.Rmd
├── hmm.Rmd
├── hurdle.Rmd
├── img
    ├── 198R.png
    ├── R.ico
    ├── mc.png
    ├── mc_logo.png
    ├── mc_sunset_2.png
    ├── nineteeneightyR.png
    ├── priorpost.png
    ├── title_plot.png
    └── title_plot.svg
├── index.Rmd
├── introduction.Rmd
├── lasso.Rmd
├── linear-regression.Rmd
├── logistic-regression.Rmd
├── marginal-structural.Rmd
├── markov.Rmd
├── maximum-likelihood.Rmd
├── metropolis-hastings.Rmd
├── mixed-model-ML.Rmd
├── mixed-model-one-factor.Rmd
├── mixed-model-two-factor.Rmd
├── mixed-models.Rmd
├── models-by-example.Rproj
├── multinomial.Rmd
├── naive-bayes.Rmd
├── nelder-mead.Rmd
├── neural-network.Rmd
├── newton-irls.Rmd
├── ordinal.Rmd
├── penalized-maximum-likelihood.Rmd
├── probit.Rmd
├── quantile-regression.Rmd
├── ridge.Rmd
├── rkhs.Rmd
├── rkhs_supplemental.pdf
├── stochastic-gradient-descent.Rmd
├── supplemental.Rmd
├── title_plot.R
├── tobit.Rmd
└── zi.Rmd


/.gitattributes:
--------------------------------------------------------------------------------
 1 | # History files
 2 | .Rhistory
 3 | .Rapp.history
 4 | 
 5 | # Session Data files
 6 | .RData
 7 | 
 8 | # Example code in package build process
 9 | *-Ex.R
10 | 
11 | # Output files from R CMD build
12 | /*.tar.gz
13 | 
14 | # Output files from R CMD check
15 | /*.Rcheck/
16 | 
17 | # RStudio files
18 | .Rproj.user/
19 | 
20 | # Primary content
21 | *.Rmd
22 | 
23 | # produced vignettes
24 | _book/*.html
25 | _docs/*.html
26 | _book/*.pdf
27 | 
28 | # OAuth2 token, see https://github.com/hadley/httr/releases/tag/v0.3
29 | .httr-oauth
30 | 
31 | # knitr and R markdown default cache directories
32 | /*_bookdown_files/
33 | /*_cache/
34 | /cache/
35 | 
36 | # Temporary files created by R markdown
37 | *.utf8.md
38 | *.knit.md
39 | 
40 | *.html linguist-documentation=true
41 | *.js linguist-vendored
42 | *.sh linguist-vendored
43 | *.css linguist-vendored
44 | 
45 | 
46 | *.Rmd linguist-language=R
47 | *.stan linguist-language=Stan
48 | *.out linguist-generated=true


--------------------------------------------------------------------------------
/.gitignore:
--------------------------------------------------------------------------------
 1 | .Rproj.user
 2 | .Rhistory
 3 | .RData
 4 | .Ruserdata
 5 | _bookdown_files/
 6 | _publish.R
 7 | _book
 8 | _bookdown_files
 9 | rsconnect
10 | */cache
11 | .DS_Store
12 | 


--------------------------------------------------------------------------------
/.nojekyll:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/m-clark/models-by-example/b544c35a3fdd63baecee7f904469c1174862ced3/.nojekyll


--------------------------------------------------------------------------------
/README.html:
--------------------------------------------------------------------------------
  1 | <!DOCTYPE html>
  2 | <html lang="" xml:lang="">
  3 | <head>
  4 | 
  5 |   <meta charset="utf-8" />
  6 |   <meta http-equiv="X-UA-Compatible" content="IE=edge" />
  7 |   <title>Model Estimation by Example | README.utf8</title>
  8 |   <meta name="description" content="" />
  9 |   <meta name="generator" content="bookdown 0.21 and GitBook 2.6.7" />
 10 | 
 11 |   <meta property="og:title" content="Model Estimation by Example | README.utf8" />
 12 |   <meta property="og:type" content="book" />
 13 |   
 14 |   
 15 |   
 16 |   
 17 | 
 18 |   <meta name="twitter:card" content="summary" />
 19 |   <meta name="twitter:title" content="Model Estimation by Example | README.utf8" />
 20 |   
 21 |   
 22 |   
 23 | 
 24 | 
 25 | 
 26 | 
 27 |   <meta name="viewport" content="width=device-width, initial-scale=1" />
 28 |   <meta name="apple-mobile-web-app-capable" content="yes" />
 29 |   <meta name="apple-mobile-web-app-status-bar-style" content="black" />
 30 |   
 31 |   
 32 | 
 33 | 
 34 | <script src="libs/header-attrs-2.5/header-attrs.js"></script>
 35 | <script src="libs/jquery-2.2.3/jquery.min.js"></script>
 36 | <link href="libs/gitbook-2.6.7/css/style.css" rel="stylesheet" />
 37 | <link href="libs/gitbook-2.6.7/css/plugin-table.css" rel="stylesheet" />
 38 | <link href="libs/gitbook-2.6.7/css/plugin-bookdown.css" rel="stylesheet" />
 39 | <link href="libs/gitbook-2.6.7/css/plugin-highlight.css" rel="stylesheet" />
 40 | <link href="libs/gitbook-2.6.7/css/plugin-search.css" rel="stylesheet" />
 41 | <link href="libs/gitbook-2.6.7/css/plugin-fontsettings.css" rel="stylesheet" />
 42 | <link href="libs/gitbook-2.6.7/css/plugin-clipboard.css" rel="stylesheet" />
 43 | 
 44 | 
 45 | 
 46 | 
 47 | 
 48 | 
 49 | 
 50 | 
 51 | 
 52 | <script src="libs/accessible-code-block-0.0.1/empty-anchor.js"></script>
 53 | <link href="libs/anchor-sections-1.0/anchor-sections.css" rel="stylesheet" />
 54 | <script src="libs/anchor-sections-1.0/anchor-sections.js"></script>
 55 | 
 56 | 
 57 | 
 58 | <link rel="stylesheet" href="css/book.css" type="text/css" />
 59 | <link rel="stylesheet" href="https://use.fontawesome.com/releases/v5.14.0/css/all.css" type="text/css" />
 60 | </head>
 61 | 
 62 | <body>
 63 | 
 64 | 
 65 | 
 66 |   <div class="book without-animation with-summary font-size-2 font-family-1" data-basepath=".">
 67 | 
 68 |     <div class="book-summary">
 69 |       <nav role="navigation">
 70 | 
 71 | <ul class="summary">
 72 | <li class='before'><a href="./">Model Estimation by Example</a></li>
 73 | 
 74 | <li class="divider"></li>
 75 | <li class="chapter" data-level="" data-path=""><a href="#model-estimation-by-example"><i class="fa fa-check"></i>Model Estimation by Example</a></li>
 76 | <li class="divider"></li>
 77 | <li class='after'">
 78 |    <a href="https://m-clark.github.io/">
 79 |       <img src="img/mc_logo.png" style="width:25%; padding:0px 0; display:block; margin: 0 auto;" alt="MC logo">
 80 |    </a>
 81 | </li>
 82 | <li class='after'">
 83 |    <div style='text-align:center'>
 84 |       <a href="https://github.com/m-clark/">
 85 |          <i class="fab fa-github fa-2x" aria-hidden="true"></i>
 86 |       </a>
 87 |    </div>
 88 | </li>
 89 | <li class='after'">
 90 |    <div style='text-align:center'>
 91 |       <a rel="license" href="http://creativecommons.org/licenses/by-sa/4.0/">
 92 |          <i class="fab fa-creative-commons fa-lg"></i>
 93 |          <i class="fab fa-creative-commons-by fa-lg"></i>
 94 |          <i class="fab fa-creative-commons-sa fa-lg"></i>
 95 |       </a>
 96 |    </div>
 97 | </li>
 98 | 
 99 | </ul>
100 | 
101 |       </nav>
102 |     </div>
103 | 
104 |     <div class="book-body">
105 |       <div class="body-inner">
106 |         <div class="book-header" role="navigation">
107 |           <h1>
108 |             <i class="fa fa-circle-o-notch fa-spin"></i><a href="./"></a>
109 |           </h1>
110 |         </div>
111 | 
112 |         <div class="page-wrapper" tabindex="-1" role="main">
113 |           <div class="page-inner">
114 | 
115 |             <section class="normal" id="section-">
116 | <!--bookdown:title:end-->
117 | <!--bookdown:title:start-->
118 | <div id="model-estimation-by-example" class="section level1">
119 | <h1>Model Estimation by Example</h1>
120 | <p><a href="https://www.tidyverse.org/lifecycle/"><img src="https://img.shields.io/badge/lifecycle-stable-green.svg" alt="Lifecycle Status" /></a></p>
121 | <p>This is the repo for the document found <a href="https://m-clark.github.io/models-by-example/">here</a>, based on the raw code repo- <a href="https://github.com/m-clark/Miscellaneous-R-Code/">Miscellaneous R Code</a>. The document code has been tidied and may have other improvements relative to the original repo, but remains a conceptual/tutorial.</p>
122 | </div>
123 |             </section>
124 | 
125 |           </div>
126 |         </div>
127 |       </div>
128 | 
129 | 
130 |     </div>
131 |   </div>
132 | <script src="libs/gitbook-2.6.7/js/app.min.js"></script>
133 | <script src="libs/gitbook-2.6.7/js/lunr.js"></script>
134 | <script src="libs/gitbook-2.6.7/js/clipboard.min.js"></script>
135 | <script src="libs/gitbook-2.6.7/js/plugin-search.js"></script>
136 | <script src="libs/gitbook-2.6.7/js/plugin-sharing.js"></script>
137 | <script src="libs/gitbook-2.6.7/js/plugin-fontsettings.js"></script>
138 | <script src="libs/gitbook-2.6.7/js/plugin-bookdown.js"></script>
139 | <script src="libs/gitbook-2.6.7/js/jquery.highlight.js"></script>
140 | <script src="libs/gitbook-2.6.7/js/plugin-clipboard.js"></script>
141 | <script>
142 | gitbook.require(["gitbook"], function(gitbook) {
143 | gitbook.start({
144 | "sharing": {
145 | "github": false,
146 | "facebook": false,
147 | "twitter": false,
148 | "linkedin": false,
149 | "weibo": false,
150 | "instapaper": false,
151 | "vk": false,
152 | "all": ["twitter", "facebook", "linkedin", "google", "weibo", "instapaper"],
153 | "google": false,
154 | "instapper": false
155 | },
156 | "fontsettings": {
157 | "theme": "white",
158 | "family": "sans",
159 | "size": 2
160 | },
161 | "edit": {
162 | "link": "https://github.com/m-clark/models-by-example/blob/master/%s",
163 | "text": "Edit"
164 | },
165 | "history": {
166 | "link": null,
167 | "text": null
168 | },
169 | "view": {
170 | "link": null,
171 | "text": null
172 | },
173 | "download": null,
174 | "toc": {
175 | "collapse": "section",
176 | "depth": 2,
177 | "scroll_highlight": true
178 | },
179 | "df_print": "kable",
180 | "highlight": "pygments",
181 | "search": false
182 | });
183 | });
184 | </script>
185 | 
186 | </body>
187 | 
188 | </html>
189 | 


--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
 1 | # Model Estimation by Example
 2 | 
 3 | [![Lifecycle Status](https://img.shields.io/badge/lifecycle-stable-green.svg)](https://www.tidyverse.org/lifecycle/)
 4 | 
 5 | This is the repo for the document found
 6 | [here](https://m-clark.github.io/models-by-example/), based on the raw code
 7 | repo- [Miscellaneous R Code](https://github.com/m-clark/Miscellaneous-R-Code/).
 8 | The document code has been tidied and may have other improvements relative to
 9 | the original repo, but remains a conceptual/tutorial endeavor to various
10 | modeling  techniques and algorithms. It provides 'by-hand' demonstrations of
11 | various models and algorithms. The goal is to take away some of the mystery of
12 | them by providing clean code examples that are easy to run and compare with
13 | other tools.  The primary functions are usually just a few lines of code, and in almost all
14 | cases, comparisons are made to an R package result.  A few Python and other
15 | language demos as well.
16 | 
17 | 
18 | At present the topics covered are:
19 | 
20 | \* Python
21 | ** Stan
22 | 
23 | 
24 | ##### Models
25 | 
26 | - Linear Regression *
27 | - Logistic Regression *
28 | - One-factor Mixed Model
29 | - Two-factor Mixed Model
30 | - Mixed Model via ML
31 | - Probit & Bivariate Probit
32 | - Heckman Selection
33 | - Marginal Structural Model
34 | - Tobit Regression
35 | - Cox Survival
36 | - Hurdle Model
37 | - Zero-Inflated Model
38 | - Naive Bayes
39 | - Multinomial Regression
40 | - Ordinal Regression
41 | - Markov Model
42 | - Hidden Markov Model *
43 | - Quantile Regression *
44 | - Cubic Spline Model
45 | - Gaussian Processes
46 | - Neural Network *
47 | - Extreme Learning Machine
48 | - Reproducing Kernel Hilbert Space Regression
49 | - Confirmatory Factor Analysis
50 | 
51 | ##### Bayesian
52 | 
53 | - Introduction to Bayesian Methods
54 | - Basics
55 | - Bayesian t-test **
56 | - Bayesian Linear Regression **
57 | - Bayesian Beta Regression **
58 | - Bayesian Mixed Model **
59 | - Bayesian Multilevel Mediation **
60 | - Bayesian IRT **
61 | - Bayesian CFA **
62 | - Bayesian Nonparametric Models **
63 | - Bayesian Stochastic Volatility Model **
64 | - Bayesian Multinomial Models **
65 | - Variational Bayes Regression
66 | - Topic Model
67 | 
68 | ##### Estimation
69 | 
70 | - Maximum Likelihood
71 | - Penalized Maximum Likelihood
72 | - L1 (lasso) regularization
73 | - L2 (ridge) regularization
74 | - Newton and IRLS
75 | - Nelder-Mead *
76 | - Expectation-Maximization
77 | - Gradient Descent
78 | - Stochastic Gradient Descent *
79 | - Metropolis Hastings
80 | - Hamiltonian Monte Carlo
81 | 
82 | 
83 | \* Python
84 | ** Stan


--------------------------------------------------------------------------------
/_bookdown.yml:
--------------------------------------------------------------------------------
 1 | book_filename: 'model-demos'
 2 | language:
 3 |   ui:
 4 |     chapter_name: 'Chapter '
 5 | output_dir: 'docs'
 6 | delete_merged_file: true
 7 | 
 8 | rmd_files: [
 9 |   index.Rmd,
10 |   introduction.Rmd,
11 |   
12 |   # Models
13 |   linear-regression.Rmd,
14 |   logistic-regression.Rmd,
15 |   mixed-models.Rmd,
16 |   probit.Rmd,
17 |   heckman-selection.Rmd,
18 |   marginal-structural.Rmd,
19 |   tobit.Rmd,
20 |   cox.Rmd,
21 |   hurdle.Rmd,
22 |   zi.Rmd,
23 |   naive-bayes.Rmd,
24 |   multinomial.Rmd,
25 |   ordinal.Rmd,
26 |   markov.Rmd,
27 |   hmm.Rmd,
28 |   quantile-regression.Rmd,
29 |   cubic-spline.Rmd,
30 |   gaussian-process.Rmd,
31 |   neural-network.Rmd,
32 |   elm.Rmd,
33 |   rkhs.Rmd,
34 |   cfa.Rmd,
35 |   
36 |   # Bayesian
37 |   bayesian.Rmd,
38 |   bayesian-basics.Rmd,
39 |   bayesian-t-test.Rmd,
40 |   bayesian-linear-regression.Rmd,
41 |   bayesian-beta-regression.Rmd,
42 |   bayesian-mixed-model.Rmd,
43 |   bayesian-mixed-mediation.Rmd,
44 |   bayesian-irt.Rmd,
45 |   bayesian-cfa.Rmd,
46 |   bayesian-non-parametric.Rmd,
47 |   bayesian-stochastic-volatility.Rmd,
48 |   bayesian-multinomial-model.Rmd,
49 |   bayesian-variational.Rmd,
50 |   bayesian-topic-model.Rmd,
51 |   
52 |   # Algos
53 |   maximum-likelihood.Rmd,
54 |   penalized-maximum-likelihood.Rmd,
55 |   # lasso.Rmd,
56 |   # ridge.Rmd,
57 |   newton-irls.Rmd,
58 |   nelder-mead.Rmd,
59 |   em.Rmd,
60 |   gradient-descent.Rmd,
61 |   stochastic-gradient-descent.Rmd,
62 |   metropolis-hastings.Rmd,
63 |   hamiltonian-monte-carlo.Rmd,
64 |   
65 |   # Other
66 |   supplemental.Rmd
67 | ]
68 | 


--------------------------------------------------------------------------------
/_output.yml:
--------------------------------------------------------------------------------
 1 |  bookdown::gitbook:
 2 |     css: [css/book.css, 'https://use.fontawesome.com/releases/v5.15.1/css/all.css']
 3 |     font-import: https://fonts.googleapis.com/css?family=Roboto|Open+Sans
 4 |     font-family: 'Roboto'
 5 |     number_sections: false
 6 |     split_by: rmd
 7 |     config:
 8 |       df_print: kable
 9 |       highlight: pygments
10 |       edit: https://github.com/m-clark/models-by-example/blob/master/%s
11 |       download: null
12 |       search: yes
13 |       sharing:
14 |         facebook: no
15 |         twitter: no
16 |         google: no
17 |         weibo: no
18 |         instapper: no
19 |         vk: no
20 |         all: ['twitter', 'facebook', 'linkedin', 'google', 'weibo', 'instapaper']
21 |       toc:
22 |         depth: 2
23 |         collapse: section
24 |         scroll_highlight: yes
25 |         before: |
26 |           <li class='before'><a href="./">Model Estimation by Example</a></li>
27 |         after: |
28 |          <li class='after'">
29 |             <a href="https://m-clark.github.io/">
30 |                <img src="img/mc_logo.png" style="width:25%; padding:0px 0; display:block; margin: 0 auto;" alt="MC logo">
31 |             </a>
32 |          </li>
33 |          <li class='after'">
34 |             <div style='text-align:center'>
35 |                <a href="https://github.com/m-clark/">
36 |                   <i class="fab fa-github fa-2x" aria-hidden="true"></i>
37 |                </a>
38 |             </div>
39 |          </li>
40 |          <li class='after'">
41 |             <div style='text-align:center'>
42 |                <a rel="license" href="http://creativecommons.org/licenses/by-sa/4.0/">
43 |                   <i class="fab fa-creative-commons fa-lg"></i>
44 |                   <i class="fab fa-creative-commons-by fa-lg"></i>
45 |                   <i class="fab fa-creative-commons-sa fa-lg"></i>
46 |                </a>
47 |             </div>
48 |          </li>
49 | 
50 | # bookdown::pdf_book:
51 | #   includes:
52 | #     in_header: preamble.tex
53 | #   latex_engine: xelatex
54 | #   citation_package: natbib
55 | 
56 | # have to do this separately; but pretty useless as use of any html image will render entire chapter empty.
57 | # bookdown::epub_book:
58 | #    fig_width: 5
59 | #    fig_height: 4
60 | #    # dev: "svglite"
61 | #    fig_caption : TRUE
62 | #    number_sections : FALSE
63 | #    toc: TRUE
64 | #    toc_depth : 2
65 | #    stylesheet : 'css/book.css'
66 | #    cover_image : 'img/198R.png'
67 | #    chapter_level : 1


--------------------------------------------------------------------------------
/bayesian-beta-regression.Rmd:
--------------------------------------------------------------------------------
  1 | # Bayesian Beta Regression
  2 | 
  3 | 
  4 | The following provides an example of beta regression using Stan/rstan, with comparison to results with R's <span class="pack" style = "">betareg</span> package.
  5 | 
  6 | 
  7 | ## Data Setup
  8 | 
  9 | Several data sets from are available <span class="pack" style = "">betareg</span> to play with, but as they are a bit problematic in one way or another I instead focus on a simple simulated data set.
 10 | 
 11 | ```{r bayes-beta-setup}
 12 | library(tidyverse)
 13 | library(betareg)
 14 | 
 15 | # Data for assessing the contribution of non-verbal IQ to children's reading
 16 | # skills in dyslexic and non-dyslexic children.
 17 | # issue: 30% of data has a value of .99
 18 | # data("ReadingSkills")
 19 | # ?ReadingSkills
 20 | # y = ReadingSkills$accuracy 
 21 | # 
 22 | # brmod = betareg(accuracy ~ dyslexia + iq, data = ReadingSkills)
 23 | # X = cbind(1, scale(model.matrix(brmod)[,c('dyslexia','iq')], scale=F))
 24 | 
 25 | 
 26 | # or this, issue: ignores batch effects
 27 | # data("GasolineYield")
 28 | # ?GasolineYield
 29 | #
 30 | # y = GasolineYield$yield
 31 | # X = cbind(1, scale(GasolineYield[,c('gravity','pressure','temp')]))
 32 | 
 33 | # yet another data option, issue: only two binary predictors
 34 | # data(WeatherTask)
 35 | # ?WeatherTask
 36 | #
 37 | # y = WeatherTask$agreement
 38 | # brmod = betareg(agreement ~ priming + eliciting, data = WeatherTask)
 39 | # X = model.matrix(brmod)
 40 | 
 41 | # simulated data; probably a better illustration, or at least better behaved one.
 42 | set.seed(1234)
 43 | 
 44 | N    = 500                    # Sample size
 45 | x_1  = rnorm(N)               # Predictors
 46 | x_2  = rnorm(N)
 47 | X    = cbind(1, x_1, x_2)
 48 | beta = c(-1, .2, -.3)
 49 | mu   = plogis(X %*% beta)  # add noise if desired + rnorm(N, sd=.01)
 50 | phi  = 10
 51 | 
 52 | A = mu * phi
 53 | B = (1 - mu) * phi
 54 | 
 55 | y = rbeta(N, A, B)
 56 | 
 57 | d = data.frame(x_1, x_2, y)
 58 | 
 59 | qplot(y, geom='density')
 60 | ```
 61 | 
 62 | 
 63 | ## Model Code
 64 | 
 65 | ```{stan bayes-beta-code, output.var='bayes_beta'}
 66 | data {
 67 |   int<lower=1> N;                      // sample size
 68 |   int<lower=1> K;                      // K predictors
 69 |   vector<lower=0,upper=1>[N] y;        // response 
 70 |   matrix[N,K] X;                       // predictor matrix
 71 | }
 72 | 
 73 | parameters {
 74 |   vector[K] theta;                     // reg coefficients
 75 |   real<lower=0> phi;                   // dispersion parameter
 76 | }
 77 | 
 78 | transformed parameters{
 79 |   vector[K] beta;
 80 | 
 81 |   beta = theta * 5;                    // same as beta ~ normal(0, 5); fairly diffuse
 82 | }
 83 | 
 84 | model {
 85 |   // model calculations
 86 |   vector[N] LP;                        // linear predictor
 87 |   vector[N] mu;                        // transformed linear predictor
 88 |   vector[N] A;                         // parameter for beta distn
 89 |   vector[N] B;                         // parameter for beta distn
 90 | 
 91 |   LP = X * beta;
 92 |   
 93 |   for (i in 1:N) { 
 94 |     mu[i] = inv_logit(LP[i]);   
 95 |   }
 96 | 
 97 |   A = mu * phi;
 98 |   B = (1.0 - mu) * phi;
 99 | 
100 |   // priors
101 |   theta ~ normal(0, 1);   
102 |   phi ~ cauchy(0, 5);                  // different options for phi  
103 |   //phi ~ inv_gamma(.001, .001);
104 |   //phi ~ uniform(0, 500);             // put upper on phi if using this
105 | 
106 |   // likelihood
107 |   y ~ beta(A, B);
108 | }
109 | 
110 | generated quantities {
111 |   vector[N] y_rep;
112 |   
113 |   for (i in 1:N) { 
114 |     real mu;
115 |     real A;
116 |     real B;
117 |     
118 |     mu = inv_logit(X[i] * beta);   
119 |     
120 |     A = mu * phi;
121 |     B = (1.0 - mu) * phi;
122 |     
123 |     y_rep[i] = beta_rng(A, B); 
124 |   }
125 | }
126 | ```
127 | 
128 | ## Estimation
129 | 
130 | We create a data list for Stan and estimate the model.
131 | 
132 | ```{r bayes-beta-est, results='hide'}
133 | # Stan data list
134 | stan_data = list(N = length(y),
135 |                  K = ncol(X),
136 |                  y = y,
137 |                  X = X)
138 | 
139 | library(rstan)
140 | 
141 | fit = sampling(
142 |   bayes_beta,
143 |   data = stan_data,
144 |   thin = 4,
145 |   verbose = FALSE
146 | )
147 | 
148 | 
149 | # model for later comparison
150 | brmod = betareg(y ~ ., data = d)
151 | ```
152 | 
153 | 
154 | ## Comparison
155 | 
156 | Estimates are almost idential in this particular case.
157 | 
158 | ```{r bayes-beta-compare}
159 | print(
160 |   fit,
161 |   pars = c('beta', 'phi'),
162 |   digits_summary = 3,
163 |   probs = c(.025, .5, .975)
164 | )
165 | 
166 | summary(brmod)
167 | ```
168 | 
169 | 
170 | ## Visualization
171 | 
172 | Posterior predictive check.
173 | 
174 | ```{r bayes-beta-ppcheck}
175 | library(bayesplot)
176 | 
177 | pp_check(
178 |   stan_data$y,
179 |   rstan::extract(fit, par = 'y_rep')$y_rep[1:10, ], 
180 |   fun = 'dens_overlay'
181 | ) 
182 | ```
183 | 
184 | 
185 | 
186 | ## Source
187 | 
188 | Original code available at:
189 | https://github.com/m-clark/Miscellaneous-R-Code/blob/master/ModelFitting/Bayesian/rstanBetaRegression.R


--------------------------------------------------------------------------------
/bayesian-linear-regression.Rmd:
--------------------------------------------------------------------------------
  1 | # Bayesian Linear Regression
  2 | 
  3 | 
  4 | The following provides a simple working example of a standard regression model
  5 | using Stan via <span class="pack" style = "">rstan</span>. It will hopefully to
  6 | allow some to more easily jump in to using Stan if they are comfortable with R.
  7 | You would normally just use <span class="pack" style = "">rstanarm</span> or
  8 | <span class="pack" style = "">brms</span> for such a model however.
  9 | 
 10 | 
 11 | 
 12 | ## Data Setup
 13 | 
 14 | 
 15 | Create a correlation matrix of one's choosing assuming response as last column/row.  This approach allows for some collinearity in the predictors.
 16 | 
 17 | ```{r bayes-linreg-setup}
 18 | library(tidyverse)
 19 | 
 20 | cormat = matrix(
 21 |   c(
 22 |     1, .2, -.1, .3,
 23 |     .2, 1, .1, .2,
 24 |     -.1, .1, 1, .1,
 25 |     .3, .2, .1, 1
 26 |   ),
 27 |   ncol = 4, 
 28 |   byrow = TRUE
 29 | )
 30 | 
 31 | cormat
 32 | 
 33 | cormat = Matrix::nearPD(cormat, corr = TRUE)$mat
 34 | 
 35 | n = 1000
 36 | means = rep(0, ncol(cormat))
 37 | d = MASS::mvrnorm(n, means, cormat, empirical = TRUE)
 38 | colnames(d) = c('X1', 'X2', 'X3', 'y')
 39 | 
 40 | d[,'y'] = d[,'y'] - .1 # unnecessary, just to model a non-zero intercept
 41 | 
 42 | str(d)
 43 | cor(d)
 44 | 
 45 | # Prepare for Stan
 46 | 
 47 | # create X (add intercept column) and y for vectorized version later
 48 | X = cbind(1, d[,1:3]); colnames(X) = c('Intercept', 'X1', 'X2', 'X3')
 49 | y = d[,4]
 50 | ```
 51 | 
 52 | 
 53 | ## Model Code
 54 | 
 55 | Initial preparation, create the data list object.
 56 | 
 57 | ```{r bayes-linreg-standat}
 58 | dat = list(
 59 |   N = n,
 60 |   k = 4,
 61 |   y = y,
 62 |   X = X
 63 | )
 64 | ```
 65 | 
 66 | Create the Stan model code.
 67 | 
 68 | ```{stan stan-linreg-code, output.var='bayes_linreg'}
 69 | data {                      // Data block; declarations only
 70 |   int<lower = 0> N;         // Sample size                         
 71 |   int<lower = 0> k;         // Dimension of model matrix
 72 |   matrix [N, k] X;          // Model Matrix
 73 |   vector[N] y;              // Target
 74 | }
 75 | 
 76 | /* transformed data {       // Transformed data block; declarations and statements. None needed here.
 77 |  }
 78 | */
 79 | 
 80 | parameters {                // Parameters block; declarations only
 81 |   vector[k] beta;           // Coefficient vector
 82 |   real<lower = 0> sigma;    // Error scale
 83 | }
 84 | 
 85 | transformed parameters {    // Transformed parameters block; declarations and statements.
 86 | 
 87 | }
 88 | 
 89 | model {                     // Model block; declarations and statements.
 90 |   vector[N] mu;
 91 |   mu = X * beta;            // Linear predictor
 92 | 
 93 |   // priors
 94 |   beta  ~ normal(0, 1);
 95 |   sigma ~ cauchy(0, 1);     // With sigma bounded at 0, this is half-cauchy 
 96 | 
 97 |   // likelihood
 98 |   y ~ normal(mu, sigma);
 99 | }
100 | 
101 | generated quantities {      // Generated quantities block; declarations and statements.
102 |   real rss;                
103 |   real totalss;
104 |   real R2;                  // Calculate Rsq as a demonstration
105 |   vector[N] y_hat;
106 |   
107 |   y_hat = X * beta;
108 |   rss = dot_self(y - y_hat);
109 |   totalss = dot_self(y - mean(y));
110 |   R2 = 1 - rss/totalss;
111 | }
112 | ```
113 | 
114 | 
115 | ## Estimation
116 | 
117 | Run the model and examine results.  The following assumes a character string or file (`bayes_linreg`) of the previous model code.
118 | 
119 | ```{r bayes-linreg-est, results='hide'}
120 | library(rstan)
121 | 
122 | fit = sampling(
123 |   bayes_linreg,
124 |   data  = dat,
125 |   thin  = 4,
126 |   verbose = FALSE
127 | )
128 | ```
129 | 
130 | Note the `pars` argument in the following.  You must specify desired parameters or it will print out everything, including the `y_hat`, i.e. expected values.  Also note that by taking into account the additional uncertainty estimating sigma, you get a shrunken Rsq (see Gelman & Pardoe 2006 sec. 3).
131 | 
132 | ```{r bayes-linreg-est-show}
133 | print(
134 |   fit,
135 |   digits_summary = 3,
136 |   pars  = c('beta', 'sigma', 'R2'),
137 |   probs = c(.025, .5, .975)
138 | )
139 | ```
140 | 
141 | 
142 | 
143 | ##  Comparison
144 | 
145 | Compare to basic <span class="func" style = "">lm</span> result.
146 | 
147 | ```{r bayes-linreg-compare}
148 | modlm = lm(y ~ ., data.frame(d))
149 | # Compare
150 | summary(modlm)
151 | ```
152 | 
153 | ## Visualize
154 | 
155 | Visualize the posterior predictive distribution.
156 | 
157 | ```{r bayes-linreg-pp}
158 | # shinystan::launch_shinystan(fit)   # diagnostic plots
159 | library(bayesplot)
160 | 
161 | pp_check(
162 |   dat$y, 
163 |   rstan::extract(fit, par = 'y_hat')$y_hat[1:10, ], 
164 |   fun = 'dens_overlay'
165 | )
166 | ```
167 | 
168 | ## Source
169 | 
170 | Original code available at:
171 | https://github.com/m-clark/Miscellaneous-R-Code/blob/master/ModelFitting/Bayesian/rstan_linregwithprior.R


--------------------------------------------------------------------------------
/bayesian-mixed-model.Rmd:
--------------------------------------------------------------------------------
  1 | # Bayesian Mixed Model
  2 | 
  3 | 
  4 | 
  5 | Explore the classic `sleepstudy` example of <span class="pack" style = "">lme4</span>.  Part of this code was based on that seen on this old [Stan thread](https://groups.google.com/d/msg/stan-users/pdfignYQcas/BL0LPbGA2eMJ), but you can look at the underlying code for <span class="pack" style = "">rstanarm</span> or <span class="pack" style = "">brms</span> for a fully optimized approach compared to this conceptual one.
  6 |             
  7 | 
  8 | ## Data Setup
  9 | 
 10 | The data comes from the <span class="pack" style = "">lme4</span> package.  It deals with reaction time to some task vs. sleep deprivation over 10 days.
 11 | 
 12 | ```{r bayesian-mixed-setup}
 13 | library(tidyverse)
 14 | library(lme4)
 15 | 
 16 | data(sleepstudy)
 17 | # ?sleepstudy
 18 | 
 19 | dat = list(
 20 |   N = nrow(sleepstudy),
 21 |   I = n_distinct(sleepstudy$Subject),
 22 |   Subject = as.numeric(sleepstudy$Subject),
 23 |   Days    = sleepstudy$Days,
 24 |   RT      = sleepstudy$Reaction
 25 | )
 26 | ```
 27 | 
 28 | 
 29 | ## Model Code
 30 | 
 31 | Create the Stan model code.
 32 | 
 33 | ```{stan stan-mixed-code, output.var='bayes_mixed'}
 34 | data {                                      // data setup
 35 |   int<lower = 1> N;                         // sample size
 36 |   int<lower = 1> I;                         // number of subjects
 37 |   vector<lower = 0>[N] RT;                  // Response: reaction time
 38 |   vector<lower = 0>[N] Days;                // Days in study
 39 |   int<lower = 1, upper = I> Subject[N];     // Subject
 40 | }
 41 | 
 42 | transformed data {
 43 |   real IntBase;
 44 |   real RTsd;
 45 |   
 46 |   IntBase = mean(RT);                       // Intercept starting point
 47 |   RTsd    = sd(RT);
 48 | }
 49 | 
 50 | parameters {
 51 |   real Intercept01;                         // fixed effects
 52 |   real beta01;
 53 |   vector<lower = 0>[2] sigma_u;             // sd for ints and slopes
 54 |   real<lower = 0> sigma_y;                  // residual sd
 55 |   vector[2] gamma[I];                     // individual effects
 56 |   cholesky_factor_corr[2] Omega_chol;       // correlation matrix for random intercepts and slopes (chol decomp)
 57 | }
 58 | 
 59 | transformed parameters {
 60 |   vector[I] gammaIntercept;                 // individual effects (named)
 61 |   vector[I] gammaDays;
 62 |   real Intercept;
 63 |   real beta;
 64 | 
 65 |   Intercept = IntBase + Intercept01 * RTsd;
 66 |   beta = beta01 * 10;
 67 | 
 68 |   for (i in 1:I){  
 69 |     gammaIntercept[i]  = gamma[i, 1];
 70 |     gammaDays[i] = gamma[i, 2];
 71 |   }
 72 | 
 73 | } 
 74 | 
 75 | model {
 76 |   matrix[2,2] D;
 77 |   matrix[2,2] DC;
 78 |   vector[N] mu;                             // Linear predictor
 79 |   vector[2] gamma_mu;                       // vector of Intercept and beta
 80 | 
 81 |   D = diag_matrix(sigma_u);
 82 |   gamma_mu[1] = Intercept;
 83 |   gamma_mu[2] = beta;
 84 | 
 85 |   // priors
 86 |   Intercept01 ~ normal(0, 1);               // example of weakly informative priors;
 87 |   beta01 ~ normal(0, 1);                    // remove to essentially duplicate lme4 via improper prior
 88 | 
 89 |   Omega_chol ~  lkj_corr_cholesky(2.0); 
 90 | 
 91 |   sigma_u ~ cauchy(0, 2.5);                 // prior for RE scale
 92 |   sigma_y ~ cauchy(0, 2.5);                 // prior for residual scale
 93 | 
 94 |   DC = D * Omega_chol;
 95 | 
 96 |   for (i in 1:I)                            // loop for Subject random effects
 97 |     gamma[i] ~ multi_normal_cholesky(gamma_mu, DC);
 98 | 
 99 |   // likelihood
100 |   for (n in 1:N)                          
101 |     mu[n] = gammaIntercept[Subject[n]] + gammaDays[Subject[n]] * Days[n];
102 | 
103 |   RT ~ normal(mu, sigma_y);
104 | }
105 | 
106 | generated quantities {
107 |   matrix[2, 2] Omega;                       // correlation of RE
108 |   vector[N] y_hat;
109 |   
110 |   Omega = tcrossprod(Omega_chol);
111 |   
112 |   for (n in 1:N)                 
113 |     y_hat[n] = gammaIntercept[Subject[n]] + gammaDays[Subject[n]] * Days[n];
114 | }
115 | ```
116 | 
117 | 
118 | 
119 | ## Estimation
120 | 
121 | Run the model and examine results.  The following assumes a character string or file (`bayes_mixed`) of the previous model code.
122 | 
123 | ```{r bayesian-mixed-est, results='hide'}
124 | library(rstan)
125 | 
126 | fit = sampling(
127 |   bayes_mixed,
128 |   data = dat,
129 |   thin = 4,
130 |   verbose = FALSE
131 | )
132 | ```
133 | 
134 | 
135 | 
136 | ## Comparison
137 | 
138 | Compare to <span class="pack" style = "">lme4</span> result.
139 | 
140 | ```{r bayesian-mixed-compare}
141 | print(
142 |   fit,
143 |   digits_summary = 3,
144 |   pars  = c('Intercept', 'beta', 'sigma_y', 'sigma_u', 'Omega[1,2]'),
145 |   probs = c(.025, .5, .975)
146 | )
147 | 
148 | mod_lme = lmer(Reaction ~ Days + (Days | Subject), sleepstudy)
149 | mod_lme
150 | 
151 | cbind(
152 |   coef(mod_lme)$Subject,
153 |   matrix(get_posterior_mean(fit, par = c('gammaIntercept', 'gammaDays'))[, 'mean-all chains'],
154 |          ncol = 2)
155 | )
156 | ```
157 | 
158 | 
159 | 
160 | ## Visualize
161 | 
162 | Visualize the posterior predictive distribution.
163 | 
164 | ```{r bayes-mixed-pp}
165 | # shinystan::launch_shinystan(fit)  # diagnostic plots
166 | 
167 | library(bayesplot)
168 | 
169 | pp_check(
170 |   dat$RT, 
171 |   rstan::extract(fit, par = 'y_hat')$y_hat[1:10, ], 
172 |   fun = 'dens_overlay'
173 | )
174 | ```
175 | 
176 | 
177 | ## Source
178 | 
179 | Original code available at:
180 | https://github.com/m-clark/Miscellaneous-R-Code/blob/master/ModelFitting/Bayesian/rstan_MixedModelSleepstudy_withREcorrelation.R
181 | 
182 | 
183 | 


--------------------------------------------------------------------------------
/bayesian-non-parametric.Rmd:
--------------------------------------------------------------------------------
  1 | # Bayesian Nonparametric Models
  2 | 
  3 | 
  4 | The following provides some conceptual code for the [Chinese restaurant](https://en.wikipedia.org/wiki/Chinese_restaurant_process) and [Indian buffet process](https://en.wikipedia.org/wiki/Chinese_restaurant_process#The_Indian_buffet_process) for categorical and continuous/combinations of categorical latent variables respectively.  For more detail, see the Bayesian nonparametric section of my [structural equation modeling document](https://m-clark.github.io/sem/bayesian-nonparametric-models.html). 
  5 | 
  6 | ## Chinese Restaurant Process
  7 | 
  8 | To start, we have a couple functions demonstrating the Chinese restaurant process.  The first is succinct and more conceptual, but notably slower.
  9 |  
 10 | ```{r crp-func-1}
 11 | crp <- function(alpha, n) {
 12 |   table_assignments = 1
 13 |   
 14 |   for (i in 2:n){
 15 |     table_counts = table(table_assignments)       # counts of table assignments
 16 |     nt = length(table_counts)                     # number of tables  
 17 |     table_prob = table_counts/(i - 1 + alpha)     # probabilities of previous table assignments
 18 |     
 19 |     # sample assignment based on probability of current tables and potential next table
 20 |     current_table_assignment = sample(1:(nt+1), 1, prob = c(table_prob, 1 - sum(table_prob)))
 21 |     
 22 |     # concatenate new to previous table assignments
 23 |     table_assignments = c(table_assignments, current_table_assignment)  
 24 |   }
 25 |   
 26 |   table_assignments
 27 | }
 28 | ```
 29 | 
 30 | 
 31 | The following function is similar to the restaurant function here https://github.com/mcdickenson/shinyapps, and notably faster.
 32 | 
 33 | ```{r crp-func-2}
 34 | crpF <- function(alpha, n) {
 35 |   table_assignments = c(1, rep(NA, n-1))
 36 |   table_counts = 1
 37 |   
 38 |   for (i in 2:n){
 39 |     init =  c(table_counts, alpha)
 40 |     
 41 |     table_prob = init/sum(init)
 42 |     
 43 |     current_table_assignment = sample(seq_along(init), 1, prob = table_prob)
 44 |     
 45 |     table_assignments[i] = current_table_assignment
 46 |     
 47 |     if (current_table_assignment == length(init)) {
 48 |       table_counts[current_table_assignment] = 1
 49 |     } else {
 50 |       table_counts[current_table_assignment] = table_counts[current_table_assignment] + 1
 51 |     }
 52 |   }
 53 |   
 54 |   table_assignments
 55 | }
 56 | 
 57 | # library(microbenchmark)
 58 | # test  = microbenchmark(crp(alpha = 1, n = 1000),
 59 | #                        crpF(alpha = 1, n = 1000), times = 100)
 60 | # test
 61 | # ggplot2::autoplot(test)
 62 | ```
 63 | 
 64 | 
 65 | 
 66 | 
 67 | 
 68 | Visualize some examples at a given setting.
 69 | 
 70 | ```{r vis-crp}
 71 | out = replicate(5 , crpF(alpha = 1, n = 500), simplify = FALSE)
 72 | 
 73 | library(tidyverse)
 74 | 
 75 | map_df(
 76 |   out, 
 77 |   function(x) data.frame(table(x)),
 78 |   .id = 'result'
 79 | ) %>% 
 80 |   rename(cluster = x) %>% 
 81 |   ggplot(aes(cluster, Freq)) +
 82 |   geom_col() +
 83 |   facet_grid(~ result)
 84 | ```
 85 | 
 86 | 
 87 | Visualize cluster membership. With smaller `alpha`, there is more tendency to stick to fewer clusters.
 88 | 
 89 | ```{r vis-crp2}
 90 | set.seed(123)
 91 | 
 92 | n = 100
 93 | 
 94 | crp_1 = crp(alpha = 1, n = n)
 95 | 
 96 | crp_1_mat = matrix(0, nrow = n, ncol = n_distinct(crp_1))
 97 | 
 98 | for (i in 1:n_distinct(crp_1)) {
 99 |   crp_1_mat[, i] = ifelse(crp_1 == i, 1, 0)
100 | }
101 | 
102 | 
103 | crp_4 = crp(alpha = 5, n = n)
104 | 
105 | crp_4_mat = matrix(0, nrow = n, ncol = n_distinct(crp_4))
106 | 
107 | for (i in 1:n_distinct(crp_4)) {
108 |   crp_4_mat[, i] = ifelse(crp_4 == i, 1, 0)
109 | }
110 | ```
111 | 
112 | 
113 | ```{r crp-heatmaps}
114 | heatmaply::heatmaply(
115 |   crp_1_mat,
116 |   Rowv = FALSE,
117 |   Colv = FALSE,
118 |   colors = scico::scico(n = 256, alpha = 1, begin = 0, end = 1),
119 |   width = 400
120 | )
121 | 
122 | heatmaply::heatmaply(
123 |   crp_4_mat,
124 |   Rowv = FALSE,
125 |   Colv = FALSE,
126 |   colors = scico::scico(n = 256, alpha = 1, begin = 0, end = 1),
127 |   width = 400
128 | )
129 | ```
130 | 
131 | 
132 | ## Indian Buffet Process
133 | 
134 | 
135 | The following demonstrates the Indian buffet process for continuous latent variable settings.
136 | 
137 | ```{r ibp-func}
138 | ibp <- function(alpha, N){
139 |   # preallocate assignments with upper bound of N*alpha number of latent factors
140 |   assignments = matrix(NA, nrow = N, ncol = N*alpha) 
141 |   
142 |   # start with some dishes/assignments
143 |   dishes = rpois(1, alpha)      
144 |   zeroes = ncol(assignments) - dishes   # fill in the rest of potential dishes
145 |   assignments[1, ] = c(rep(1, dishes), rep(0, zeroes))
146 |   
147 |   for(i in 2:N){
148 |     prev = i - 1
149 |     # esoteric line that gets the last dish sampled without a search for it
150 |     last_previously_sampled_dish = sum(colSums(assignments[1:prev, , drop = FALSE]) > 0)    
151 |     
152 |     # initialize 
153 |     dishes_previously_sampled = matrix(0, nrow=1, ncol=last_previously_sampled_dish)
154 |     
155 |     # calculate probability of sampling from previous dishes
156 |     dish_prob = colSums(assignments[1:prev, 1:last_previously_sampled_dish, drop = FALSE]) / i
157 |     dishes_previously_sampled[1, ] = rbinom(n    = last_previously_sampled_dish,
158 |                                             size = 1,
159 |                                             prob = dish_prob)
160 |     
161 |     # sample new dish and assign based on results
162 |     new_dishes = rpois(1, alpha/i)
163 |     zeroes = ncol(assignments) - (last_previously_sampled_dish + new_dishes)
164 |     assignments[i,] = c(dishes_previously_sampled, rep(1,new_dishes), rep(0, zeroes))
165 |   }
166 |   
167 |   # return only the dimensions sampled
168 |   last_sampled_dish = sum(colSums(assignments[1:prev,]) > 0) 
169 |   
170 |   assignments[, 1:last_sampled_dish]
171 | }
172 | ```
173 | 
174 | 
175 | As before, we can compare different settings.
176 | 
177 | ```{r vis-ibp}
178 | set.seed(123)
179 | 
180 | ibp_1 = ibp(1, 100)
181 | ibp_4 = ibp(5, 100)
182 | 
183 | heatmaply::heatmaply(
184 |   ibp_1,
185 |   Rowv   = FALSE,
186 |   Colv   = FALSE,
187 |   colors = scico::scico(n = 256, alpha = 1, begin = 0, end = 1),
188 |   width  = 400
189 | )
190 | 
191 | heatmaply::heatmaply(
192 |   ibp_4,
193 |   Rowv   = FALSE,
194 |   Colv   = FALSE,
195 |   colors = scico::scico(n = 256, alpha = 1, begin = 0, end = 1),
196 |   width  = 400
197 | )
198 | ```
199 | 
200 | 
201 | ## Source
202 | 
203 | Original code available at:
204 | https://github.com/m-clark/Miscellaneous-R-Code/blob/master/ModelFitting/crp.R


--------------------------------------------------------------------------------
/bayesian-stochastic-volatility.Rmd:
--------------------------------------------------------------------------------
  1 | # Bayesian Stochastic Volatility Model
  2 | 
  3 | Stochastic Volatility Model for centered time series over $t$ equally spaced
  4 | points. The latent parameter $h$ is the log volatility, φ the persistence of the
  5 | volatility and μ the mean log volatility. ϵ is the white-noise shock and δ the
  6 | shock on volatility.  The Stan code is based on that in the manual (at the time
  7 | I originally played with it).
  8 | 
  9 | 
 10 | y_t = exp(h_t/2)*ϵ_t
 11 | 
 12 | h_t = μ + φ\*(h_{t-1}-μ) + δ_t*σ
 13 | 
 14 | h_1 ~ N(μ, σ/sqrt(1-φ^2))
 15 | 
 16 | ϵ_t ~ N(0,1); δ_t ~ N(0,1) 
 17 | 
 18 | With some rearranging:
 19 | 
 20 | ϵ_t = y_t*exp(-h_t/2)
 21 | 
 22 | y_t ~ N(0, exp(h_t/2)
 23 | 
 24 | h_t ~ N(μ + φ*(h_t-μ), σ)
 25 | 
 26 | 
 27 | 
 28 | ## Data Setup
 29 | 
 30 | The data regards inflation based on the U.S. consumer price index (`inflation = 400*log(cpi_t/cpi_{t-1}`), from the second quarter of 1947 to the second quarter
 31 | of 2011 (from Statistical Computation and Modeling 2014, chap 11).
 32 | 
 33 | ```{r bayes-sv-setup}
 34 | library(tidyverse)
 35 | 
 36 | d = read_csv(
 37 |   'https://raw.githubusercontent.com/m-clark/Datasets/master/us%20cpi/USCPI.csv',
 38 |   col_names = 'inflation'
 39 | )
 40 | 
 41 | inflation = pull(d, inflation)
 42 | 
 43 | summary(inflation)
 44 | 
 45 | inflation_cen = scale(inflation, scale = FALSE)
 46 | ```
 47 | 
 48 | 
 49 | ## Model Code
 50 | 
 51 | This original code keeps to the above formulation but can take a long time to converge.  ϵ_t and δ_t are implicit.
 52 | 
 53 | ```{stan bayes-sv1, output.var = 'bayes_conceptual'}
 54 | data {
 55 |   int<lower = 0> N_t;                       // Number of time points (equally spaced)
 56 |   vector[N_t] y;                            // mean corrected response at time t
 57 | }
 58 | 
 59 | parameters {
 60 |   real mu;                                  // mean log volatility
 61 |   real<lower = -1,upper = 1> phi;           // persistence of volatility
 62 |   real<lower = 0> sigma;                    // white noise shock scale
 63 |   vector[N_t] h;                            // log volatility at time t
 64 | }
 65 | 
 66 | model {
 67 |   //priors
 68 |   phi   ~ uniform(-1, 1);
 69 |   sigma ~ cauchy(0, 5);
 70 |   mu    ~ cauchy(0, 10);
 71 | 
 72 |   //likelihood
 73 |   h[1] ~ normal(mu, sigma / sqrt(1 - phi * phi));
 74 |   for (t in 2:N_t)
 75 |     h[t] ~ normal(mu + phi * (h[t - 1] - mu), sigma);
 76 | 
 77 |   for (t in 1:N_t)
 78 |     y ~ normal(0, exp(h[t] / 2));
 79 | }
 80 | 
 81 | ```
 82 | 
 83 | This code is more performant and will be used to actually estimate the model.
 84 | 
 85 | ```{stan bayes-sv-2, output.var='bayes_sv'}
 86 | data {
 87 |   int<lower = 0> N_t;                       // N time points (equally spaced)
 88 |   vector[N_t] y;                            // mean corrected response at time t
 89 | }
 90 | 
 91 | parameters {
 92 |   real mu;                                  // mean log volatility
 93 |   real<lower = -1,upper = 1> phi;           // persistence of volatility
 94 |   real<lower = 0> sigma;                    // white noise shock scale
 95 |   vector[N_t] h_std;                        // standardized log volatility at time t
 96 | }
 97 | 
 98 | transformed parameters{
 99 |   vector[N_t] h;                            // log volatility at time t
100 |   
101 |   h    = h_std * sigma;
102 |   h[1] = h[1] / sqrt(1-phi * phi);
103 |   h = h + mu;
104 |   
105 |   for (t in 2:N_t)
106 |     h[t] = h[t] + phi * (h[t-1] - mu);
107 | }
108 | 
109 | model {
110 |   //priors
111 |   phi   ~ uniform(-1, 1);
112 |   sigma ~ cauchy(0, 5);
113 |   mu    ~ cauchy(0, 10);
114 |   h_std ~ normal(0, 1);
115 | 
116 |   //likelihood
117 |   y ~ normal(0, exp(h/2));
118 | }
119 | 
120 | generated quantities{
121 |   vector[N_t] y_rep;
122 | 
123 |   for (t in 1:N_t){
124 |     y_rep[t] = normal_rng(0, exp(h[t]/2));
125 |   }  
126 |   
127 | }
128 | ```
129 | 
130 | ## Estimation
131 | 
132 | We can use `c()` to get rid of matrix format, or specify as matrix instead of vector in model code.
133 | 
134 | ```{r bayes-sv-est, results='hide'}
135 | stan_data = list(N_t = length(inflation_cen), y = c(inflation_cen))
136 | 
137 | library(rstan)
138 | 
139 | fit = sampling(
140 |   bayes_sv,
141 |   data  = stan_data,
142 |   cores = 4,
143 |   thin  = 4
144 | )
145 | ```
146 | 
147 | ## Results
148 | 
149 | Explore the results.
150 | 
151 | ```{r bayes-sv-result}
152 | print(
153 |   fit,
154 |   digits = 3,
155 |   par    = c('mu', 'phi', 'sigma'),
156 |   probs  = c(.025, .5, .975)
157 | )
158 | ```
159 | 
160 | 
161 | ## Visualization
162 | 
163 | With the necessary components in place, we can visualize our predictions. Compare to fig. 11.1 in the text.
164 | 
165 | 
166 | ```{r bayes-sv-vis1}
167 | # Create y_rep 'by-hand'
168 | h = extract(fit, 'h')$h
169 | # y_rep = apply(h, 1, function(h) rnorm(length(inflation), 0, exp(h / 2)))
170 | 
171 | # or just extract
172 | y_rep = extract(fit, 'y_rep')$y_rep
173 | 
174 | h = colMeans(h)
175 | 
176 | library(lubridate)
177 | library(scales)
178 | 
179 | series = ymd(paste0(rep(1947:2014, e = 4), '-', c('01', '04', '07', '10'), '-', '01'))
180 | seriestext = series[1:length(inflation)]
181 | ```
182 | 
183 | 
184 | ```{r bayes-sv-vis2, echo=FALSE}
185 | qplot(
186 |   seriestext,
187 |   h,
188 |   width = .5,
189 |   color = I('gray50'),
190 |   geom = 'line',
191 |   ylab = 'log volatility'
192 | )
193 | 
194 | gdat0 = tibble(
195 |   date      = as_date(seriestext), 
196 |   inflation = inflation_cen[,1]
197 | )
198 | 
199 | gdat_sim = t(y_rep[sample(1:ncol(y_rep), 10), ]) %>% 
200 |   as.data.frame() %>%
201 |   mutate(date = gdat0$date) %>%
202 |   pivot_longer(-date, names_to = 'iter', values_to = 'inflation')
203 | 
204 | gdat0 %>%
205 |   ggplot(aes(date, inflation)) +
206 |   geom_line(aes(group = iter),
207 |             color = '#ff5500',
208 |             alpha = .1,
209 |             data  = gdat_sim) +
210 |   geom_line(color = 'gray25') +
211 |   labs(y = 'Inflation\ncentered', caption = '10 posterior predictive draws shown in color')
212 | ```
213 | 
214 | ## Source
215 | 
216 | Original code available at:
217 | https://github.com/m-clark/Miscellaneous-R-Code/blob/master/ModelFitting/Bayesian/stochasticVolatility.R


--------------------------------------------------------------------------------
/bayesian.Rmd:
--------------------------------------------------------------------------------
 1 | # (PART\*)  Bayesian {-}
 2 | 
 3 | # Introduction to Bayesian Methods
 4 | 
 5 | The following demonstrations will likely assume more background knowledge, but otherwise take a similar approach. For example, the model fitting functions in the previous demonstrations are now replaced with Stan code.  I start with a demo followed by the simplest of models such as a t-test and linear regression to get one comfortable. For more introduction, see [my introduction to bayesian method](https://m-clark.github.io/bayesian-basics/), and in particular, the[ maximum likelihood section of this document][Maximum Likelihood], which is an update of the appendix in that introduction.
 6 | 
 7 | 
 8 | Note that some of the old code is now easily accomplished with tools like <span class="pack" style = "">rstanarm</span> or <span class="pack" style = "">brms</span> (e.g. for standard linear and mixed models), or Stan even has built in functions (e.g. gaussian process covariance functions). As such, I didn't copy all of my old efforts to this document. So you can take a look at the [old repo](https://github.com/m-clark/Miscellaneous-R-Code/tree/master/ModelFitting/Bayesian) for a few more demos I probably won't include here, including in other languages like Bugs/Jags.
 9 | 
10 | 
11 | 


--------------------------------------------------------------------------------
/cubic-spline.Rmd:
--------------------------------------------------------------------------------
  1 | # Cubic Spline Model
  2 | 
  3 | 
  4 | See Wood (2017) Generalized Additive Models or my [document](https://m-clark.github.io/generalized-additive-models/) for an introduction to generalized additive models.  
  5 | 
  6 | 
  7 | ## Data Setup
  8 | 
  9 | The data regards engine wear index versus engine capacity for 19 Volvo car engines used.  The idea is that a larger car engine will wear out less quickly than a smaller one (from Wood GAM 2e chapter 4). 
 10 | 
 11 | ```{r cs-setup}
 12 | library(tidyverse)
 13 | 
 14 | data(engine, package = 'gamair')
 15 | 
 16 | size = engine$size
 17 | wear = engine$wear
 18 | 
 19 | x = size - min(size)
 20 | x = x / max(x)
 21 | d = data.frame(wear, x)
 22 | ```
 23 | 
 24 | ## Functions
 25 | 
 26 | Cubic spline function, `rk` refers to [reproducing kernel][Reproducing Kernel Hilbert Space Regression]. If I recall correctly, the function code is actually based on the first edition of Wood's text.
 27 | 
 28 | ```{r cs-func}
 29 | rk <- function(x, z) {
 30 |   ((z - 0.5)^2 - 1/12) * ((x - 0.5)^2 - 1/12)/4 -
 31 |     ((abs(x - z) - 0.5)^4 - (abs(x - z) - 0.5)^2 / 2 + 7/240) / 24
 32 | }
 33 | ```
 34 | 
 35 | Generate the model matrix.
 36 | 
 37 | ```{r cs-modmat}
 38 | splX <- function(x, knots) {
 39 |   q = length(knots) + 2                # number of parameters
 40 |   n = length(x)                        # number of observations
 41 |   X = matrix(1, n, q)                  # initialized model matrix
 42 |   X[ ,2]   = x                         # set second column to x
 43 |   X[ ,3:q] = outer(x, knots, FUN = rk) # remaining to cubic spline basis
 44 |   X
 45 | }
 46 | 
 47 | splS <- function(knots) {
 48 |   q = length(knots) + 2
 49 |   S = matrix(0, q, q)                         # initialize matrix
 50 |   S[3:q, 3:q] = outer(knots, knots, FUN = rk) # fill in non-zero part
 51 |   S
 52 | }
 53 | ```
 54 | 
 55 | 
 56 | 
 57 | Matrix square root function. Note that there are various packages with their own.
 58 | 
 59 | ```{r cs-mat-sqrt}
 60 | mat_sqrt <- function(S) {
 61 |   d  = eigen(S, symmetric = TRUE)
 62 |   rS = d$vectors %*% diag(d$values^.5) %*% t(d$vectors)
 63 |   rS
 64 | }
 65 | ```
 66 | 
 67 | Penalized fitting function.
 68 | 
 69 | ```{r cs-fit}
 70 | prs_fit <- function(y, x, knots, lambda) {
 71 |   q  = length(knots) + 2    # dimension of basis
 72 |   n  = length(x)            # number of observations
 73 |   Xa = rbind(splX(x, knots), mat_sqrt(splS(knots))*sqrt(lambda)) # augmented model matrix
 74 |   y[(n + 1):(n+q)] = 0      # augment the data vector
 75 |   
 76 |   lm(y ~ Xa - 1) # fit and return penalized regression spline
 77 | }
 78 | ```
 79 | 
 80 | 
 81 | ## Example 1
 82 | 
 83 | 
 84 | We start with an unpenalized approach.
 85 | 
 86 | ```{r cs-unpenal}
 87 | knots = 1:4/5
 88 | X = splX(x, knots)            # generate model matrix
 89 | 
 90 | fit_lm  = lm(wear ~ X - 1)    # fit model
 91 | 
 92 | xp = 0:100/100                # x values for prediction
 93 | Xp = splX(xp, knots)          # prediction matrix
 94 | ```
 95 | 
 96 | Visualize.
 97 | 
 98 | ```{r cs-unpenal-vis}
 99 | ggplot(aes(x = x, y = wear), data = data.frame(x, wear)) +
100 |   geom_point(color = "#FF5500") +
101 |   geom_line(aes(x = xp, y = Xp %*% coef(fit_lm)),
102 |             data = data.frame(xp, Xp),
103 |             color = "#00AAFF") +
104 |   labs(x = 'Scaled Engine size', y  = 'Wear Index')
105 | ```
106 | 
107 | 
108 | 
109 | 
110 | ## Example 2
111 | 
112 | Now we add the `lambda` penalty and compare fits at different values of `lambda`.
113 | 
114 | ```{r cs-penal}
115 | knots = 1:7/8
116 | d2 = data.frame(x = xp)
117 | lambda = c(.1, .01, .001, .0001, .00001, .000001)
118 | rmse   = vector('numeric', length(lambda))
119 | idx = 0
120 | 
121 | for (i in lambda) {
122 |   # fit penalized regression
123 |   fit_penalized = prs_fit(
124 |     y = wear,
125 |     x = x,
126 |     knots = knots,
127 |     lambda = i
128 |   ) 
129 |   # spline choosing lambda
130 |   Xp = splX(xp, knots) # matrix to map parameters to fitted values at xp
131 |   LP = Xp %*% coef(fit_penalized)
132 |   d2[, paste0('lambda = ', i)] = LP[, 1]
133 |   
134 |   r = resid(fit_penalized)
135 |   idx = 1 + idx
136 |   
137 |   rmse[idx] = sqrt(mean(r^2))
138 | }
139 | ```
140 | 
141 | 
142 | 
143 | Visualize. I add the root mean square error for model comparison.
144 | 
145 | ```{r cs-penal-vis}
146 | d3 = d2 %>%
147 |   pivot_longer(cols = -x,
148 |                names_to  = 'lambda',
149 |                values_to = 'value') %>% 
150 |   mutate(lambda = fct_inorder(lambda),
151 |          rmse   = round(rmse[lambda], 3))
152 | ```
153 | 
154 | 
155 | ```{r cs-penal-vis-show, echo=FALSE}
156 | ggplot(d3) +
157 |   geom_point(aes(x = x, y = wear), col = '#FF5500', data = d) +
158 |   geom_line(aes(x = x, y = value), col = "#00AAFF") +
159 |   geom_text(
160 |     aes(label = glue::glue('rmse: {rmse}')),
161 |     x  = .33,
162 |     y = 4.5,
163 |     size = 2,
164 |     color = 'gray50'
165 |   ) +
166 |   facet_wrap( ~ lambda)
167 | ```
168 | 
169 | 
170 | ## Source
171 | 
172 | Original code available at https://github.com/m-clark/Miscellaneous-R-Code/blob/master/ModelFitting/cubicsplines.R
173 | 


--------------------------------------------------------------------------------
/data/mle_est.csv:
--------------------------------------------------------------------------------
  1 | mu,sigma,ll
  2 | 2,1,-7248.145866
  3 | 2.001,1,-7245.199561
  4 | 1.999,1,-7251.093172
  5 | 2,1.001,-7236.505914
  6 | 2,0.999,-7259.822794
  7 | 2.245054689,1.969509257,-3049.97199
  8 | 2.246054689,1.969509257,-3049.275606
  9 | 2.244054689,1.969509257,-3050.668632
 10 | 2.245054689,1.970509257,-3049.004978
 11 | 2.245054689,1.968509257,-3050.940992
 12 | 2.313180288,2.058923171,-2928.018321
 13 | 2.314180288,2.058923171,-2927.397178
 14 | 2.312180288,2.058923171,-2928.639699
 15 | 2.313180288,2.059923171,-2927.254736
 16 | 2.313180288,2.057923171,-2928.783491
 17 | 2.772785054,2.432558188,-2543.104043
 18 | 2.773785054,2.432558188,-2542.736729
 19 | 2.771785054,2.432558188,-2543.471525
 20 | 2.772785054,2.433558188,-2542.910936
 21 | 2.772785054,2.431558188,-2543.297726
 22 | 3.286158244,2.626594171,-2372.559876
 23 | 3.287158244,2.626594171,-2372.31924
 24 | 3.285158244,2.626594171,-2372.800657
 25 | 3.286158244,2.627594171,-2372.569204
 26 | 3.286158244,2.625594171,-2372.550828
 27 | 4.132685643,2.698387543,-2230.048809
 28 | 4.133685643,2.698387543,-2229.937068
 29 | 4.131685643,2.698387543,-2230.160688
 30 | 4.132685643,2.699387543,-2230.183429
 31 | 4.132685643,2.697387543,-2229.914314
 32 | 4.974736787,2.510545606,-2154.814884
 33 | 4.975736787,2.510545606,-2154.819395
 34 | 4.973736787,2.510545606,-2154.810532
 35 | 4.974736787,2.511545606,-2154.962033
 36 | 4.974736787,2.509545606,-2154.667876
 37 | 5.214893204,2.189475732,-2124.668644
 38 | 5.215893204,2.189475732,-2124.724672
 39 | 5.213893204,2.189475732,-2124.612825
 40 | 5.214893204,2.190475732,-2124.739992
 41 | 5.214893204,2.188475732,-2124.597616
 42 | 5.009959883,1.926225869,-2110.66941
 43 | 5.010959883,1.926225869,-2110.686566
 44 | 5.008959883,1.926225869,-2110.652524
 45 | 5.009959883,1.927225869,-2110.632155
 46 | 5.009959883,1.925225869,-2110.707263
 47 | 4.913354202,2.019622139,-2109.222546
 48 | 4.914354202,2.019622139,-2109.214467
 49 | 4.912354202,2.019622139,-2109.230869
 50 | 4.913354202,2.020622139,-2109.235285
 51 | 4.913354202,2.018622139,-2109.210278
 52 | 4.946511432,1.997172669,-2108.922715
 53 | 4.947511432,1.997172669,-2108.922766
 54 | 4.945511432,1.997172669,-2108.922914
 55 | 4.946511432,1.998172669,-2108.924715
 56 | 4.946511432,1.996172669,-2108.921214
 57 | 4.94623334,1.993080253,-2108.919771
 58 | 4.94723334,1.993080253,-2108.919753
 59 | 4.94523334,1.993080253,-2108.920041
 60 | 4.94623334,1.994080253,-2108.919722
 61 | 4.94623334,1.992080253,-2108.920324
 62 | 4.946872501,1.993678604,-2108.919641
 63 | 4.947872501,1.993678604,-2108.919783
 64 | 4.945872501,1.993678604,-2108.91975
 65 | 4.946872501,1.994678604,-2108.919892
 66 | 4.946872501,1.992678604,-2108.919892
 67 | 4.94680327,1.993679547,-2108.91964
 68 | 4.94780327,1.993679547,-2108.919765
 69 | 4.94580327,1.993679547,-2108.919766
 70 | 4.94680327,1.994679547,-2108.919892
 71 | 4.94680327,1.992679547,-2108.919891
 72 | 4.94680327,1.993679547,-2108.91964
 73 | 4.94680327,1.993679547,-2108.91964
 74 | 5.441483597,1.993679547,-2139.702183
 75 | 4.452122943,1.993679547,-2139.702762
 76 | 5.194143434,1.993679547,-2116.615203
 77 | 4.699463107,1.993679547,-2116.615493
 78 | 5.070473352,1.993679547,-2110.843495
 79 | 4.823133189,1.993679547,-2110.84364
 80 | 5.008638311,1.993679547,-2109.400586
 81 | 4.88496823,1.993679547,-2109.400658
 82 | 4.94680327,2.193047502,-2117.453107
 83 | 4.94680327,1.794311593,-2120.842877
 84 | 4.94680327,2.093363525,-2111.224622
 85 | 4.94680327,1.89399557,-2111.642875
 86 | 4.94680327,2.043521536,-2109.519491
 87 | 4.94680327,1.943837559,-2109.571545
 88 | 4.94680327,2.018600542,-2109.07271
 89 | 4.94680327,1.968758553,-2109.07918
 90 | 5.441483597,2.193047502,-2142.893225
 91 | 4.452122943,1.794311593,-2158.846731
 92 | 5.194143434,2.093363525,-2118.204725
 93 | 4.699463107,1.89399557,-2120.170136
 94 | 5.070473352,2.043521536,-2111.350644
 95 | 4.823133189,1.943837559,-2111.595476
 96 | 5.008638311,2.018600542,-2109.541853
 97 | 4.88496823,1.968758553,-2109.572452
 98 | 4.94680327,1.993679547,-2108.91964
 99 | 4.947297951,1.993679547,-2108.919671
100 | 4.94630859,1.993679547,-2108.919671
101 | 4.94680327,1.993878915,-2108.91965
102 | 4.94680327,1.993480179,-2108.91965
103 | 4.947050611,1.993679547,-2108.919648
104 | 4.94655593,1.993679547,-2108.919648
105 | 4.94680327,1.993779231,-2108.919643
106 | 4.94680327,1.993579863,-2108.919642
107 | 4.94692694,1.993679547,-2108.919642
108 | 4.9466796,1.993679547,-2108.919642
109 | 4.94680327,1.993729389,-2108.919641
110 | 4.94680327,1.993629705,-2108.919641
111 | 4.946865105,1.993679547,-2108.919641
112 | 4.946741435,1.993679547,-2108.919641
113 | 4.94680327,1.993704468,-2108.91964
114 | 4.94680327,1.993654626,-2108.91964


--------------------------------------------------------------------------------
/docs/img/198R.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/m-clark/models-by-example/b544c35a3fdd63baecee7f904469c1174862ced3/docs/img/198R.png


--------------------------------------------------------------------------------
/docs/img/R.ico:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/m-clark/models-by-example/b544c35a3fdd63baecee7f904469c1174862ced3/docs/img/R.ico


--------------------------------------------------------------------------------
/docs/img/mc_logo.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/m-clark/models-by-example/b544c35a3fdd63baecee7f904469c1174862ced3/docs/img/mc_logo.png


--------------------------------------------------------------------------------
/docs/img/nineteeneightyR.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/m-clark/models-by-example/b544c35a3fdd63baecee7f904469c1174862ced3/docs/img/nineteeneightyR.png


--------------------------------------------------------------------------------
/docs/img/title_plot.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/m-clark/models-by-example/b544c35a3fdd63baecee7f904469c1174862ced3/docs/img/title_plot.png


--------------------------------------------------------------------------------
/docs/libs/DiagrammeR-styles-0.2/styles.css:
--------------------------------------------------------------------------------
 1 | .DiagrammeR,.grViz pre {
 2 |   white-space: pre-wrap;       /* CSS 3 */
 3 |   white-space: -moz-pre-wrap;  /* Mozilla, since 1999 */
 4 |   white-space: -pre-wrap;      /* Opera 4-6 */
 5 |   white-space: -o-pre-wrap;    /* Opera 7 */
 6 |   word-wrap: break-word;       /* Internet Explorer 5.5+ */
 7 | }
 8 | 
 9 | .DiagrammeR g .label {
10 |   font-family: Helvetica;
11 |   font-size: 14px;
12 |   color: #333333;
13 | }
14 | 
15 | 


--------------------------------------------------------------------------------
/docs/libs/accessible-code-block-0.0.1/empty-anchor.js:
--------------------------------------------------------------------------------
 1 | // Hide empty <a> tag within highlighted CodeBlock for screen reader accessibility (see https://github.com/jgm/pandoc/issues/6352#issuecomment-626106786) -->
 2 | // v0.0.1
 3 | // Written by JooYoung Seo (jooyoung@psu.edu) and Atsushi Yasumoto on June 1st, 2020.
 4 | 
 5 | document.addEventListener('DOMContentLoaded', function() {
 6 |   const codeList = document.getElementsByClassName("sourceCode");
 7 |   for (var i = 0; i < codeList.length; i++) {
 8 |     var linkList = codeList[i].getElementsByTagName('a');
 9 |     for (var j = 0; j < linkList.length; j++) {
10 |       if (linkList[j].innerHTML === "") {
11 |         linkList[j].setAttribute('aria-hidden', 'true');
12 |       }
13 |     }
14 |   }
15 | });
16 | 


--------------------------------------------------------------------------------
/docs/libs/anchor-sections-1.0/anchor-sections.css:
--------------------------------------------------------------------------------
1 | /* Styles for section anchors */
2 | a.anchor-section {margin-left: 10px; visibility: hidden; color: inherit;}
3 | a.anchor-section::before {content: '#';}
4 | .hasAnchor:hover a.anchor-section {visibility: visible;}
5 | 


--------------------------------------------------------------------------------
/docs/libs/anchor-sections-1.0/anchor-sections.js:
--------------------------------------------------------------------------------
 1 | // Anchor sections v1.0 written by Atsushi Yasumoto on Oct 3rd, 2020.
 2 | document.addEventListener('DOMContentLoaded', function() {
 3 |   // Do nothing if AnchorJS is used
 4 |   if (typeof window.anchors === 'object' && anchors.hasOwnProperty('hasAnchorJSLink')) {
 5 |     return;
 6 |   }
 7 | 
 8 |   const h = document.querySelectorAll('h1, h2, h3, h4, h5, h6');
 9 | 
10 |   // Do nothing if sections are already anchored
11 |   if (Array.from(h).some(x => x.classList.contains('hasAnchor'))) {
12 |     return null;
13 |   }
14 | 
15 |   // Use section id when pandoc runs with --section-divs
16 |   const section_id = function(x) {
17 |     return ((x.classList.contains('section') || (x.tagName === 'SECTION'))
18 |             ? x.id : '');
19 |   };
20 | 
21 |   // Add anchors
22 |   h.forEach(function(x) {
23 |     const id = x.id || section_id(x.parentElement);
24 |     if (id === '') {
25 |       return null;
26 |     }
27 |     let anchor = document.createElement('a');
28 |     anchor.href = '#' + id;
29 |     anchor.classList = ['anchor-section'];
30 |     x.classList.add('hasAnchor');
31 |     x.appendChild(anchor);
32 |   });
33 | });
34 | 


--------------------------------------------------------------------------------
/docs/libs/crosstalk-1.1.0.1/css/crosstalk.css:
--------------------------------------------------------------------------------
 1 | /* Adjust margins outwards, so column contents line up with the edges of the
 2 |    parent of container-fluid. */
 3 | .container-fluid.crosstalk-bscols {
 4 |   margin-left: -30px;
 5 |   margin-right: -30px;
 6 |   white-space: normal;
 7 | }
 8 | 
 9 | /* But don't adjust the margins outwards if we're directly under the body,
10 |    i.e. we were the top-level of something at the console. */
11 | body > .container-fluid.crosstalk-bscols {
12 |   margin-left: auto;
13 |   margin-right: auto;
14 | }
15 | 
16 | .crosstalk-input-checkboxgroup .crosstalk-options-group .crosstalk-options-column {
17 |   display: inline-block;
18 |   padding-right: 12px;
19 |   vertical-align: top;
20 | }
21 | 
22 | @media only screen and (max-width:480px) {
23 |   .crosstalk-input-checkboxgroup .crosstalk-options-group .crosstalk-options-column {
24 |     display: block;
25 |     padding-right: inherit;
26 |   }
27 | }
28 | 


--------------------------------------------------------------------------------
/docs/libs/gitbook-2.6.7/css/fontawesome/fontawesome-webfont.ttf:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/m-clark/models-by-example/b544c35a3fdd63baecee7f904469c1174862ced3/docs/libs/gitbook-2.6.7/css/fontawesome/fontawesome-webfont.ttf


--------------------------------------------------------------------------------
/docs/libs/gitbook-2.6.7/css/plugin-bookdown.css:
--------------------------------------------------------------------------------
  1 | .book .book-header h1 {
  2 |   padding-left: 20px;
  3 |   padding-right: 20px;
  4 | }
  5 | .book .book-header.fixed {
  6 |   position: fixed;
  7 |   right: 0;
  8 |   top: 0;
  9 |   left: 0;
 10 |   border-bottom: 1px solid rgba(0,0,0,.07);
 11 | }
 12 | span.search-highlight {
 13 |   background-color: #ffff88;
 14 | }
 15 | @media (min-width: 600px) {
 16 |   .book.with-summary .book-header.fixed {
 17 |     left: 300px;
 18 |   }
 19 | }
 20 | @media (max-width: 1240px) {
 21 |   .book .book-body.fixed {
 22 |     top: 50px;
 23 |   }
 24 |   .book .book-body.fixed .body-inner {
 25 |     top: auto;
 26 |   }
 27 | }
 28 | @media (max-width: 600px) {
 29 |   .book.with-summary .book-header.fixed {
 30 |     left: calc(100% - 60px);
 31 |     min-width: 300px;
 32 |   }
 33 |   .book.with-summary .book-body {
 34 |     transform: none;
 35 |     left: calc(100% - 60px);
 36 |     min-width: 300px;
 37 |   }
 38 |   .book .book-body.fixed {
 39 |     top: 0;
 40 |   }
 41 | }
 42 | 
 43 | .book .book-body.fixed .body-inner {
 44 |   top: 50px;
 45 | }
 46 | .book .book-body .page-wrapper .page-inner section.normal sub, .book .book-body .page-wrapper .page-inner section.normal sup {
 47 |   font-size: 85%;
 48 | }
 49 | 
 50 | @media print {
 51 |   .book .book-summary, .book .book-body .book-header, .fa {
 52 |     display: none !important;
 53 |   }
 54 |   .book .book-body.fixed {
 55 |     left: 0px;
 56 |   }
 57 |   .book .book-body,.book .book-body .body-inner, .book.with-summary {
 58 |     overflow: visible !important;
 59 |   }
 60 | }
 61 | .kable_wrapper {
 62 |   border-spacing: 20px 0;
 63 |   border-collapse: separate;
 64 |   border: none;
 65 |   margin: auto;
 66 | }
 67 | .kable_wrapper > tbody > tr > td {
 68 |   vertical-align: top;
 69 | }
 70 | .book .book-body .page-wrapper .page-inner section.normal table tr.header {
 71 |   border-top-width: 2px;
 72 | }
 73 | .book .book-body .page-wrapper .page-inner section.normal table tr:last-child td {
 74 |   border-bottom-width: 2px;
 75 | }
 76 | .book .book-body .page-wrapper .page-inner section.normal table td, .book .book-body .page-wrapper .page-inner section.normal table th {
 77 |   border-left: none;
 78 |   border-right: none;
 79 | }
 80 | .book .book-body .page-wrapper .page-inner section.normal table.kable_wrapper > tbody > tr, .book .book-body .page-wrapper .page-inner section.normal table.kable_wrapper > tbody > tr > td {
 81 |   border-top: none;
 82 | }
 83 | .book .book-body .page-wrapper .page-inner section.normal table.kable_wrapper > tbody > tr:last-child > td {
 84 |     border-bottom: none;
 85 | }
 86 | 
 87 | div.theorem, div.lemma, div.corollary, div.proposition, div.conjecture {
 88 |   font-style: italic;
 89 | }
 90 | span.theorem, span.lemma, span.corollary, span.proposition, span.conjecture {
 91 |   font-style: normal;
 92 | }
 93 | div.proof>*:last-child:after {
 94 |   content: "\25a2";
 95 |   float: right;
 96 | }
 97 | .header-section-number {
 98 |   padding-right: .5em;
 99 | }
100 | 


--------------------------------------------------------------------------------
/docs/libs/gitbook-2.6.7/css/plugin-clipboard.css:
--------------------------------------------------------------------------------
 1 | div.sourceCode {
 2 |   position: relative;
 3 | }
 4 | 
 5 | .copy-to-clipboard-button {
 6 |   position: absolute;
 7 |   right: 0;
 8 |   top: 0;
 9 |   visibility: hidden;
10 | }
11 | 
12 | .copy-to-clipboard-button:focus {
13 |   outline: 0;
14 | }
15 | 
16 | div.sourceCode:hover > .copy-to-clipboard-button {
17 |   visibility: visible;
18 | }
19 | 


--------------------------------------------------------------------------------
/docs/libs/gitbook-2.6.7/css/plugin-search.css:
--------------------------------------------------------------------------------
 1 | .book .book-summary .book-search {
 2 |   padding: 6px;
 3 |   background: transparent;
 4 |   position: absolute;
 5 |   top: -50px;
 6 |   left: 0px;
 7 |   right: 0px;
 8 |   transition: top 0.5s ease;
 9 | }
10 | .book .book-summary .book-search input,
11 | .book .book-summary .book-search input:focus,
12 | .book .book-summary .book-search input:hover {
13 |   width: 100%;
14 |   background: transparent;
15 |   border: 1px solid #ccc;
16 |   box-shadow: none;
17 |   outline: none;
18 |   line-height: 22px;
19 |   padding: 7px 4px;
20 |   color: inherit;
21 |   box-sizing: border-box;
22 | }
23 | .book.with-search .book-summary .book-search {
24 |   top: 0px;
25 | }
26 | .book.with-search .book-summary ul.summary {
27 |   top: 50px;
28 | }
29 | .with-search .summary li[data-level] a[href*=".html#"] {
30 |   display: none;
31 | }
32 | 


--------------------------------------------------------------------------------
/docs/libs/gitbook-2.6.7/css/plugin-table.css:
--------------------------------------------------------------------------------
1 | .book .book-body .page-wrapper .page-inner section.normal table{display:table;width:100%;border-collapse:collapse;border-spacing:0;overflow:auto}.book .book-body .page-wrapper .page-inner section.normal table td,.book .book-body .page-wrapper .page-inner section.normal table th{padding:6px 13px;border:1px solid #ddd}.book .book-body .page-wrapper .page-inner section.normal table tr{background-color:#fff;border-top:1px solid #ccc}.book .book-body .page-wrapper .page-inner section.normal table tr:nth-child(2n){background-color:#f8f8f8}.book .book-body .page-wrapper .page-inner section.normal table th{font-weight:700}
2 | 


--------------------------------------------------------------------------------
/docs/libs/gitbook-2.6.7/js/jquery.highlight.js:
--------------------------------------------------------------------------------
 1 | gitbook.require(["jQuery"], function(jQuery) {
 2 | 
 3 | /*
 4 |  * jQuery Highlight plugin
 5 |  *
 6 |  * Based on highlight v3 by Johann Burkard
 7 |  * http://johannburkard.de/blog/programming/javascript/highlight-javascript-text-higlighting-jquery-plugin.html
 8 |  *
 9 |  * Code a little bit refactored and cleaned (in my humble opinion).
10 |  * Most important changes:
11 |  *  - has an option to highlight only entire words (wordsOnly - false by default),
12 |  *  - has an option to be case sensitive (caseSensitive - false by default)
13 |  *  - highlight element tag and class names can be specified in options
14 |  *
15 |  * Copyright (c) 2009 Bartek Szopka
16 |  *
17 |  * Licensed under MIT license.
18 |  *
19 |  */
20 | 
21 | jQuery.extend({
22 |     highlight: function (node, re, nodeName, className) {
23 |         if (node.nodeType === 3) {
24 |             var match = node.data.match(re);
25 |             if (match) {
26 |                 var highlight = document.createElement(nodeName || 'span');
27 |                 highlight.className = className || 'highlight';
28 |                 var wordNode = node.splitText(match.index);
29 |                 wordNode.splitText(match[0].length);
30 |                 var wordClone = wordNode.cloneNode(true);
31 |                 highlight.appendChild(wordClone);
32 |                 wordNode.parentNode.replaceChild(highlight, wordNode);
33 |                 return 1; //skip added node in parent
34 |             }
35 |         } else if ((node.nodeType === 1 && node.childNodes) && // only element nodes that have children
36 |                 !/(script|style)/i.test(node.tagName) && // ignore script and style nodes
37 |                 !(node.tagName === nodeName.toUpperCase() && node.className === className)) { // skip if already highlighted
38 |             for (var i = 0; i < node.childNodes.length; i++) {
39 |                 i += jQuery.highlight(node.childNodes[i], re, nodeName, className);
40 |             }
41 |         }
42 |         return 0;
43 |     }
44 | });
45 | 
46 | jQuery.fn.unhighlight = function (options) {
47 |     var settings = { className: 'highlight', element: 'span' };
48 |     jQuery.extend(settings, options);
49 | 
50 |     return this.find(settings.element + "." + settings.className).each(function () {
51 |         var parent = this.parentNode;
52 |         parent.replaceChild(this.firstChild, this);
53 |         parent.normalize();
54 |     }).end();
55 | };
56 | 
57 | jQuery.fn.highlight = function (words, options) {
58 |     var settings = { className: 'highlight', element: 'span', caseSensitive: false, wordsOnly: false };
59 |     jQuery.extend(settings, options);
60 | 
61 |     if (words.constructor === String) {
62 |         words = [words];
63 |         // also match 'foo-bar' if search for 'foo bar'
64 |         if (/\s/.test(words[0])) words.push(words[0].replace(/\s+/, '-'));
65 |     }
66 |     words = jQuery.grep(words, function(word, i){
67 |       return word !== '';
68 |     });
69 |     words = jQuery.map(words, function(word, i) {
70 |       return word.replace(/[-[\]{}()*+?.,\\^$|#\s]/g, "\\$&");
71 |     });
72 |     if (words.length === 0) { return this; }
73 | 
74 |     var flag = settings.caseSensitive ? "" : "i";
75 |     var pattern = "(" + words.join("|") + ")";
76 |     if (settings.wordsOnly) {
77 |         pattern = "\\b" + pattern + "\\b";
78 |     }
79 |     var re = new RegExp(pattern, flag);
80 | 
81 |     return this.each(function () {
82 |         jQuery.highlight(this, re, settings.element, settings.className);
83 |     });
84 | };
85 | 
86 | });
87 | 


--------------------------------------------------------------------------------
/docs/libs/gitbook-2.6.7/js/plugin-clipboard.js:
--------------------------------------------------------------------------------
 1 | gitbook.require(["gitbook", "jQuery"], function(gitbook, $) {
 2 | 
 3 |   var copyButton = '<button type="button" class="copy-to-clipboard-button" title="Copy to clipboard" aria-label="Copy to clipboard"><i class="fa fa-copy"></i></button>';
 4 |   var clipboard;
 5 | 
 6 |   gitbook.events.bind("page.change", function() {
 7 | 
 8 |     if (!ClipboardJS.isSupported()) return;
 9 | 
10 |     // the page.change event is thrown twice: before and after the page changes
11 |     if (clipboard) {
12 |       // clipboard is already defined
13 |       // we can deduct that we are before page changes
14 |       clipboard.destroy(); // destroy the previous events listeners
15 |       clipboard = undefined; // reset the clipboard object
16 |       return;
17 |     }
18 | 
19 |     $(copyButton).prependTo("div.sourceCode");
20 | 
21 |     clipboard = new ClipboardJS(".copy-to-clipboard-button", {
22 |       text: function(trigger) {
23 |         return trigger.parentNode.textContent;
24 |       }
25 |     });
26 | 
27 |   });
28 | 
29 | });
30 | 


--------------------------------------------------------------------------------
/docs/libs/gitbook-2.6.7/js/plugin-fontsettings.js:
--------------------------------------------------------------------------------
  1 | gitbook.require(["gitbook", "lodash", "jQuery"], function(gitbook, _, $) {
  2 |     var fontState;
  3 | 
  4 |     var THEMES = {
  5 |         "white": 0,
  6 |         "sepia": 1,
  7 |         "night": 2
  8 |     };
  9 | 
 10 |     var FAMILY = {
 11 |         "serif": 0,
 12 |         "sans": 1
 13 |     };
 14 | 
 15 |     // Save current font settings
 16 |     function saveFontSettings() {
 17 |         gitbook.storage.set("fontState", fontState);
 18 |         update();
 19 |     }
 20 | 
 21 |     // Increase font size
 22 |     function enlargeFontSize(e) {
 23 |         e.preventDefault();
 24 |         if (fontState.size >= 4) return;
 25 | 
 26 |         fontState.size++;
 27 |         saveFontSettings();
 28 |     };
 29 | 
 30 |     // Decrease font size
 31 |     function reduceFontSize(e) {
 32 |         e.preventDefault();
 33 |         if (fontState.size <= 0) return;
 34 | 
 35 |         fontState.size--;
 36 |         saveFontSettings();
 37 |     };
 38 | 
 39 |     // Change font family
 40 |     function changeFontFamily(index, e) {
 41 |         e.preventDefault();
 42 | 
 43 |         fontState.family = index;
 44 |         saveFontSettings();
 45 |     };
 46 | 
 47 |     // Change type of color
 48 |     function changeColorTheme(index, e) {
 49 |         e.preventDefault();
 50 | 
 51 |         var $book = $(".book");
 52 | 
 53 |         if (fontState.theme !== 0)
 54 |             $book.removeClass("color-theme-"+fontState.theme);
 55 | 
 56 |         fontState.theme = index;
 57 |         if (fontState.theme !== 0)
 58 |             $book.addClass("color-theme-"+fontState.theme);
 59 | 
 60 |         saveFontSettings();
 61 |     };
 62 | 
 63 |     function update() {
 64 |         var $book = gitbook.state.$book;
 65 | 
 66 |         $(".font-settings .font-family-list li").removeClass("active");
 67 |         $(".font-settings .font-family-list li:nth-child("+(fontState.family+1)+")").addClass("active");
 68 | 
 69 |         $book[0].className = $book[0].className.replace(/\bfont-\S+/g, '');
 70 |         $book.addClass("font-size-"+fontState.size);
 71 |         $book.addClass("font-family-"+fontState.family);
 72 | 
 73 |         if(fontState.theme !== 0) {
 74 |             $book[0].className = $book[0].className.replace(/\bcolor-theme-\S+/g, '');
 75 |             $book.addClass("color-theme-"+fontState.theme);
 76 |         }
 77 |     };
 78 | 
 79 |     function init(config) {
 80 |         var $bookBody, $book;
 81 | 
 82 |         //Find DOM elements.
 83 |         $book = gitbook.state.$book;
 84 |         $bookBody = $book.find(".book-body");
 85 | 
 86 |         // Instantiate font state object
 87 |         fontState = gitbook.storage.get("fontState", {
 88 |             size: config.size || 2,
 89 |             family: FAMILY[config.family || "sans"],
 90 |             theme: THEMES[config.theme || "white"]
 91 |         });
 92 | 
 93 |         update();
 94 |     };
 95 | 
 96 | 
 97 |     gitbook.events.bind("start", function(e, config) {
 98 |         var opts = config.fontsettings;
 99 |         if (!opts) return;
100 |         
101 |         // Create buttons in toolbar
102 |         gitbook.toolbar.createButton({
103 |             icon: 'fa fa-font',
104 |             label: 'Font Settings',
105 |             className: 'font-settings',
106 |             dropdown: [
107 |                 [
108 |                     {
109 |                         text: 'A',
110 |                         className: 'font-reduce',
111 |                         onClick: reduceFontSize
112 |                     },
113 |                     {
114 |                         text: 'A',
115 |                         className: 'font-enlarge',
116 |                         onClick: enlargeFontSize
117 |                     }
118 |                 ],
119 |                 [
120 |                     {
121 |                         text: 'Serif',
122 |                         onClick: _.partial(changeFontFamily, 0)
123 |                     },
124 |                     {
125 |                         text: 'Sans',
126 |                         onClick: _.partial(changeFontFamily, 1)
127 |                     }
128 |                 ],
129 |                 [
130 |                     {
131 |                         text: 'White',
132 |                         onClick: _.partial(changeColorTheme, 0)
133 |                     },
134 |                     {
135 |                         text: 'Sepia',
136 |                         onClick: _.partial(changeColorTheme, 1)
137 |                     },
138 |                     {
139 |                         text: 'Night',
140 |                         onClick: _.partial(changeColorTheme, 2)
141 |                     }
142 |                 ]
143 |             ]
144 |         });
145 | 
146 | 
147 |         // Init current settings
148 |         init(opts);
149 |     });
150 | });
151 | 
152 | 
153 | 


--------------------------------------------------------------------------------
/docs/libs/gitbook-2.6.7/js/plugin-sharing.js:
--------------------------------------------------------------------------------
  1 | gitbook.require(["gitbook", "lodash", "jQuery"], function(gitbook, _, $) {
  2 |     var SITES = {
  3 |         'github': {
  4 |             'label': 'Github',
  5 |             'icon': 'fa fa-github',
  6 |             'onClick': function(e) {
  7 |                 e.preventDefault();
  8 |                 var repo = $('meta[name="github-repo"]').attr('content');
  9 |                 if (typeof repo === 'undefined') throw("Github repo not defined");
 10 |                 window.open("https://github.com/"+repo);
 11 |             }
 12 |         },
 13 |         'facebook': {
 14 |             'label': 'Facebook',
 15 |             'icon': 'fa fa-facebook',
 16 |             'onClick': function(e) {
 17 |                 e.preventDefault();
 18 |                 window.open("http://www.facebook.com/sharer/sharer.php?u="+encodeURIComponent(location.href));
 19 |             }
 20 |         },
 21 |         'twitter': {
 22 |             'label': 'Twitter',
 23 |             'icon': 'fa fa-twitter',
 24 |             'onClick': function(e) {
 25 |                 e.preventDefault();
 26 |                 window.open("http://twitter.com/intent/tweet?text="+encodeURIComponent(document.title)+"&url="+encodeURIComponent(location.href)+"&hashtags=rmarkdown,bookdown");
 27 |             }
 28 |         },
 29 |         'linkedin': {
 30 |             'label': 'LinkedIn',
 31 |             'icon': 'fa fa-linkedin',
 32 |             'onClick': function(e) {
 33 |                 e.preventDefault();
 34 |                 window.open("https://www.linkedin.com/shareArticle?mini=true&url="+encodeURIComponent(location.href)+"&title="+encodeURIComponent(document.title));
 35 |             }
 36 |         },
 37 |         'weibo': {
 38 |             'label': 'Weibo',
 39 |             'icon': 'fa fa-weibo',
 40 |             'onClick': function(e) {
 41 |                 e.preventDefault();
 42 |                 window.open("http://service.weibo.com/share/share.php?content=utf-8&url="+encodeURIComponent(location.href)+"&title="+encodeURIComponent(document.title));
 43 |             }
 44 |         },
 45 |         'instapaper': {
 46 |             'label': 'Instapaper',
 47 |             'icon': 'fa fa-italic',
 48 |             'onClick': function(e) {
 49 |                 e.preventDefault();
 50 |                 window.open("http://www.instapaper.com/text?u="+encodeURIComponent(location.href));
 51 |             }
 52 |         },
 53 |         'vk': {
 54 |             'label': 'VK',
 55 |             'icon': 'fa fa-vk',
 56 |             'onClick': function(e) {
 57 |                 e.preventDefault();
 58 |                 window.open("http://vkontakte.ru/share.php?url="+encodeURIComponent(location.href));
 59 |             }
 60 |         }
 61 |     };
 62 | 
 63 | 
 64 | 
 65 |     gitbook.events.bind("start", function(e, config) {
 66 |         var opts = config.sharing;
 67 |         if (!opts) return;
 68 | 
 69 |         // Create dropdown menu
 70 |         var menu = _.chain(opts.all)
 71 |             .map(function(id) {
 72 |                 var site = SITES[id];
 73 |                 if (!site) return;
 74 |                 return {
 75 |                     text: site.label,
 76 |                     onClick: site.onClick
 77 |                 };
 78 |             })
 79 |             .compact()
 80 |             .value();
 81 | 
 82 |         // Create main button with dropdown
 83 |         if (menu.length > 0) {
 84 |             gitbook.toolbar.createButton({
 85 |                 icon: 'fa fa-share-alt',
 86 |                 label: 'Share',
 87 |                 position: 'right',
 88 |                 dropdown: [menu]
 89 |             });
 90 |         }
 91 | 
 92 |         // Direct actions to share
 93 |         _.each(SITES, function(site, sideId) {
 94 |             if (!opts[sideId]) return;
 95 | 
 96 |             gitbook.toolbar.createButton({
 97 |                 icon: site.icon,
 98 |                 label: site.label,
 99 |                 title: site.label,
100 |                 position: 'right',
101 |                 onClick: site.onClick
102 |             });
103 |         });
104 |     });
105 | });
106 | 


--------------------------------------------------------------------------------
/docs/libs/grViz-binding-1.0.6.1/grViz.js:
--------------------------------------------------------------------------------
 1 | HTMLWidgets.widget({
 2 | 
 3 |   name: 'grViz',
 4 | 
 5 |   type: 'output',
 6 | 
 7 |   initialize: function(el, width, height) {
 8 | 
 9 |     return {
10 |       // TODO: add instance fields as required
11 |     };
12 |   },
13 | 
14 |   renderValue: function(el, x, instance) {
15 |     //  Use this to sort of make our diagram responsive
16 |     //  or at a minimum fit within the bounds set by htmlwidgets
17 |     //  for the parent container
18 |     function makeResponsive(el){
19 |        var svg = el.getElementsByTagName("svg")[0];
20 |        if (svg) {
21 |         if (svg.width) {svg.removeAttribute("width")}
22 |         if (svg.height) {svg.removeAttribute("height")}
23 |         svg.style.width = "100%";
24 |         svg.style.height = "100%";
25 |        }
26 |     }
27 | 
28 |     if (x.diagram !== "") {
29 | 
30 |       if (typeof x.config === "undefined"){
31 |         x.config = {};
32 |         x.config.engine = "dot";
33 |         x.config.options = {};
34 |       }
35 | 
36 |       try {
37 | 
38 |         el.innerHTML = Viz(x.diagram, format="svg", engine=x.config.engine, options=x.config.options);
39 | 
40 |         makeResponsive(el);
41 | 
42 |         if (HTMLWidgets.shinyMode) {
43 |           // Get widget id
44 |           var id = el.id;
45 | 
46 |           $("#" + id + " .node").click(function(e) {
47 |             // Get node id
48 |             var nodeid = e.currentTarget.id;
49 |             // Get node text object and make an array
50 |             var node_texts = $("#" + nodeid + " text");
51 |             //var node_path = $("#" + nodeid + " path")[0];
52 |             var text_array = node_texts.map(function() {return $(this).text(); }).toArray();
53 |             // Build return object *obj* with node-id, node text values and node fill
54 |             var obj = {
55 |               id: nodeid,
56 |               //fill: node_path.attributes.fill.nodeValue,
57 |               //outerHMTL: node_path.outerHTML,
58 |               nodeValues: text_array
59 |             };
60 |             // Send *obj* to Shiny's inputs (input$[id]+_click  e.g.: input$vtree_click))
61 |             Shiny.setInputValue(id + "_click", obj, {priority: "event"});
62 |           });
63 |         }
64 | 
65 |         // set up a container for tasks to perform after completion
66 |         //  one example would be add callbacks for event handling
67 |         //  styling
68 |         if (typeof x.tasks !== "undefined") {
69 |           if ((typeof x.tasks.length === "undefined") ||
70 |            (typeof x.tasks === "function")) {
71 |              // handle a function not enclosed in array
72 |              // should be able to remove once using jsonlite
73 |              x.tasks = [x.tasks];
74 |           }
75 |           x.tasks.map(function(t){
76 |             // for each tasks add it to the mermaid.tasks with el
77 |             t.call(el);
78 |           });
79 |         }
80 |       } catch(e){
81 |         var p = document.createElement("pre");
82 |         p.innerText = e;
83 |         el.appendChild(p);
84 |       }
85 |     }
86 | 
87 |   },
88 | 
89 |   resize: function(el, width, height, instance) {
90 |   }
91 | });
92 | 


--------------------------------------------------------------------------------
/docs/libs/header-attrs-2.5/header-attrs.js:
--------------------------------------------------------------------------------
 1 | // Pandoc 2.9 adds attributes on both header and div. We remove the former (to
 2 | // be compatible with the behavior of Pandoc < 2.8).
 3 | document.addEventListener('DOMContentLoaded', function(e) {
 4 |   var hs = document.querySelectorAll("div.section[class*='level'] > :first-child");
 5 |   var i, h, a;
 6 |   for (i = 0; i < hs.length; i++) {
 7 |     h = hs[i];
 8 |     if (!/^h[1-6]$/i.test(h.tagName)) continue;  // it should be a header h1-h6
 9 |     a = h.attributes;
10 |     while (a.length > 0) h.removeAttribute(a[0].name);
11 |   }
12 | });
13 | 


--------------------------------------------------------------------------------
/docs/libs/header-attrs-2.6/header-attrs.js:
--------------------------------------------------------------------------------
 1 | // Pandoc 2.9 adds attributes on both header and div. We remove the former (to
 2 | // be compatible with the behavior of Pandoc < 2.8).
 3 | document.addEventListener('DOMContentLoaded', function(e) {
 4 |   var hs = document.querySelectorAll("div.section[class*='level'] > :first-child");
 5 |   var i, h, a;
 6 |   for (i = 0; i < hs.length; i++) {
 7 |     h = hs[i];
 8 |     if (!/^h[1-6]$/i.test(h.tagName)) continue;  // it should be a header h1-h6
 9 |     a = h.attributes;
10 |     while (a.length > 0) h.removeAttribute(a[0].name);
11 |   }
12 | });
13 | 


--------------------------------------------------------------------------------
/docs/libs/kePrint-0.0.1/kePrint.js:
--------------------------------------------------------------------------------
1 | $(document).ready(function(){
2 |     if (typeof $('[data-toggle="tooltip"]').tooltip === 'function') {
3 |         $('[data-toggle="tooltip"]').tooltip();
4 |     }
5 |     if ($('[data-toggle="popover"]').popover === 'function') {
6 |         $('[data-toggle="popover"]').popover();
7 |     }
8 | });
9 | 


--------------------------------------------------------------------------------
/docs/libs/lightable-0.0.1/lightable.css:
--------------------------------------------------------------------------------
  1 | /*!
  2 |  * lightable v0.0.1
  3 |  * Copyright 2020 Hao Zhu
  4 |  * Licensed under MIT (https://github.com/haozhu233/kableExtra/blob/master/LICENSE)
  5 |  */
  6 | 
  7 | .lightable-minimal {
  8 |   border-collapse: separate;
  9 |   border-spacing: 16px 1px;
 10 |   width: 100%;
 11 |   margin-bottom: 10px;
 12 | }
 13 | 
 14 | .lightable-minimal td {
 15 |   margin-left: 5px;
 16 |   margin-right: 5px;
 17 | }
 18 | 
 19 | .lightable-minimal th {
 20 |   margin-left: 5px;
 21 |   margin-right: 5px;
 22 | }
 23 | 
 24 | .lightable-minimal thead tr:last-child th {
 25 |   border-bottom: 2px solid #00000050;
 26 |   empty-cells: hide;
 27 | 
 28 | }
 29 | 
 30 | .lightable-minimal tbody tr:first-child td {
 31 |   padding-top: 0.5em;
 32 | }
 33 | 
 34 | .lightable-minimal.lightable-hover tbody tr:hover {
 35 |   background-color: #f5f5f5;
 36 | }
 37 | 
 38 | .lightable-minimal.lightable-striped tbody tr:nth-child(even) {
 39 |   background-color: #f5f5f5;
 40 | }
 41 | 
 42 | .lightable-classic {
 43 |   border-top: 0.16em solid #111111;
 44 |   border-bottom: 0.16em solid #111111;
 45 |   width: 100%;
 46 |   margin-bottom: 10px;
 47 |   margin: 10px 5px;
 48 | }
 49 | 
 50 | .lightable-classic tfoot tr td {
 51 |   border: 0;
 52 | }
 53 | 
 54 | .lightable-classic tfoot tr:first-child td {
 55 |   border-top: 0.14em solid #111111;
 56 | }
 57 | 
 58 | .lightable-classic caption {
 59 |   color: #222222;
 60 | }
 61 | 
 62 | .lightable-classic td {
 63 |   padding-left: 5px;
 64 |   padding-right: 5px;
 65 |   color: #222222;
 66 | }
 67 | 
 68 | .lightable-classic th {
 69 |   padding-left: 5px;
 70 |   padding-right: 5px;
 71 |   font-weight: normal;
 72 |   color: #222222;
 73 | }
 74 | 
 75 | .lightable-classic thead tr:last-child th {
 76 |   border-bottom: 0.10em solid #111111;
 77 | }
 78 | 
 79 | .lightable-classic.lightable-hover tbody tr:hover {
 80 |   background-color: #F9EEC1;
 81 | }
 82 | 
 83 | .lightable-classic.lightable-striped tbody tr:nth-child(even) {
 84 |   background-color: #f5f5f5;
 85 | }
 86 | 
 87 | .lightable-classic-2 {
 88 |   border-top: 3px double #111111;
 89 |   border-bottom: 3px double #111111;
 90 |   width: 100%;
 91 |   margin-bottom: 10px;
 92 | }
 93 | 
 94 | .lightable-classic-2 tfoot tr td {
 95 |   border: 0;
 96 | }
 97 | 
 98 | .lightable-classic-2 tfoot tr:first-child td {
 99 |   border-top: 3px double #111111;
100 | }
101 | 
102 | .lightable-classic-2 caption {
103 |   color: #222222;
104 | }
105 | 
106 | .lightable-classic-2 td {
107 |   padding-left: 5px;
108 |   padding-right: 5px;
109 |   color: #222222;
110 | }
111 | 
112 | .lightable-classic-2 th {
113 |   padding-left: 5px;
114 |   padding-right: 5px;
115 |   font-weight: normal;
116 |   color: #222222;
117 | }
118 | 
119 | .lightable-classic-2 tbody tr:last-child td {
120 |   border-bottom: 3px double #111111;
121 | }
122 | 
123 | .lightable-classic-2 thead tr:last-child th {
124 |   border-bottom: 1px solid #111111;
125 | }
126 | 
127 | .lightable-classic-2.lightable-hover tbody tr:hover {
128 |   background-color: #F9EEC1;
129 | }
130 | 
131 | .lightable-classic-2.lightable-striped tbody tr:nth-child(even) {
132 |   background-color: #f5f5f5;
133 | }
134 | 
135 | .lightable-material {
136 |   min-width: 100%;
137 |   white-space: nowrap;
138 |   table-layout: fixed;
139 |   font-family: Roboto, sans-serif;
140 |   border: 1px solid #EEE;
141 |   border-collapse: collapse;
142 |   margin-bottom: 10px;
143 | }
144 | 
145 | .lightable-material tfoot tr td {
146 |   border: 0;
147 | }
148 | 
149 | .lightable-material tfoot tr:first-child td {
150 |   border-top: 1px solid #EEE;
151 | }
152 | 
153 | .lightable-material th {
154 |   height: 56px;
155 |   padding-left: 16px;
156 |   padding-right: 16px;
157 | }
158 | 
159 | .lightable-material td {
160 |   height: 52px;
161 |   padding-left: 16px;
162 |   padding-right: 16px;
163 |   border-top: 1px solid #eeeeee;
164 | }
165 | 
166 | .lightable-material.lightable-hover tbody tr:hover {
167 |   background-color: #f5f5f5;
168 | }
169 | 
170 | .lightable-material.lightable-striped tbody tr:nth-child(even) {
171 |   background-color: #f5f5f5;
172 | }
173 | 
174 | .lightable-material.lightable-striped tbody td {
175 |   border: 0;
176 | }
177 | 
178 | .lightable-material.lightable-striped thead tr:last-child th {
179 |   border-bottom: 1px solid #ddd;
180 | }
181 | 
182 | .lightable-material-dark {
183 |   min-width: 100%;
184 |   white-space: nowrap;
185 |   table-layout: fixed;
186 |   font-family: Roboto, sans-serif;
187 |   border: 1px solid #FFFFFF12;
188 |   border-collapse: collapse;
189 |   margin-bottom: 10px;
190 |   background-color: #363640;
191 | }
192 | 
193 | .lightable-material-dark tfoot tr td {
194 |   border: 0;
195 | }
196 | 
197 | .lightable-material-dark tfoot tr:first-child td {
198 |   border-top: 1px solid #FFFFFF12;
199 | }
200 | 
201 | .lightable-material-dark th {
202 |   height: 56px;
203 |   padding-left: 16px;
204 |   padding-right: 16px;
205 |   color: #FFFFFF60;
206 | }
207 | 
208 | .lightable-material-dark td {
209 |   height: 52px;
210 |   padding-left: 16px;
211 |   padding-right: 16px;
212 |   color: #FFFFFF;
213 |   border-top: 1px solid #FFFFFF12;
214 | }
215 | 
216 | .lightable-material-dark.lightable-hover tbody tr:hover {
217 |   background-color: #FFFFFF12;
218 | }
219 | 
220 | .lightable-material-dark.lightable-striped tbody tr:nth-child(even) {
221 |   background-color: #FFFFFF12;
222 | }
223 | 
224 | .lightable-material-dark.lightable-striped tbody td {
225 |   border: 0;
226 | }
227 | 
228 | .lightable-material-dark.lightable-striped thead tr:last-child th {
229 |   border-bottom: 1px solid #FFFFFF12;
230 | }
231 | 
232 | .lightable-paper {
233 |   width: 100%;
234 |   margin-bottom: 10px;
235 |   color: #444;
236 | }
237 | 
238 | .lightable-paper tfoot tr td {
239 |   border: 0;
240 | }
241 | 
242 | .lightable-paper tfoot tr:first-child td {
243 |   border-top: 1px solid #00000020;
244 | }
245 | 
246 | .lightable-paper thead tr:last-child th {
247 |   color: #666;
248 |   vertical-align: bottom;
249 |   border-bottom: 1px solid #00000020;
250 |   line-height: 1.15em;
251 |   padding: 10px 5px;
252 | }
253 | 
254 | .lightable-paper td {
255 |   vertical-align: middle;
256 |   border-bottom: 1px solid #00000010;
257 |   line-height: 1.15em;
258 |   padding: 7px 5px;
259 | }
260 | 
261 | .lightable-paper.lightable-hover tbody tr:hover {
262 |   background-color: #F9EEC1;
263 | }
264 | 
265 | .lightable-paper.lightable-striped tbody tr:nth-child(even) {
266 |   background-color: #00000008;
267 | }
268 | 
269 | .lightable-paper.lightable-striped tbody td {
270 |   border: 0;
271 | }
272 | 
273 | 


--------------------------------------------------------------------------------
/docs/libs/plotly-htmlwidgets-css-1.52.2/plotly-htmlwidgets.css:
--------------------------------------------------------------------------------
 1 | /*
 2 | just here so that plotly works
 3 | correctly with ioslides.
 4 | see https://github.com/ropensci/plotly/issues/463
 5 | */
 6 | 
 7 | slide:not(.current) .plotly.html-widget{
 8 |   display: none;
 9 | }
10 | 


--------------------------------------------------------------------------------
/docs/model-demos_files/figure-html/em-pca-vis-1.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/m-clark/models-by-example/b544c35a3fdd63baecee7f904469c1174862ced3/docs/model-demos_files/figure-html/em-pca-vis-1.png


--------------------------------------------------------------------------------
/docs/model-demos_files/figure-html/em-ppca-miss-vis-recon-1.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/m-clark/models-by-example/b544c35a3fdd63baecee7f904469c1174862ced3/docs/model-demos_files/figure-html/em-ppca-miss-vis-recon-1.png


--------------------------------------------------------------------------------
/docs/model-demos_files/figure-html/em-ppca-miss-vis-recon-2.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/m-clark/models-by-example/b544c35a3fdd63baecee7f904469c1174862ced3/docs/model-demos_files/figure-html/em-ppca-miss-vis-recon-2.png


--------------------------------------------------------------------------------
/docs/model-demos_files/figure-html/em-ppca-miss-vis-scores-1.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/m-clark/models-by-example/b544c35a3fdd63baecee7f904469c1174862ced3/docs/model-demos_files/figure-html/em-ppca-miss-vis-scores-1.png


--------------------------------------------------------------------------------
/docs/model-demos_files/figure-html/em-ppca-vis-recon-1.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/m-clark/models-by-example/b544c35a3fdd63baecee7f904469c1174862ced3/docs/model-demos_files/figure-html/em-ppca-vis-recon-1.png


--------------------------------------------------------------------------------
/docs/model-demos_files/figure-html/em-ppca-vis-recon-2.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/m-clark/models-by-example/b544c35a3fdd63baecee7f904469c1174862ced3/docs/model-demos_files/figure-html/em-ppca-vis-recon-2.png


--------------------------------------------------------------------------------
/docs/model-demos_files/figure-html/em-ppca-vis-scores-1.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/m-clark/models-by-example/b544c35a3fdd63baecee7f904469c1174862ced3/docs/model-demos_files/figure-html/em-ppca-vis-scores-1.png


--------------------------------------------------------------------------------
/docs/model-demos_files/figure-html/em-ssm-vis-1.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/m-clark/models-by-example/b544c35a3fdd63baecee7f904469c1174862ced3/docs/model-demos_files/figure-html/em-ssm-vis-1.png


--------------------------------------------------------------------------------
/docs/model-demos_files/figure-html/gaussEM-vis-1.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/m-clark/models-by-example/b544c35a3fdd63baecee7f904469c1174862ced3/docs/model-demos_files/figure-html/gaussEM-vis-1.png


--------------------------------------------------------------------------------
/docs/model-demos_files/figure-html/gaussEM-vis-2.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/m-clark/models-by-example/b544c35a3fdd63baecee7f904469c1174862ced3/docs/model-demos_files/figure-html/gaussEM-vis-2.png


--------------------------------------------------------------------------------
/docs/model-demos_files/figure-html/gd-result-1.svg:
--------------------------------------------------------------------------------
1 | <svg xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" viewBox="0 0 504 378"><defs><style type="text/css">line,polyline,rect{fill:none;stroke:#000;stroke-linecap:round;stroke-linejoin:round;stroke-miterlimit:10}</style></defs><rect width="100%" height="100%" style="stroke:none;fill:none"/><defs><clipPath id="cpNTkuMDR8NDczLjc2fDMwNC41Nnw1OS4wNA=="><rect width="414.72" height="245.52" x="59.04" y="59.04"/></clipPath></defs><polyline points="74.4 68.13 79.97 68.13 85.53 111.5 91.1 139.86 96.66 168.4 102.23 196.07 107.79 221.71 113.36 244.19 118.92 262.59 124.49 276.43 130.05 285.77 135.62 291.28 141.18 294.02 146.75 295.09 152.31 295.4 157.88 295.46 163.44 295.47 169.01 295.47 174.57 295.47 180.14 295.47 185.7 295.47 191.27 295.47 196.83 295.47 202.4 295.47 207.97 295.47 213.53 295.47 219.1 295.47 224.66 295.47 230.23 295.47 235.79 295.47 241.36 295.47 246.92 295.47 252.49 295.47 258.05 295.47 263.62 295.47 269.18 295.47 274.75 295.47 280.31 295.47 285.88 295.47 291.44 295.47 297.01 295.47 302.57 295.47 308.14 295.47 313.7 295.47 319.27 295.47 324.83 295.47 330.4 295.47 335.97 295.47 341.53 295.47 347.1 295.47 352.66 295.47 358.23 295.47 363.79 295.47 369.36 295.47 374.92 295.47 380.49 295.47 386.05 295.47 391.62 295.47 397.18 295.47 402.75 295.47 408.31 295.47 413.88 295.47 419.44 295.47 425.01 295.47 430.57 295.47 436.14 295.47 441.7 295.47 447.27 295.47 452.83 295.47 458.4 295.47" clip-path="url(#cpNTkuMDR8NDczLjc2fDMwNC41Nnw1OS4wNA==)" style="stroke-width:.75"/><defs><clipPath id="cpMC4wMHw1MDQuMDB8Mzc4LjAwfDAuMDA="><rect width="504" height="378" x="0" y="0"/></clipPath></defs><line x1="68.83" x2="458.4" y1="304.56" y2="304.56" clip-path="url(#cpMC4wMHw1MDQuMDB8Mzc4LjAwfDAuMDA=)" style="stroke-width:.75"/><line x1="68.83" x2="68.83" y1="304.56" y2="311.76" clip-path="url(#cpMC4wMHw1MDQuMDB8Mzc4LjAwfDAuMDA=)" style="stroke-width:.75"/><line x1="124.49" x2="124.49" y1="304.56" y2="311.76" clip-path="url(#cpMC4wMHw1MDQuMDB8Mzc4LjAwfDAuMDA=)" style="stroke-width:.75"/><line x1="180.14" x2="180.14" y1="304.56" y2="311.76" clip-path="url(#cpMC4wMHw1MDQuMDB8Mzc4LjAwfDAuMDA=)" style="stroke-width:.75"/><line x1="235.79" x2="235.79" y1="304.56" y2="311.76" clip-path="url(#cpMC4wMHw1MDQuMDB8Mzc4LjAwfDAuMDA=)" style="stroke-width:.75"/><line x1="291.44" x2="291.44" y1="304.56" y2="311.76" clip-path="url(#cpMC4wMHw1MDQuMDB8Mzc4LjAwfDAuMDA=)" style="stroke-width:.75"/><line x1="347.1" x2="347.1" y1="304.56" y2="311.76" clip-path="url(#cpMC4wMHw1MDQuMDB8Mzc4LjAwfDAuMDA=)" style="stroke-width:.75"/><line x1="402.75" x2="402.75" y1="304.56" y2="311.76" clip-path="url(#cpMC4wMHw1MDQuMDB8Mzc4LjAwfDAuMDA=)" style="stroke-width:.75"/><line x1="458.4" x2="458.4" y1="304.56" y2="311.76" clip-path="url(#cpMC4wMHw1MDQuMDB8Mzc4LjAwfDAuMDA=)" style="stroke-width:.75"/><g clip-path="url(#cpMC4wMHw1MDQuMDB8Mzc4LjAwfDAuMDA=)"><text x="65.5" y="330.48" lengthAdjust="spacingAndGlyphs" textLength="6.67" style="font-size:12px;font-family:Arial">0</text></g><g clip-path="url(#cpMC4wMHw1MDQuMDB8Mzc4LjAwfDAuMDA=)"><text x="117.81" y="330.48" lengthAdjust="spacingAndGlyphs" textLength="13.35" style="font-size:12px;font-family:Arial">10</text></g><g clip-path="url(#cpMC4wMHw1MDQuMDB8Mzc4LjAwfDAuMDA=)"><text x="173.47" y="330.48" lengthAdjust="spacingAndGlyphs" textLength="13.35" style="font-size:12px;font-family:Arial">20</text></g><g clip-path="url(#cpMC4wMHw1MDQuMDB8Mzc4LjAwfDAuMDA=)"><text x="229.12" y="330.48" lengthAdjust="spacingAndGlyphs" textLength="13.35" style="font-size:12px;font-family:Arial">30</text></g><g clip-path="url(#cpMC4wMHw1MDQuMDB8Mzc4LjAwfDAuMDA=)"><text x="284.77" y="330.48" lengthAdjust="spacingAndGlyphs" textLength="13.35" style="font-size:12px;font-family:Arial">40</text></g><g clip-path="url(#cpMC4wMHw1MDQuMDB8Mzc4LjAwfDAuMDA=)"><text x="340.42" y="330.48" lengthAdjust="spacingAndGlyphs" textLength="13.35" style="font-size:12px;font-family:Arial">50</text></g><g clip-path="url(#cpMC4wMHw1MDQuMDB8Mzc4LjAwfDAuMDA=)"><text x="396.07" y="330.48" lengthAdjust="spacingAndGlyphs" textLength="13.35" style="font-size:12px;font-family:Arial">60</text></g><g clip-path="url(#cpMC4wMHw1MDQuMDB8Mzc4LjAwfDAuMDA=)"><text x="451.73" y="330.48" lengthAdjust="spacingAndGlyphs" textLength="13.35" style="font-size:12px;font-family:Arial">70</text></g><line x1="59.04" x2="59.04" y1="269.67" y2="88.85" clip-path="url(#cpMC4wMHw1MDQuMDB8Mzc4LjAwfDAuMDA=)" style="stroke-width:.75"/><line x1="59.04" x2="51.84" y1="269.67" y2="269.67" clip-path="url(#cpMC4wMHw1MDQuMDB8Mzc4LjAwfDAuMDA=)" style="stroke-width:.75"/><line x1="59.04" x2="51.84" y1="233.51" y2="233.51" clip-path="url(#cpMC4wMHw1MDQuMDB8Mzc4LjAwfDAuMDA=)" style="stroke-width:.75"/><line x1="59.04" x2="51.84" y1="197.34" y2="197.34" clip-path="url(#cpMC4wMHw1MDQuMDB8Mzc4LjAwfDAuMDA=)" style="stroke-width:.75"/><line x1="59.04" x2="51.84" y1="161.18" y2="161.18" clip-path="url(#cpMC4wMHw1MDQuMDB8Mzc4LjAwfDAuMDA=)" style="stroke-width:.75"/><line x1="59.04" x2="51.84" y1="125.02" y2="125.02" clip-path="url(#cpMC4wMHw1MDQuMDB8Mzc4LjAwfDAuMDA=)" style="stroke-width:.75"/><line x1="59.04" x2="51.84" y1="88.85" y2="88.85" clip-path="url(#cpMC4wMHw1MDQuMDB8Mzc4LjAwfDAuMDA=)" style="stroke-width:.75"/><g clip-path="url(#cpMC4wMHw1MDQuMDB8Mzc4LjAwfDAuMDA=)"><text style="font-size:12px;font-family:Arial" lengthAdjust="spacingAndGlyphs" textLength="26.7" transform="translate(41.76,283.02) rotate(-90)">1200</text></g><g clip-path="url(#cpMC4wMHw1MDQuMDB8Mzc4LjAwfDAuMDA=)"><text style="font-size:12px;font-family:Arial" lengthAdjust="spacingAndGlyphs" textLength="26.7" transform="translate(41.76,210.69) rotate(-90)">1600</text></g><g clip-path="url(#cpMC4wMHw1MDQuMDB8Mzc4LjAwfDAuMDA=)"><text style="font-size:12px;font-family:Arial" lengthAdjust="spacingAndGlyphs" textLength="26.7" transform="translate(41.76,138.36) rotate(-90)">2000</text></g><g clip-path="url(#cpMC4wMHw1MDQuMDB8Mzc4LjAwfDAuMDA=)"><text x="251.72" y="359.28" lengthAdjust="spacingAndGlyphs" textLength="29.36" style="font-size:12px;font-family:Arial">Index</text></g><g clip-path="url(#cpMC4wMHw1MDQuMDB8Mzc4LjAwfDAuMDA=)"><text style="font-size:12px;font-family:Arial" lengthAdjust="spacingAndGlyphs" textLength="21.34" transform="translate(12.96,192.47) rotate(-90)">loss</text></g></svg>


--------------------------------------------------------------------------------
/docs/model-demos_files/figure-html/markov-chain-demo-1.svg:
--------------------------------------------------------------------------------
1 | <svg xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" viewBox="0 0 504 378"><defs><style type="text/css">circle,line,polygon,polyline,rect{fill:none;stroke:#000;stroke-linecap:round;stroke-linejoin:round;stroke-miterlimit:10}</style></defs><rect width="100%" height="100%" style="stroke:none;fill:none"/><defs><clipPath id="cpNTkuMDR8NDczLjc2fDMwNC41Nnw1OS4wNA=="><rect width="414.72" height="245.52" x="59.04" y="59.04"/></clipPath></defs><polyline points="380.07 287.54 382.6 286.32 385.03 285.26 387.36 284.34 389.58 283.56 391.69 282.91 393.7 282.39 395.6 281.99 397.4 281.7 399.09 281.52 400.68 281.44 402.16 281.45 403.53 281.55 404.8 281.73 405.96 281.99 407.02 282.31 407.97 282.7 408.81 283.14 409.55 283.62 410.19 284.16 410.72 284.72 411.14 285.32 411.46 285.93 411.67 286.57 411.77 287.21 411.77 287.86 411.67 288.5 411.46 289.14 411.14 289.76 410.72 290.35 410.19 290.92 409.55 291.45 408.81 291.94 407.97 292.38 407.02 292.76 405.96 293.09 404.8 293.34 403.53 293.52 402.16 293.62 400.68 293.64 399.09 293.55 397.4 293.37 395.6 293.09 393.7 292.68 391.69 292.16 389.58 291.52 387.36 290.74 385.03 289.82 382.6 288.75 380.07 287.54 380.07 287.54" clip-path="url(#cpNTkuMDR8NDczLjc2fDMwNC41Nnw1OS4wNA==)" style="stroke-width:.75;stroke:#a9a9a9"/><line x1="381.3" x2="380.07" y1="286.94" y2="287.54" clip-path="url(#cpNTkuMDR8NDczLjc2fDMwNC41Nnw1OS4wNA==)" style="stroke-width:.75;stroke:#a9a9a9"/><polygon points="391.15 277.35 390.46 278.37 389.67 279.43 388.78 280.54 387.73 281.73 386.44 283.03 384.68 284.56 380.04 287.47 380.1 287.6 385.27 285.8 387.57 285.39 389.4 285.19 390.98 285.12 392.41 285.12 393.72 285.17 394.95 285.27" clip-path="url(#cpNTkuMDR8NDczLjc2fDMwNC41Nnw1OS4wNA==)" style="stroke-width:.75;stroke:#a9a9a9;fill:#a9a9a9"/><g clip-path="url(#cpNTkuMDR8NDczLjc2fDMwNC41Nnw1OS4wNA==)"><text x="404.29" y="291.5" lengthAdjust="spacingAndGlyphs" textLength="15" style="font-size:12px;fill:#00008b;font-family:Times">0.7</text></g><polyline points="168.59 76.06 171.13 74.85 173.56 73.78 175.89 72.86 178.11 72.08 180.22 71.44 182.23 70.92 184.13 70.51 185.93 70.23 187.62 70.05 189.2 69.96 190.68 69.98 192.06 70.08 193.33 70.26 194.49 70.51 195.55 70.84 196.5 71.22 197.34 71.66 198.08 72.15 198.72 72.68 199.24 73.25 199.67 73.84 199.98 74.46 200.2 75.1 200.3 75.74 200.3 76.39 200.2 77.03 199.98 77.67 199.67 78.28 199.24 78.88 198.72 79.44 198.08 79.98 197.34 80.46 196.5 80.9 195.55 81.29 194.49 81.61 193.33 81.87 192.06 82.05 190.68 82.15 189.2 82.16 187.62 82.08 185.93 81.9 184.13 81.61 182.23 81.21 180.22 80.69 178.11 80.04 175.89 79.26 173.56 78.34 171.13 77.28 168.59 76.06 168.59 76.06" clip-path="url(#cpNTkuMDR8NDczLjc2fDMwNC41Nnw1OS4wNA==)" style="stroke-width:.75;stroke:#a9a9a9"/><line x1="169.83" x2="168.59" y1="75.47" y2="76.06" clip-path="url(#cpNTkuMDR8NDczLjc2fDMwNC41Nnw1OS4wNA==)" style="stroke-width:.75;stroke:#a9a9a9"/><polygon points="179.68 65.88 178.98 66.89 178.2 67.95 177.31 69.07 176.26 70.25 174.97 71.56 173.2 73.09 168.56 76 168.62 76.13 173.8 74.33 176.1 73.91 177.93 73.72 179.51 73.65 180.93 73.65 182.25 73.7 183.48 73.8" clip-path="url(#cpNTkuMDR8NDczLjc2fDMwNC41Nnw1OS4wNA==)" style="stroke-width:.75;stroke:#a9a9a9;fill:#a9a9a9"/><g clip-path="url(#cpNTkuMDR8NDczLjc2fDMwNC41Nnw1OS4wNA==)"><text x="192.81" y="80.02" lengthAdjust="spacingAndGlyphs" textLength="15" style="font-size:12px;fill:#00008b;font-family:Times">0.1</text></g><line x1="365.51" x2="166.27" y1="280.91" y2="81.67" clip-path="url(#cpNTkuMDR8NDczLjc2fDMwNC41Nnw1OS4wNA==)" style="stroke-width:.75;stroke:#a9a9a9"/><line x1="167.29" x2="366.53" y1="82.69" y2="281.93" clip-path="url(#cpNTkuMDR8NDczLjc2fDMwNC41Nnw1OS4wNA==)" style="stroke-width:.75;stroke:#a9a9a9"/><polygon points="179.56 88.75 178.37 88.43 177.11 88.04 175.76 87.57 174.3 86.98 172.64 86.19 170.61 85.03 166.32 81.62 166.22 81.72 169.63 86.01 170.79 88.04 171.58 89.7 172.17 91.16 172.64 92.51 173.03 93.77 173.35 94.96" clip-path="url(#cpNTkuMDR8NDczLjc2fDMwNC41Nnw1OS4wNA==)" style="stroke-width:.75;stroke:#a9a9a9;fill:#a9a9a9"/><polygon points="353.24 274.85 354.43 275.17 355.69 275.56 357.04 276.03 358.5 276.62 360.16 277.41 362.19 278.57 366.48 281.98 366.58 281.88 363.17 277.59 362.01 275.56 361.22 273.9 360.63 272.44 360.16 271.09 359.77 269.83 359.45 268.64" clip-path="url(#cpNTkuMDR8NDczLjc2fDMwNC41Nnw1OS4wNA==)" style="stroke-width:.75;stroke:#a9a9a9;fill:#a9a9a9"/><g clip-path="url(#cpNTkuMDR8NDczLjc2fDMwNC41Nnw1OS4wNA==)"><text x="292.28" y="219.17" lengthAdjust="spacingAndGlyphs" textLength="15" style="font-size:12px;fill:#00008b;font-family:Times">0.3</text></g><g clip-path="url(#cpNTkuMDR8NDczLjc2fDMwNC41Nnw1OS4wNA==)"><text x="225.52" y="152.32" lengthAdjust="spacingAndGlyphs" textLength="15" style="font-size:12px;fill:#00008b;font-family:Times">0.9</text></g><circle cx="372.14" cy="287.54" r="7.93" clip-path="url(#cpNTkuMDR8NDczLjc2fDMwNC41Nnw1OS4wNA==)" style="stroke-width:.75;fill:#e69f00"/><circle cx="160.66" cy="76.06" r="7.93" clip-path="url(#cpNTkuMDR8NDczLjc2fDMwNC41Nnw1OS4wNA==)" style="stroke-width:.75;fill:#e69f00"/><defs><clipPath id="cpMC4wMHw1MDQuMDB8Mzc4LjAwfDAuMDA="><rect width="504" height="378" x="0" y="0"/></clipPath></defs><g clip-path="url(#cpMC4wMHw1MDQuMDB8Mzc4LjAwfDAuMDA=)"><text x="369.47" y="290.27" lengthAdjust="spacingAndGlyphs" textLength="5.33" style="font-size:12px;fill:#00008b;font-family:Times">a</text></g><g clip-path="url(#cpMC4wMHw1MDQuMDB8Mzc4LjAwfDAuMDA=)"><text x="157.66" y="80.1" lengthAdjust="spacingAndGlyphs" textLength="6" style="font-size:12px;fill:#00008b;font-family:Times">b</text></g></svg>


--------------------------------------------------------------------------------
/docs/model-demos_files/figure-html/maxLikeillustration-1.svg:
--------------------------------------------------------------------------------
1 | <svg xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" viewBox="0 0 504 378"><defs><style type="text/css">line,polyline,rect{fill:none;stroke:#000;stroke-linecap:round;stroke-linejoin:round;stroke-miterlimit:10}</style></defs><rect width="100%" height="100%" style="stroke:none;fill:none"/><rect width="504" height="378" x="0" y="0" style="stroke-width:1.07;stroke:none"/><defs><clipPath id="cpNTEuNDV8NDk4LjUyfDMzNC42MHw1LjQ4"><rect width="447.07" height="329.12" x="51.45" y="5.48"/></clipPath></defs><line x1="234.34" x2="234.34" y1="334.6" y2="5.48" clip-path="url(#cpNTEuNDV8NDk4LjUyfDMzNC42MHw1LjQ4)" style="stroke-width:1.07;stroke:#000;stroke-opacity:.5;stroke-dasharray:5.69,5.69;stroke-linecap:butt"/><line x1="51.45" x2="498.52" y1="20.44" y2="20.44" clip-path="url(#cpNTEuNDV8NDk4LjUyfDMzNC42MHw1LjQ4)" style="stroke-width:1.07;stroke:#000;stroke-opacity:.5;stroke-dasharray:5.69,5.69;stroke-linecap:butt"/><polyline points="71.77 277.09 75.88 261.84 79.98 247.23 84.09 233.23 88.19 219.82 92.3 206.98 96.41 194.71 100.51 182.97 104.62 171.76 108.72 161.06 112.83 150.85 116.93 141.12 121.04 131.85 125.14 123.04 129.25 114.67 133.35 106.73 137.46 99.2 141.56 92.08 145.67 85.36 149.77 79.03 153.88 73.06 157.98 67.47 162.09 62.23 166.2 57.34 170.3 52.79 174.41 48.58 178.51 44.69 182.62 41.11 186.72 37.84 190.83 34.88 194.93 32.21 199.04 29.83 203.14 27.74 207.25 25.92 211.35 24.37 215.46 23.08 219.56 22.06 223.67 21.28 227.78 20.76 231.88 20.48 235.99 20.44 240.09 20.63 244.2 21.05 248.3 21.7 252.41 22.57 256.51 23.65 260.62 24.94 264.72 26.45 268.83 28.15 272.93 30.06 277.04 32.16 281.14 34.46 285.25 36.94 289.35 39.62 293.46 42.47 297.57 45.51 301.67 48.72 305.78 52.1 309.88 55.66 313.99 59.38 318.09 63.27 322.2 67.31 326.3 71.52 330.41 75.89 334.51 80.41 338.62 85.08 342.72 89.9 346.83 94.87 350.93 99.98 355.04 105.23 359.15 110.63 363.25 116.16 367.36 121.83 371.46 127.63 375.57 133.56 379.67 139.62 383.78 145.82 387.88 152.13 391.99 158.57 396.09 165.14 400.2 171.82 404.3 178.62 408.41 185.54 412.51 192.58 416.62 199.73 420.72 206.99 424.83 214.36 428.94 221.85 433.04 229.44 437.15 237.13 441.25 244.93 445.36 252.84 449.46 260.84 453.57 268.95 457.67 277.16 461.78 285.46 465.88 293.87 469.99 302.36 474.09 310.95 478.2 319.64" clip-path="url(#cpNTEuNDV8NDk4LjUyfDMzNC42MHw1LjQ4)" style="stroke-width:4.27;stroke:#f50;stroke-linecap:butt"/><defs><clipPath id="cpMC4wMHw1MDQuMDB8Mzc4LjAwfDAuMDA="><rect width="504" height="378" x="0" y="0"/></clipPath></defs><polyline points="71.77 337.34 71.77 334.6" clip-path="url(#cpMC4wMHw1MDQuMDB8Mzc4LjAwfDAuMDA=)" style="stroke-width:1.07;stroke:#333;stroke-linecap:butt"/><polyline points="153.06 337.34 153.06 334.6" clip-path="url(#cpMC4wMHw1MDQuMDB8Mzc4LjAwfDAuMDA=)" style="stroke-width:1.07;stroke:#333;stroke-linecap:butt"/><polyline points="234.34 337.34 234.34 334.6" clip-path="url(#cpMC4wMHw1MDQuMDB8Mzc4LjAwfDAuMDA=)" style="stroke-width:1.07;stroke:#333;stroke-linecap:butt"/><polyline points="315.63 337.34 315.63 334.6" clip-path="url(#cpMC4wMHw1MDQuMDB8Mzc4LjAwfDAuMDA=)" style="stroke-width:1.07;stroke:#333;stroke-linecap:butt"/><polyline points="396.91 337.34 396.91 334.6" clip-path="url(#cpMC4wMHw1MDQuMDB8Mzc4LjAwfDAuMDA=)" style="stroke-width:1.07;stroke:#333;stroke-linecap:butt"/><polyline points="478.2 337.34 478.2 334.6" clip-path="url(#cpMC4wMHw1MDQuMDB8Mzc4LjAwfDAuMDA=)" style="stroke-width:1.07;stroke:#333;stroke-linecap:butt"/><g clip-path="url(#cpMC4wMHw1MDQuMDB8Mzc4LjAwfDAuMDA=)"><text x="67.88" y="348.9" lengthAdjust="spacingAndGlyphs" textLength="7.79" style="font-size:14px;fill:#1a1a1a;font-family:Arial">3</text></g><g clip-path="url(#cpMC4wMHw1MDQuMDB8Mzc4LjAwfDAuMDA=)"><text x="149.17" y="348.9" lengthAdjust="spacingAndGlyphs" textLength="7.79" style="font-size:14px;fill:#1a1a1a;font-family:Arial">4</text></g><g clip-path="url(#cpMC4wMHw1MDQuMDB8Mzc4LjAwfDAuMDA=)"><text x="230.45" y="348.9" lengthAdjust="spacingAndGlyphs" textLength="7.79" style="font-size:14px;fill:#1a1a1a;font-family:Arial">5</text></g><g clip-path="url(#cpMC4wMHw1MDQuMDB8Mzc4LjAwfDAuMDA=)"><text x="311.74" y="348.9" lengthAdjust="spacingAndGlyphs" textLength="7.79" style="font-size:14px;fill:#1a1a1a;font-family:Arial">6</text></g><g clip-path="url(#cpMC4wMHw1MDQuMDB8Mzc4LjAwfDAuMDA=)"><text x="393.02" y="348.9" lengthAdjust="spacingAndGlyphs" textLength="7.79" style="font-size:14px;fill:#1a1a1a;font-family:Arial">7</text></g><g clip-path="url(#cpMC4wMHw1MDQuMDB8Mzc4LjAwfDAuMDA=)"><text x="474.31" y="348.9" lengthAdjust="spacingAndGlyphs" textLength="7.79" style="font-size:14px;fill:#1a1a1a;font-family:Arial">8</text></g><g clip-path="url(#cpMC4wMHw1MDQuMDB8Mzc4LjAwfDAuMDA=)"><text x="266.48" y="369.88" lengthAdjust="spacingAndGlyphs" textLength="17.02" style="font-size:24px;fill:#1a1a1a;font-family:PT Serif">θ</text></g><g clip-path="url(#cpMC4wMHw1MDQuMDB8Mzc4LjAwfDAuMDA=)"><text x="5.48" y="173.48" lengthAdjust="spacingAndGlyphs" textLength="43.23" style="font-size:9.6px;fill:#4d4d4d;font-family:Arial">Likelihood</text></g></svg>


--------------------------------------------------------------------------------
/docs/model-demos_files/figure-html/mixmv-vis1-1.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/m-clark/models-by-example/b544c35a3fdd63baecee7f904469c1174862ced3/docs/model-demos_files/figure-html/mixmv-vis1-1.png


--------------------------------------------------------------------------------
/docs/model-demos_files/figure-html/mixmv-vis1-2.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/m-clark/models-by-example/b544c35a3fdd63baecee7f904469c1174862ced3/docs/model-demos_files/figure-html/mixmv-vis1-2.png


--------------------------------------------------------------------------------
/docs/model-demos_files/figure-html/mixmv-vis1-3.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/m-clark/models-by-example/b544c35a3fdd63baecee7f904469c1174862ced3/docs/model-demos_files/figure-html/mixmv-vis1-3.png


--------------------------------------------------------------------------------
/docs/model-demos_files/figure-html/ml-illustration-1.svg:
--------------------------------------------------------------------------------
1 | <svg xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" viewBox="0 0 504 378"><defs><style type="text/css">line,polyline,rect{fill:none;stroke:#000;stroke-linecap:round;stroke-linejoin:round;stroke-miterlimit:10}</style></defs><rect width="100%" height="100%" style="stroke:none;fill:none"/><rect width="504" height="378" x="0" y="0" style="stroke-width:1.07;stroke:none"/><defs><clipPath id="cpNTEuNDV8NDk4LjUyfDMzNC42MHw1LjQ4"><rect width="447.07" height="329.12" x="51.45" y="5.48"/></clipPath></defs><line x1="234.34" x2="234.34" y1="334.6" y2="5.48" clip-path="url(#cpNTEuNDV8NDk4LjUyfDMzNC42MHw1LjQ4)" style="stroke-width:1.07;stroke:#000;stroke-opacity:.5;stroke-dasharray:5.69,5.69;stroke-linecap:butt"/><line x1="51.45" x2="498.52" y1="20.44" y2="20.44" clip-path="url(#cpNTEuNDV8NDk4LjUyfDMzNC42MHw1LjQ4)" style="stroke-width:1.07;stroke:#000;stroke-opacity:.5;stroke-dasharray:5.69,5.69;stroke-linecap:butt"/><polyline points="71.77 277.09 75.88 261.84 79.98 247.23 84.09 233.23 88.19 219.82 92.3 206.98 96.41 194.71 100.51 182.97 104.62 171.76 108.72 161.06 112.83 150.85 116.93 141.12 121.04 131.85 125.14 123.04 129.25 114.67 133.35 106.73 137.46 99.2 141.56 92.08 145.67 85.36 149.77 79.03 153.88 73.06 157.98 67.47 162.09 62.23 166.2 57.34 170.3 52.79 174.41 48.58 178.51 44.69 182.62 41.11 186.72 37.84 190.83 34.88 194.93 32.21 199.04 29.83 203.14 27.74 207.25 25.92 211.35 24.37 215.46 23.08 219.56 22.06 223.67 21.28 227.78 20.76 231.88 20.48 235.99 20.44 240.09 20.63 244.2 21.05 248.3 21.7 252.41 22.57 256.51 23.65 260.62 24.94 264.72 26.45 268.83 28.15 272.93 30.06 277.04 32.16 281.14 34.46 285.25 36.94 289.35 39.62 293.46 42.47 297.57 45.51 301.67 48.72 305.78 52.1 309.88 55.66 313.99 59.38 318.09 63.27 322.2 67.31 326.3 71.52 330.41 75.89 334.51 80.41 338.62 85.08 342.72 89.9 346.83 94.87 350.93 99.98 355.04 105.23 359.15 110.63 363.25 116.16 367.36 121.83 371.46 127.63 375.57 133.56 379.67 139.62 383.78 145.82 387.88 152.13 391.99 158.57 396.09 165.14 400.2 171.82 404.3 178.62 408.41 185.54 412.51 192.58 416.62 199.73 420.72 206.99 424.83 214.36 428.94 221.85 433.04 229.44 437.15 237.13 441.25 244.93 445.36 252.84 449.46 260.84 453.57 268.95 457.67 277.16 461.78 285.46 465.88 293.87 469.99 302.36 474.09 310.95 478.2 319.64" clip-path="url(#cpNTEuNDV8NDk4LjUyfDMzNC42MHw1LjQ4)" style="stroke-width:4.27;stroke:#f50;stroke-linecap:butt"/><defs><clipPath id="cpMC4wMHw1MDQuMDB8Mzc4LjAwfDAuMDA="><rect width="504" height="378" x="0" y="0"/></clipPath></defs><polyline points="71.77 337.34 71.77 334.6" clip-path="url(#cpMC4wMHw1MDQuMDB8Mzc4LjAwfDAuMDA=)" style="stroke-width:1.07;stroke:#333;stroke-linecap:butt"/><polyline points="153.06 337.34 153.06 334.6" clip-path="url(#cpMC4wMHw1MDQuMDB8Mzc4LjAwfDAuMDA=)" style="stroke-width:1.07;stroke:#333;stroke-linecap:butt"/><polyline points="234.34 337.34 234.34 334.6" clip-path="url(#cpMC4wMHw1MDQuMDB8Mzc4LjAwfDAuMDA=)" style="stroke-width:1.07;stroke:#333;stroke-linecap:butt"/><polyline points="315.63 337.34 315.63 334.6" clip-path="url(#cpMC4wMHw1MDQuMDB8Mzc4LjAwfDAuMDA=)" style="stroke-width:1.07;stroke:#333;stroke-linecap:butt"/><polyline points="396.91 337.34 396.91 334.6" clip-path="url(#cpMC4wMHw1MDQuMDB8Mzc4LjAwfDAuMDA=)" style="stroke-width:1.07;stroke:#333;stroke-linecap:butt"/><polyline points="478.2 337.34 478.2 334.6" clip-path="url(#cpMC4wMHw1MDQuMDB8Mzc4LjAwfDAuMDA=)" style="stroke-width:1.07;stroke:#333;stroke-linecap:butt"/><g clip-path="url(#cpMC4wMHw1MDQuMDB8Mzc4LjAwfDAuMDA=)"><text x="67.88" y="348.9" lengthAdjust="spacingAndGlyphs" textLength="7.79" style="font-size:14px;fill:#1a1a1a;font-family:Arial">3</text></g><g clip-path="url(#cpMC4wMHw1MDQuMDB8Mzc4LjAwfDAuMDA=)"><text x="149.17" y="348.9" lengthAdjust="spacingAndGlyphs" textLength="7.79" style="font-size:14px;fill:#1a1a1a;font-family:Arial">4</text></g><g clip-path="url(#cpMC4wMHw1MDQuMDB8Mzc4LjAwfDAuMDA=)"><text x="230.45" y="348.9" lengthAdjust="spacingAndGlyphs" textLength="7.79" style="font-size:14px;fill:#1a1a1a;font-family:Arial">5</text></g><g clip-path="url(#cpMC4wMHw1MDQuMDB8Mzc4LjAwfDAuMDA=)"><text x="311.74" y="348.9" lengthAdjust="spacingAndGlyphs" textLength="7.79" style="font-size:14px;fill:#1a1a1a;font-family:Arial">6</text></g><g clip-path="url(#cpMC4wMHw1MDQuMDB8Mzc4LjAwfDAuMDA=)"><text x="393.02" y="348.9" lengthAdjust="spacingAndGlyphs" textLength="7.79" style="font-size:14px;fill:#1a1a1a;font-family:Arial">7</text></g><g clip-path="url(#cpMC4wMHw1MDQuMDB8Mzc4LjAwfDAuMDA=)"><text x="474.31" y="348.9" lengthAdjust="spacingAndGlyphs" textLength="7.79" style="font-size:14px;fill:#1a1a1a;font-family:Arial">8</text></g><g clip-path="url(#cpMC4wMHw1MDQuMDB8Mzc4LjAwfDAuMDA=)"><text x="266.48" y="369.88" lengthAdjust="spacingAndGlyphs" textLength="17.02" style="font-size:24px;fill:#1a1a1a;font-family:PT Serif">θ</text></g><g clip-path="url(#cpMC4wMHw1MDQuMDB8Mzc4LjAwfDAuMDA=)"><text x="5.48" y="173.48" lengthAdjust="spacingAndGlyphs" textLength="43.23" style="font-size:9.6px;fill:#4d4d4d;font-family:Arial">Likelihood</text></g></svg>


--------------------------------------------------------------------------------
/docs/model-demos_files/figure-html/probit-em-vis-show-1.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/m-clark/models-by-example/b544c35a3fdd63baecee7f904469c1174862ced3/docs/model-demos_files/figure-html/probit-em-vis-show-1.png


--------------------------------------------------------------------------------
/docs/model-demos_files/figure-html/rk-ridge-plot-1.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/m-clark/models-by-example/b544c35a3fdd63baecee7f904469c1174862ced3/docs/model-demos_files/figure-html/rk-ridge-plot-1.png


--------------------------------------------------------------------------------
/docs/model-demos_files/figure-html/rk-spline-comparison-1.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/m-clark/models-by-example/b544c35a3fdd63baecee7f904469c1174862ced3/docs/model-demos_files/figure-html/rk-spline-comparison-1.png


--------------------------------------------------------------------------------
/docs/model-demos_files/figure-html/rk-spline-gcv-plot-1.svg:
--------------------------------------------------------------------------------
1 | <svg xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" viewBox="0 0 504 378"><defs><style type="text/css">polyline,rect{fill:none;stroke:#000;stroke-linecap:round;stroke-linejoin:round;stroke-miterlimit:10}</style></defs><rect width="100%" height="100%" style="stroke:none;fill:none"/><defs><clipPath id="cpNDMuMDJ8NDk4LjUyfDM0Ni4yOHwyMy4yNw=="><rect width="455.5" height="323.01" x="43.02" y="23.27"/></clipPath></defs><polyline points="43.02 296.33 498.52 296.33" clip-path="url(#cpNDMuMDJ8NDk4LjUyfDM0Ni4yOHwyMy4yNw==)" style="stroke-width:.53;stroke:#ebebeb;stroke-linecap:butt"/><polyline points="43.02 200.69 498.52 200.69" clip-path="url(#cpNDMuMDJ8NDk4LjUyfDM0Ni4yOHwyMy4yNw==)" style="stroke-width:.53;stroke:#ebebeb;stroke-linecap:butt"/><polyline points="43.02 105.05 498.52 105.05" clip-path="url(#cpNDMuMDJ8NDk4LjUyfDM0Ni4yOHwyMy4yNw==)" style="stroke-width:.53;stroke:#ebebeb;stroke-linecap:butt"/><polyline points="63.73 346.28 63.73 23.27" clip-path="url(#cpNDMuMDJ8NDk4LjUyfDM0Ni4yOHwyMy4yNw==)" style="stroke-width:.53;stroke:#ebebeb;stroke-linecap:butt"/><polyline points="201.76 346.28 201.76 23.27" clip-path="url(#cpNDMuMDJ8NDk4LjUyfDM0Ni4yOHwyMy4yNw==)" style="stroke-width:.53;stroke:#ebebeb;stroke-linecap:butt"/><polyline points="339.79 346.28 339.79 23.27" clip-path="url(#cpNDMuMDJ8NDk4LjUyfDM0Ni4yOHwyMy4yNw==)" style="stroke-width:.53;stroke:#ebebeb;stroke-linecap:butt"/><polyline points="477.82 346.28 477.82 23.27" clip-path="url(#cpNDMuMDJ8NDk4LjUyfDM0Ni4yOHwyMy4yNw==)" style="stroke-width:.53;stroke:#ebebeb;stroke-linecap:butt"/><polyline points="43.02 344.15 498.52 344.15" clip-path="url(#cpNDMuMDJ8NDk4LjUyfDM0Ni4yOHwyMy4yNw==)" style="stroke-width:1.07;stroke:#ebebeb;stroke-linecap:butt"/><polyline points="43.02 248.51 498.52 248.51" clip-path="url(#cpNDMuMDJ8NDk4LjUyfDM0Ni4yOHwyMy4yNw==)" style="stroke-width:1.07;stroke:#ebebeb;stroke-linecap:butt"/><polyline points="43.02 152.87 498.52 152.87" clip-path="url(#cpNDMuMDJ8NDk4LjUyfDM0Ni4yOHwyMy4yNw==)" style="stroke-width:1.07;stroke:#ebebeb;stroke-linecap:butt"/><polyline points="43.02 57.24 498.52 57.24" clip-path="url(#cpNDMuMDJ8NDk4LjUyfDM0Ni4yOHwyMy4yNw==)" style="stroke-width:1.07;stroke:#ebebeb;stroke-linecap:butt"/><polyline points="132.74 346.28 132.74 23.27" clip-path="url(#cpNDMuMDJ8NDk4LjUyfDM0Ni4yOHwyMy4yNw==)" style="stroke-width:1.07;stroke:#ebebeb;stroke-linecap:butt"/><polyline points="270.77 346.28 270.77 23.27" clip-path="url(#cpNDMuMDJ8NDk4LjUyfDM0Ni4yOHwyMy4yNw==)" style="stroke-width:1.07;stroke:#ebebeb;stroke-linecap:butt"/><polyline points="408.8 346.28 408.8 23.27" clip-path="url(#cpNDMuMDJ8NDk4LjUyfDM0Ni4yOHwyMy4yNw==)" style="stroke-width:1.07;stroke:#ebebeb;stroke-linecap:butt"/><polyline points="63.73 311.16 70.63 311.71 77.53 312.15 84.43 312.99 91.33 314.55 98.23 315.93 105.13 317.51 112.04 318.97 118.94 320.27 125.84 321.65 132.74 322.99 139.64 324.28 146.54 325.49 153.45 326.64 160.35 327.68 167.25 328.65 174.15 329.51 181.05 330.27 187.95 330.89 194.85 331.35 201.76 331.59 208.66 331.57 215.56 331.22 222.46 330.44 229.36 329.14 236.26 327.23 243.16 324.62 250.07 321.22 256.97 316.95 263.87 311.77 270.77 305.64 277.67 298.55 284.57 290.52 291.48 281.62 298.38 271.96 305.28 261.7 312.18 251.04 319.08 240.18 325.98 229.29 332.88 218.51 339.79 207.89 346.69 197.4 353.59 186.97 360.49 176.47 367.39 165.82 374.29 154.98 381.19 143.96 388.1 132.89 395 121.91 401.9 111.23 408.8 101 415.7 91.39 422.6 82.49 429.51 74.35 436.41 66.99 443.31 60.4 450.21 54.57 457.11 49.45 464.01 45.01 470.91 41.19 477.82 37.95" clip-path="url(#cpNDMuMDJ8NDk4LjUyfDM0Ni4yOHwyMy4yNw==)" style="stroke-width:1.07;stroke-linecap:butt"/><defs><clipPath id="cpMC4wMHw1MDQuMDB8Mzc4LjAwfDAuMDA="><rect width="504" height="378" x="0" y="0"/></clipPath></defs><g clip-path="url(#cpMC4wMHw1MDQuMDB8Mzc4LjAwfDAuMDA=)"><text x="23.41" y="347.3" lengthAdjust="spacingAndGlyphs" textLength="14.68" style="font-size:8.8px;fill:#4d4d4d;font-family:Arial">500</text></g><g clip-path="url(#cpMC4wMHw1MDQuMDB8Mzc4LjAwfDAuMDA=)"><text x="18.51" y="251.66" lengthAdjust="spacingAndGlyphs" textLength="19.58" style="font-size:8.8px;fill:#4d4d4d;font-family:Arial">1000</text></g><g clip-path="url(#cpMC4wMHw1MDQuMDB8Mzc4LjAwfDAuMDA=)"><text x="18.51" y="156.02" lengthAdjust="spacingAndGlyphs" textLength="19.58" style="font-size:8.8px;fill:#4d4d4d;font-family:Arial">1500</text></g><g clip-path="url(#cpMC4wMHw1MDQuMDB8Mzc4LjAwfDAuMDA=)"><text x="18.51" y="60.39" lengthAdjust="spacingAndGlyphs" textLength="19.58" style="font-size:8.8px;fill:#4d4d4d;font-family:Arial">2000</text></g><g clip-path="url(#cpMC4wMHw1MDQuMDB8Mzc4LjAwfDAuMDA=)"><text x="121.49" y="357.51" lengthAdjust="spacingAndGlyphs" textLength="22.51" style="font-size:8.8px;fill:#4d4d4d;font-family:Arial">1e-05</text></g><g clip-path="url(#cpMC4wMHw1MDQuMDB8Mzc4LjAwfDAuMDA=)"><text x="259.52" y="357.51" lengthAdjust="spacingAndGlyphs" textLength="22.51" style="font-size:8.8px;fill:#4d4d4d;font-family:Arial">1e-03</text></g><g clip-path="url(#cpMC4wMHw1MDQuMDB8Mzc4LjAwfDAuMDA=)"><text x="397.55" y="357.51" lengthAdjust="spacingAndGlyphs" textLength="22.51" style="font-size:8.8px;fill:#4d4d4d;font-family:Arial">1e-01</text></g><g clip-path="url(#cpMC4wMHw1MDQuMDB8Mzc4LjAwfDAuMDA=)"><text x="252.73" y="370.1" lengthAdjust="spacingAndGlyphs" textLength="36.08" style="font-size:11px;font-family:Arial">lambda</text></g><g clip-path="url(#cpMC4wMHw1MDQuMDB8Mzc4LjAwfDAuMDA=)"><text style="font-size:11px;font-family:Arial" lengthAdjust="spacingAndGlyphs" textLength="23.84" transform="translate(13.35,196.69) rotate(-90)">GCV</text></g><g clip-path="url(#cpMC4wMHw1MDQuMDB8Mzc4LjAwfDAuMDA=)"><text x="43.02" y="14.93" lengthAdjust="spacingAndGlyphs" textLength="64.55" style="font-size:13.2px;font-family:Arial">GCV score</text></g></svg>


--------------------------------------------------------------------------------
/docs/reference-keys.txt:
--------------------------------------------------------------------------------
1 | tab:hmc-est-show
2 | tab:hmc-compare-stan
3 | 


--------------------------------------------------------------------------------
/elm.Rmd:
--------------------------------------------------------------------------------
  1 | # Extreme Learning Machine
  2 | 
  3 | A very simple implementation of an extreme learning machine for regression, which can be seen as a quick way to estimate a 'good enough' neural net, one that can be nearly as performant but with a lot less computational overhead. See <span class="pack" style = "">elmNN</span> and <span class="pack" style = "">ELMR</span> for some R package implementations. I add comparison to generalized additive models (elm/neural networks and GAMs are adaptive basis function models). 
  4 | 
  5 | 
  6 | - http://www.extreme-learning-machines.org
  7 | - G.B. Huang, Q.Y. Zhu and C.K. Siew, Extreme Learning Machine: Theory and Applications.
  8 | 
  9 | 
 10 | ## Data Setup
 11 | 
 12 | 
 13 | One variable, complex function.
 14 | 
 15 | ```{r elm-setup1}
 16 | library(tidyverse)
 17 | library(mgcv)
 18 | 
 19 | set.seed(123)
 20 | 
 21 | n = 5000
 22 | x = runif(n)
 23 | # x = rnorm(n)
 24 | mu = sin(2*(4*x-2)) + 2* exp(-(16^2) * ((x-.5)^2))
 25 | y  = rnorm(n, mu, .3)
 26 | 
 27 | d = data.frame(x, y) 
 28 | 
 29 | qplot(x, y, color = I('#ff55001A'))
 30 | ```
 31 | 
 32 | 
 33 | Motorcycle accident data.
 34 | 
 35 | ```{r elm-setup2}
 36 | data('mcycle', package = 'MASS')
 37 | 
 38 | times = matrix(mcycle$times, ncol = 1)
 39 | accel = mcycle$accel
 40 | ```
 41 | 
 42 | 
 43 | 
 44 | ## Function
 45 | 
 46 | ```{r elm-func}
 47 | elm <- function(X, y, n_hidden = NULL, active_fun = tanh) {
 48 |   # X: an N observations x p features matrix
 49 |   # y: the target
 50 |   # n_hidden: the number of hidden nodes
 51 |   # active_fun: activation function
 52 |   
 53 |   pp1 = ncol(X) + 1
 54 |   w0  = matrix(rnorm(pp1*n_hidden), pp1, n_hidden)       # random weights
 55 |   h   = active_fun(cbind(1, scale(X)) %*% w0)            # compute hidden layer
 56 |   B   = MASS::ginv(h) %*% y                              # find weights for hidden layer
 57 |   
 58 |   fit = h %*% B                                          # fitted values
 59 |   
 60 |   list(
 61 |     fit  = fit,
 62 |     loss = crossprod(y - fit),
 63 |     B    = B,
 64 |     w0   = w0
 65 |   )
 66 | }
 67 | ```
 68 | 
 69 | 
 70 | 
 71 | 
 72 | ## Estimation
 73 | 
 74 | ```{r elm-est1}
 75 | X_mat = as.matrix(x, ncol = 1)
 76 | 
 77 | fit_elm = elm(X_mat, y, n_hidden = 100)
 78 | str(fit_elm)
 79 | 
 80 | ggplot(aes(x, y), data = d) +
 81 |   geom_point(color = '#ff55001A') + 
 82 |   geom_line(aes(y = fit_elm$fit), color = '#00aaff')
 83 | 
 84 | cor(fit_elm$fit[,1], y)^2
 85 | ```
 86 | 
 87 | 
 88 | ```{r  elm-est2}
 89 | fit_elm_mcycle = elm(times, accel, n_hidden = 100)
 90 | cor(fit_elm_mcycle$fit[,1], accel)^2
 91 | ```
 92 | 
 93 | 
 94 | 
 95 | 
 96 | ## Comparison
 97 | 
 98 | We'll compare to a generalized additive model with gaussian process approximation.
 99 | 
100 | ```{r elm-compare1}
101 | fit_gam = gam(y ~ s(x, bs = 'gp', k = 20), data = d)
102 | summary(fit_gam)$r.sq
103 | 
104 | 
105 | d %>%
106 |   mutate(fit_elm = fit_elm$fit,
107 |          fit_gam = fitted(fit_gam)) %>%
108 |   ggplot() +
109 |   geom_point(aes(x, y), color = '#ff55001A') +
110 |   geom_line(aes(x, y = fit_elm), color = '#1e90ff') +
111 |   geom_line(aes(x, y = fit_gam), color = '#990024')
112 | ```
113 | 
114 | 
115 | ```{r elm-compare2}
116 | fit_gam_mcycle = gam(accel ~ s(times), data = mcycle)
117 | summary(fit_gam_mcycle)$r.sq
118 | 
119 | mcycle %>% 
120 |   ggplot(aes(times, accel)) +
121 |   geom_point(color = '#ff55001A') +
122 |   geom_line(aes(y = fit_elm_mcycle$fit), color = '#1e90ff') +
123 |   geom_line(aes(y = fitted(fit_gam_mcycle)), color = '#990024')
124 | ```
125 | 
126 | 
127 | 
128 | ## Supplemental Example
129 | 
130 | Yet another example with additional covariates.
131 | 
132 | ```{r elm-setup-3}
133 | d = gamSim(eg = 7, n = 10000)
134 | X = as.matrix(d[, 2:5])
135 | y = d[, 1]
136 | 
137 | n_nodes = c(10, 25, 100, 250, 500, 1000)
138 | ```
139 | 
140 | The following estimation over multiple models will take several seconds.
141 | 
142 | ```{r elm-est3}
143 | fit_elm = purrr::map(n_nodes, function(n) elm(X, y, n_hidden = n))
144 | ```
145 | 
146 | Now find the best fitting model.
147 | 
148 | ```{r elm-best}
149 | # estimate 
150 | best_loss = which.min(map_dbl(fit_elm, function(x) x$loss))
151 | fit_best  = fit_elm[[best_loss]]
152 | ```
153 | 
154 | A quick check of the fit.
155 | 
156 | ```{r elm-fit}
157 | # str(fit_best)
158 | # qplot(fit_best$fit[, 1], y, alpha = .2)
159 | cor(fit_best$fit[, 1], y)^2
160 | ```
161 | 
162 | 
163 | And compare again to <span class="pack" style = "">mgcv</span>.  In this case, we're comparing fit on test data of the same form.
164 | 
165 | ```{r elm-compare3}
166 | fit_gam = gam(y ~ s(x0) + s(x1) + s(x2) + s(x3), data = d)
167 | gam.check(fit_gam)
168 | summary(fit_gam)$r.sq
169 | 
170 | 
171 | test_data0 = gamSim(eg = 7)  # default n = 400
172 | test_data  = cbind(1, scale(test_data0[, 2:5]))
173 | 
174 |  # remember to use your specific activation function here
175 | elm_prediction = tanh(test_data %*% fit_best$w0) %*% fit_best$B         
176 | gam_prediction = predict(fit_gam, newdata = test_data0)
177 | 
178 | cor(data.frame(elm_prediction, gam_prediction), test_data0$y)^2
179 | ```
180 | 
181 | 
182 | 
183 | ## Source
184 | 
185 | Original code available at:
186 | https://github.com/m-clark/Miscellaneous-R-Code/blob/master/ModelFitting/elm.R
187 | 


--------------------------------------------------------------------------------
/em-pca.Rmd:
--------------------------------------------------------------------------------
  1 | ## PCA
  2 | 
  3 | 
  4 | The following is an EM algorithm for principal components analysis. See Murphy,
  5 | 2012 Probabilistic Machine Learning 12.2.5. Some of the constructed object is
  6 | based on output from <span class="func" style = "">pca</span> function used below. 
  7 | 
  8 | ### Data Setup
  9 | 
 10 | The `state.x77` is from base R, which includes various state demographics.  We
 11 | will first standardize the data.
 12 | 
 13 | ```{r em-pca-setup}
 14 | library(tidyverse)
 15 | 
 16 | X = scale(state.x77)
 17 | ```
 18 | 
 19 | 
 20 | ###  Function
 21 | 
 22 | The estimating function.  Note that it uses <span class="func" style =
 23 | "">orth</span> from <span class="pack" style = "">pracma</span>, but I show the
 24 | core of the underlying code if you don't want to install it.
 25 | 
 26 | ```{r em-pca-func}
 27 | # orth <- function(M) {
 28 | #   svdM = svd(M)
 29 | #   U    = svdM$u
 30 | #   s    = svdM$d
 31 | #   tol  = max(dim(M)) * max(s) * .Machine$double.eps
 32 | #   r    = sum(s > tol)
 33 | #   
 34 | #   U[, 1:r, drop = FALSE]
 35 | # }
 36 | 
 37 | em_pca <- function(
 38 |   X,
 39 |   n_comp   = 2,
 40 |   tol     = .00001,
 41 |   maxits  = 100,
 42 |   showits = TRUE
 43 |   ) {
 44 |   
 45 |   # Arguments 
 46 |   # X: numeric data
 47 |   # n_comp: number of components
 48 |   # tol = tolerance level
 49 |   # maxits: maximum iterations
 50 |   # showits: show iterations
 51 |   
 52 |   
 53 |   # starting points and other initializations
 54 |   N  = nrow(X)
 55 |   D  = ncol(X)
 56 |   L  = n_comp
 57 |   Xt = t(X)
 58 |   Z  = t(replicate(L, rnorm(N)))                 # latent variables
 59 |   W  = replicate(L, rnorm(D))                    # loadings
 60 |   it = 0
 61 |   converged = FALSE
 62 |     
 63 |   if (showits)                                                     
 64 |     cat(paste("Iterations of EM:", "\n"))
 65 |   
 66 |   # while no convergence and we haven't reached our max iterations do this stuff
 67 |   while ((!converged) & (it < maxits)) {                           
 68 |     Z_old = Z                                    # create 'old' values for comparison
 69 |     Z = solve(t(W)%*%W) %*% crossprod(W, Xt)     # E
 70 |     W = Xt%*%t(Z) %*% solve(tcrossprod(Z))       # M
 71 | 
 72 |     it = it + 1
 73 |     
 74 |     # if showits, show first and every 5th iteration
 75 |     if (showits & (it == 1 | it%%5 == 0))           
 76 |       cat(paste(format(it), "...", "\n", sep = ""))
 77 |     
 78 |     converged = max(abs(Z_old-Z)) <= tol
 79 |   }
 80 |   
 81 |   # calculate reconstruction error
 82 |   Xrecon_em = W %*% Z
 83 |   reconerr  = sum((Xrecon_em - t(X))^2)
 84 |   
 85 |   # orthogonalize
 86 |   W     = pracma::orth(W)     # for orthonormal basis of W; pcaMethods package has also
 87 |   evs   = eigen(cov(X %*% W))
 88 |   evals = evs$values
 89 |   evecs = evs$vectors
 90 |   
 91 |   W = W %*% evecs
 92 |   Z = X %*% W
 93 | 
 94 |   if (showits)                                     # Show last iteration
 95 |     cat(paste0(format(it), "...", "\n"))
 96 |   
 97 |   list(
 98 |     scores    = Z,
 99 |     loadings  = W,
100 |     reconerr  = reconerr,
101 |     Xrecon_em = t(Xrecon_em)
102 |   )
103 | }
104 | ```
105 | 
106 | 
107 | 
108 | 
109 | 
110 | 
111 | ### Estimation
112 | 
113 | ```{r em-pca-est}
114 | fit_em = em_pca(
115 |   X = X,
116 |   n_comp = 2,
117 |   tol    = 1e-12,
118 |   maxit  = 1000
119 | )
120 | 
121 | str(fit_em)  # examine results
122 | ```
123 | 
124 | ### Comparison
125 | 
126 | Extract reconstructed values and loadings for comparison.
127 | 
128 | ```{r em-pca-extract}
129 | Xrecon_em   = fit_em$Xrecon_em
130 | loadings_em = fit_em$loadings
131 | scores_em   = fit_em$scores
132 | ```
133 | 
134 | Compare results to output from <span class="pack" style = "">pcaMethods</span>, which also has probabilistic PCA (demonstrated next). Note that the signs for loadings/scores may be different in sign, but otherwise should be comparable.
135 | 
136 | ```{r em-pca-compare}
137 | library(pcaMethods)  # install via BiocManager::install("pcaMethods")
138 | 
139 | fit_pcam = pca(
140 |   X,
141 |   nPcs = 2,
142 |   method = 'svd',
143 |   scale  = 'none',
144 |   center = FALSE
145 | )
146 | 
147 | loadings_pcam = loadings(fit_pcam)
148 | scores_pcam   = scores(fit_pcam)
149 | ```
150 | 
151 | 
152 | Compare loadings and scores.
153 | 
154 | ```{r em-pca-compare-loadings}
155 | sum((abs(loadings_pcam) - abs(loadings_em))^2)
156 | 
157 | cbind(scores_pcam, data.frame(EM = scores_em)) %>% 
158 |   head()
159 | ```
160 | 
161 | 
162 | Calculate mean squared reconstruction error and compare.
163 | 
164 | ```{r em-pca-compare-recon}
165 | Xrecon_pcam = scores_pcam %*% t(loadings_pcam)
166 | 
167 | mean((Xrecon_em - X)^2)
168 | mean((Xrecon_pcam - X)^2)
169 | 
170 | mean(abs(Xrecon_pcam - Xrecon_em))
171 | ```
172 | 
173 | 
174 | 
175 | ### Visualize
176 | 
177 | ```{r em-pca-vis}
178 | # qplot(Xrecon_pcam[,1], X[,1])
179 | # qplot(Xrecon_pcam[,2], X[,2])
180 | qplot(Xrecon_em[,1], Xrecon_pcam[,1])
181 | ```
182 | 
183 | 
184 | ### Source
185 | 
186 | Original code available at
187 | https://github.com/m-clark/Miscellaneous-R-Code/blob/master/ModelFitting/EM%20Examples/EM%20for%20pca.R
188 | 


--------------------------------------------------------------------------------
/em-probit.Rmd:
--------------------------------------------------------------------------------
  1 | ## Probit Model
  2 | 
  3 | 
  4 | The following regards models for a binary response. See Murphy, 2012 Probabilistic Machine Learning Chapter 11.4.                                     
  5 | 
  6 | 
  7 | ### Data Setup
  8 | 
  9 | ```{r probit-setup}
 10 | library(tidyverse)
 11 | 
 12 | admission = haven::read_dta("https://stats.idre.ucla.edu/stat/stata/dae/binary.dta")
 13 | ```
 14 | 
 15 | ### Probit via Maximum Likelihood
 16 | 
 17 | #### Function
 18 | 
 19 | We'll start with the a basic maximum likelihood function for a standard probit.  See the [logistic regression][Logistic Regression] and [previous chapter on probit models][Probit & Bivariate Probit] for comparison.
 20 | 
 21 | ```{r probit-mle}
 22 | probit_mle <- function(params, X, y){
 23 |   # Arguments are starting parameters (coefficients), model matrix, response 
 24 |   
 25 |   b = params
 26 |   mu = X %*% b    # linear predictor
 27 |   
 28 |   # compute the log likelihood either way
 29 |   # ll = sum(y * pnorm(mu, log.p = TRUE) + (1 - y) * pnorm(-mu, log.p = TRUE))  
 30 |   ll = sum(dbinom(y, 1, prob = pnorm(mu), log = TRUE))
 31 |   
 32 |   -ll
 33 | }
 34 | ```
 35 | 
 36 | 
 37 | #### Estimation
 38 | 
 39 | Estimate with <span class="func" style = "">optim</span>.
 40 | 
 41 | ```{r probit-mle-est}
 42 | # input data
 43 | X = as.matrix(cbind(1, admission[, 2:4]))
 44 | y = as.matrix(admission[, 1])
 45 | init = c(0, 0, 0, 0)
 46 | 
 47 | # Can set tolerance really low to duplicate glm result
 48 | fit_mle = optim(
 49 |   par = init,
 50 |   fn  = probit_mle,
 51 |   X   = X,
 52 |   y   = y,
 53 |   control = list(maxit = 1000, reltol = 1e-12)
 54 | ) 
 55 | 
 56 | # extract coefficients
 57 | coefs_mle = fit_mle$par
 58 | ```
 59 | 
 60 | 
 61 | #### Comparison
 62 | 
 63 | Compare to <span class="func" style = "">glm</span>.
 64 | 
 65 | ```{r probit-glm}
 66 | fit_glm = glm(
 67 |   admit ~ gre + gpa + rank,
 68 |   family  = binomial(link = "probit"),
 69 |   control = list(maxit = 500, epsilon = 1e-8),
 70 |   data    = admission
 71 | )
 72 | 
 73 | 
 74 | summary(fit_glm)
 75 | 
 76 | coefs_glm = coef(fit_glm)
 77 | ```
 78 | 
 79 | Compare.
 80 | 
 81 | ```{r probit-compare-mle-glm, echo=FALSE}
 82 | rbind(coefs_mle, coefs_glm) %>% 
 83 |   kable_df()
 84 | ```
 85 | 
 86 | 
 87 | 
 88 | ### EM for Latent Variable Approach to Probit
 89 | 
 90 | Now for the EM approach, which assumes an continuous latent variable underlying the binary target.
 91 | 
 92 | #### Function
 93 | 
 94 | ```{r probit-em}
 95 | em_probit <- function(
 96 |   params,
 97 |   X,
 98 |   y,
 99 |   tol = .00001,
100 |   maxits  = 100,
101 |   showits = TRUE
102 | ) {
103 |   
104 |   # Arguments 
105 |   # params: starting parameters (coefficients)
106 |   # X: model matrix
107 |   # y: response 
108 |   # tol: tolerance, 
109 |   # maxits: maximum iterations
110 |   # showits: whether to show iterations
111 | 
112 |   #starting points
113 |   b  = params
114 |   mu = X%*%b
115 |   it = 0
116 |   converged = FALSE
117 |   z = rnorm(length(y))    # z is the latent variable ~N(0,1)
118 |   
119 |   # Show iterations
120 |   if (showits)                                                            
121 |     cat(paste("Iterations of EM:", "\n"))
122 |   
123 |   # while no convergence and we haven't reached our max iterations do this stuff
124 |   while ((!converged) & (it < maxits)) {                                 
125 |     z_old = z       # create 'old' values for comparison
126 |     
127 |     # E step create a new z based on current values
128 |     z = ifelse(
129 |       y == 1, 
130 |       mu + dnorm(mu) / pnorm(mu), 
131 |       mu - dnorm(mu) / pnorm(-mu)
132 |     )     
133 |     
134 |     # M step estimate b
135 |     b  = solve(t(X)%*%X) %*% t(X)%*%z                                     
136 |     mu = X%*%b
137 |     
138 |     ll = sum(y * pnorm(mu, log.p = TRUE) + (1 - y) * pnorm(-mu, log.p = TRUE))
139 |     
140 |     it = it + 1
141 |     
142 |     if (showits & (it == 1 | it%%5 == 0))
143 |       cat(paste(format(it), "...", "\n", sep = ""))
144 |     
145 |     converged = max(abs(z_old - z)) <= tol
146 |   }
147 |   
148 |   # Show last iteration
149 |   if (showits)                                                            
150 |     cat(paste0(format(it), "...", "\n"))
151 |   
152 |   list(b = t(b), ll = ll)
153 | }
154 | ```
155 | 
156 | 
157 | #### Estimation
158 | 
159 | Use the same setup and starting values to estimate the parameters.
160 | 
161 | ```{r probit-em-est}
162 | # can lower tolerance to duplicate glm result
163 | fit_em = em_probit(
164 |   params = init,
165 |   X      = X,
166 |   y      = y,
167 |   tol    = 1e-12,
168 |   maxit  = 100
169 | )
170 | 
171 | # fit_em  
172 | 
173 | coefs_em = fit_em$b
174 | ```
175 | 
176 | 
177 | #### Comparison
178 | 
179 | Compare all results.
180 | 
181 | ```{r probit-compare-all, echo=FALSE}
182 | rownames(coefs_em) = 'coefs_em'
183 | rbind(coef(fit_glm), fit_mle$par, fit_em$b) %>% 
184 |   cbind(logLik = c(logLik(fit_glm), fit_mle$value, fit_em$ll)) %>% 
185 |   as_tibble() %>% 
186 |   mutate(fit = c('glm', 'mle', 'em')) %>% 
187 |   select(fit, everything()) %>% 
188 |   kable_df()
189 | ```
190 | 
191 | 
192 | 
193 | 
194 | #### Visualize
195 | 
196 | Show estimates over niter iterations and visualize.
197 | 
198 | ```{r probit-em-vis}
199 | X2 = X
200 | X2[, 2:3] = scale(X2[, 2:3])
201 | 
202 | niter = 20
203 | 
204 | fit_em = map_df(1:niter, function(x)
205 |   as_tibble(
206 |     em_probit(
207 |       params  = init,
208 |       X       = X2,
209 |       y       = y,
210 |       tol     = 1e-8,
211 |       maxit   = x,
212 |       showits = F
213 |     )$b)
214 | )
215 | 
216 | gdat = fit_em %>% 
217 |   rowid_to_column('iter') %>% 
218 |   pivot_longer(-iter, names_to = 'coef') %>% 
219 |   mutate(
220 |     coef = factor(coef, labels = c('Intercept', 'gre', 'gpa', 'rank'))
221 |   ) %>% 
222 |   arrange(iter, coef)
223 | ```
224 | 
225 | ```{r probit-em-vis-show, echo=FALSE}
226 | ggplot(aes(x = iter, y = value), data = gdat) +
227 |   geom_line(aes(group = coef, color = coef)) +
228 |   scico::scale_color_scico_d()
229 | ```
230 | 
231 | 
232 | 
233 | ### Source
234 | 
235 | Original code available at
236 | https://github.com/m-clark/Miscellaneous-R-Code/blob/master/ModelFitting/EM%20Examples/EM%20algorithm%20for%20probit%20example.R
237 | 


--------------------------------------------------------------------------------
/em-ssm.Rmd:
--------------------------------------------------------------------------------
  1 | ## State Space Model
  2 | 
  3 | The following regards chapter 11 in Statistical Modeling and Computation, the
  4 | first example for an unobserved components model.  The data regards  inflation
  5 | based on the U.S. consumer price index ($\textrm{infl} = 400*log(cpi_t/cpi_{t-1})$), from
  6 | the second quarter of 1947 to the second  quarter of 2011.  You can acquire the
  7 | data [here](http://www.maths.uq.edu.au/~kroese/statbook/Statespace/USCPI.csv) or
  8 | in [Datasets repo](https://github.com/m-clark/Datasets). Just note that it has 2
  9 | mystery columns and one mystery row presumably supplied by Excel.  You can also
 10 | get the CPI data yourself at the [Bureau of Labor
 11 | Statistics](http://www.bls.gov/cpi/) in a frustrating fashion, or in a much
 12 | easier fashion [here](https://fred.stlouisfed.org/series/CPIAUCSL).
 13 | 
 14 | 
 15 | For the following I use `n` instead of `t` or `T` because those are transpose and `TRUE`
 16 | in R. The model is basically y = τ + ϵ, with ϵ ~ N(0, σ^2^), and τ = τ<sub>n-1<sub> +
 17 | υ_n with υ ~ N(0, ω^2^).  Thus each y is associated with a latent variable that
 18 | follows a random walk over time. ω^2^ serves as a smoothing parameter, which
 19 | itself may be estimated but which is fixed in the following. See the text for
 20 | more details.
 21 | 
 22 | 
 23 | ### Data Setup
 24 | 
 25 | ```{r em-ssm-setup}
 26 | library(tidyverse)
 27 | 
 28 | d = read_csv(
 29 |   'https://raw.githubusercontent.com/m-clark/Datasets/master/us%20cpi/USCPI.csv',
 30 |   col_names = FALSE
 31 | )
 32 | 
 33 | inflation = as.matrix(d$X1)
 34 | 
 35 | summary(inflation)
 36 | ```
 37 | 
 38 | 
 39 | 
 40 | ### Function
 41 | 
 42 | EM function for a state space model.
 43 | 
 44 | ```{r em-ssm}
 45 | em_state_space <- function(
 46 |   params,
 47 |   y,
 48 |   omega2_0,
 49 |   omega2,
 50 |   tol     = .00001,
 51 |   maxits  = 100,
 52 |   showits = FALSE
 53 | ) {
 54 |   
 55 |   # Arguments 
 56 |   # params: starting parameters (variance as 'sigma2'), 
 57 |   # y: data, 
 58 |   # tol: tolerance,
 59 |   # omega2: latent variance (2_0) is a noisier starting variance
 60 |   # maxits: maximum iterations
 61 |   # showits: whether to show iterations
 62 |   
 63 |   # Not really needed here, but would be a good idea generally to take advantage
 64 |   # of sparse representation for large data
 65 |   # require(spam)  # see usage below
 66 |   
 67 |   # Starting points
 68 |   n = length(y)
 69 |   sigma2 = params$sigma2
 70 |   
 71 |   # Other initializations
 72 |   H = diag(n)
 73 |   
 74 |   for (i in 1:(ncol(H) - 1)) {
 75 |     H[i + 1, i] = -1
 76 |   }
 77 |   
 78 |   Omega2 = spam::as.spam(diag(omega2, n))
 79 |   Omega2[1, 1] = omega2_0
 80 |   
 81 |   H = spam::as.spam(H)
 82 |   HinvOmega2H = t(H) %*% spam::chol2inv(spam::chol(Omega2)) %*% H   # tau ~ N(0, HinvOmmega2H^-1)
 83 |   
 84 |   it = 0
 85 |   converged = FALSE
 86 |   
 87 |   if (showits)                                    # Show iterations
 88 |     cat(paste("Iterations of EM:", "\n"))
 89 | 
 90 |   while ((!converged) & (it < maxits)) { 
 91 |     sigma2Old    = sigma2[1]
 92 |     Sigma2invOld = diag(n)/sigma2Old
 93 | 
 94 |     K   = HinvOmega2H + Sigma2invOld              # E
 95 |     tau = solve(K, y/sigma2Old)                   # tau|y, sigma2_{n-1}, omega2 ~ N(0, K^-1)
 96 |     K_inv_tr = sum(1/eigen(K)$values)
 97 |     
 98 |     sigma2 = 1/n * (K_inv_tr + crossprod(y-tau))  # M
 99 |     
100 |     converged = max(abs(sigma2 - sigma2Old)) <= tol
101 |     
102 |     it = it + 1
103 |     
104 |     # if showits true, & it =1 or divisible by 5 print message
105 |     if (showits & it == 1 | it%%5 == 0)        
106 |       cat(paste(format(it), "...", "\n", sep = ""))
107 |   }
108 |   
109 |   Kfinal   = HinvOmega2H + diag(n) / sigma2[1]
110 |   taufinal = solve(K, (y / sigma2[1]))
111 |   
112 |   list(sigma2 = sigma2, tau = taufinal)
113 | }
114 | ```
115 | 
116 | 
117 | 
118 | 
119 | ### Estimation
120 | 
121 | ```{r em-ssm-est}
122 | ss_mod_1 = em_state_space(
123 |   params = data.frame(sigma2 = var(inflation)),
124 |   y      = inflation,
125 |   tol    = 1e-10,
126 |   omega2_0 = 9,
127 |   omega2   = 1^2
128 | )
129 | 
130 | ss_mod_.5 = em_state_space(
131 |   params = data.frame(sigma2 = var(inflation)),
132 |   y      = inflation,
133 |   tol    = 1e-10,
134 |   omega2_0 = 9,
135 |   omega2   = .5^2
136 | )
137 | 
138 | # more smooth
139 | ss_mod_.1 = em_state_space(
140 |   params = data.frame(sigma2 = var(inflation)),
141 |   y      = inflation,
142 |   tol    = 1e-10,
143 |   omega2_0 = 9,
144 |   omega2   = .1^2
145 | )
146 | 
147 | ss_mod_1$sigma2
148 | ss_mod_.5$sigma2
149 | ss_mod_.1$sigma2
150 | ```
151 | 
152 | 
153 | 
154 | 
155 | ### Visualization
156 | 
157 | ```{r em-ssm-vis-setup}
158 | library(lubridate)
159 | 
160 | series = ymd(
161 |   paste0(
162 |     rep(1947:2014, e = 4), 
163 |     '-', 
164 |     c('01', '04', '07', '10'), 
165 |     '-', 
166 |     '01')
167 |   )
168 | ```
169 | 
170 | 
171 | 
172 | The following corresponds to Fig. 11.1 in the text.  We'll also compare to generalized additive model via <span class="func" style = "">geom_smooth</span> (greenish line).  We can see the .1 model (light blue) is overly smooth.
173 | 
174 | ```{r em-ssm-vis}
175 | library(tidyverse)
176 | 
177 | data.frame(
178 |   series = series[1:length(inflation)],
179 |   inflation = inflation,
180 |   Mod_1  = ss_mod_1$tau,
181 |   Mod_.5 = ss_mod_.5$tau,
182 |   Mod_.1 = ss_mod_.1$tau
183 | ) %>% 
184 |   ggplot(aes(x = series, y = inflation)) +
185 |   geom_point(color = 'gray50', alpha = .25) +
186 |   geom_line(aes(y = Mod_1),  color = '#ff5500') +
187 |   geom_line(aes(y = Mod_.5), color = '#9E1B34') +
188 |   geom_line(aes(y = Mod_.1), color = '#00aaff') +
189 |   geom_smooth(
190 |     formula = y ~ s(x, bs = 'gp', k = 50),
191 |     se = FALSE,
192 |     color = '#1b9e86',
193 |     method = 'gam',
194 |     size = .5
195 |   ) +
196 |   scale_x_date(date_breaks = '10 years') +
197 |   labs(x = '')
198 | ```
199 | 
200 | 
201 | ### Source
202 | 
203 | Original code found at
204 | https://github.com/m-clark/Miscellaneous-R-Code/blob/master/ModelFitting/EM%20Examples/EM%20for%20state%20space%20unobserved%20components.R
205 | 


--------------------------------------------------------------------------------
/em.Rmd:
--------------------------------------------------------------------------------
 1 | # Expectation-Maximization
 2 | 
 3 | ```{r child='em-mixture.Rmd'}
 4 | ```
 5 | 
 6 | ```{r child='em-mixture-MV.Rmd'}
 7 | ```
 8 | 
 9 | ```{r child='em-probit.Rmd'}
10 | ```
11 | 
12 | ```{r child='em-pca.Rmd'}
13 | ```
14 | 
15 | ```{r child='em-ppca.Rmd'}
16 | ```
17 | 
18 | ```{r child='em-ssm.Rmd'}
19 | ```
20 | 
21 | 


--------------------------------------------------------------------------------
/gradient-descent.Rmd:
--------------------------------------------------------------------------------
  1 | # Gradient Descent
  2 | 
  3 | 
  4 | The following demonstration regards Gradient descent for a standard linear regression model.  
  5 | 
  6 | 
  7 | ## Data Setup
  8 | 
  9 | Create some basic data for standard regression.
 10 | 
 11 | ```{r gd-setup}
 12 | library(tidyverse)
 13 | 
 14 | set.seed(8675309)
 15 | 
 16 | n  = 1000
 17 | x1 = rnorm(n)
 18 | x2 = rnorm(n)
 19 | y  = 1 + .5*x1 + .2*x2 + rnorm(n)
 20 | X  = cbind(Intercept = 1, x1, x2)  # model matrix
 21 | ```
 22 | 
 23 | 
 24 | 
 25 | ## Function
 26 | 
 27 | (Batch) Gradient Descent Algorithm.  The function takes arguments starting
 28 | points for the parameters to be estimated, a tolerance or maximum iteration
 29 | value to provide a stopping point, stepsize (or starting stepsize for adaptive
 30 | approach), whether to print out iterations, and whether to plot the loss over
 31 | each iteration.
 32 | 
 33 | ```{r gd}
 34 | gd <- function(
 35 |   par,
 36 |   X,
 37 |   y,
 38 |   tolerance = 1e-3,
 39 |   maxit     = 1000,
 40 |   stepsize  = 1e-3,
 41 |   adapt     = FALSE,
 42 |   verbose   = TRUE,
 43 |   plotLoss  = TRUE
 44 |   ) {
 45 |   
 46 |   # initialize
 47 |   beta = par; names(beta) = colnames(X)
 48 |   loss = crossprod(X %*% beta - y)
 49 |   tol  = 1
 50 |   iter = 1
 51 |   
 52 |   while(tol > tolerance && iter < maxit){
 53 |     
 54 |     LP   = X %*% beta
 55 |     grad = t(X) %*% (LP - y)
 56 |     betaCurrent = beta - stepsize * grad
 57 |     tol  = max(abs(betaCurrent - beta))
 58 |     beta = betaCurrent
 59 |     loss = append(loss, crossprod(LP - y))
 60 |     iter = iter + 1
 61 |     
 62 |     if (adapt)
 63 |       stepsize = ifelse(
 64 |         loss[iter] < loss[iter - 1],  
 65 |         stepsize * 1.2, 
 66 |         stepsize * .8
 67 |       )
 68 |     
 69 |     if (verbose && iter %% 10 == 0)
 70 |       message(paste('Iteration:', iter))
 71 |   }
 72 |   
 73 |   if (plotLoss)
 74 |     plot(loss, type = 'l', bty = 'n')
 75 |   
 76 |   list(
 77 |     par    = beta,
 78 |     loss   = loss,
 79 |     RSE    = sqrt(crossprod(LP - y) / (nrow(X) - ncol(X))), 
 80 |     iter   = iter,
 81 |     fitted = LP
 82 |   )
 83 | }
 84 | ```
 85 | 
 86 | ## Estimation
 87 | 
 88 | Set starting values.
 89 | 
 90 | ```{r gd-initial}
 91 | init = rep(0, 3)
 92 | ```
 93 | 
 94 | For any particular data you'd have to fiddle with the `stepsize`, which could 
 95 | be assessed via cross-validation, or alternatively one can use an
 96 | adaptive approach, a simple one of which is implemented in this function.
 97 | 
 98 | ```{r gd-result}
 99 | fit_gd = gd(
100 |   init,
101 |   X = X,
102 |   y = y,
103 |   tolerance = 1e-8,
104 |   stepsize  = 1e-4,
105 |   adapt     = TRUE
106 | )
107 | 
108 | str(fit_gd)
109 | ```
110 | 
111 | 
112 | ## Comparison
113 | 
114 | 
115 | We can compare to standard linear regression.
116 | 
117 | ```{r gd-compare, echo=FALSE}
118 | rbind(
119 |   gd = round(fit_gd$par[, 1], 5),
120 |   lm = coef(lm(y ~ x1 + x2))
121 | ) %>% 
122 |   kable_df()
123 | 
124 | # summary(lm(y ~ x1 + x2))
125 | ```
126 | 
127 | 
128 | 
129 | 
130 | ## Source
131 | 
132 | Original code available at https://github.com/m-clark/Miscellaneous-R-Code/blob/master/ModelFitting/gradient_descent.R
133 | 


--------------------------------------------------------------------------------
/hmm.Rmd:
--------------------------------------------------------------------------------
  1 | # Hidden Markov Model
  2 | 
  3 | 
  4 | This function duplicates [hmm_viterbi.py][HMM], which comes from the [Viterbi algorithm wikipedia page](https://en.wikipedia.org/wiki/Viterbi_algorithm) (at least as it was when I stumbled across it, see it in the [supplemental section](#python-hmm)). This first function is just to provide R code that is similar, in case anyone is interested in a more direct comparison, but the original used lists of tuples and thus was very inefficient R-wise, and provided output that wasn't succinct.  The second function takes a vectorized approach and returns a matrix in a much more straightforward fashion.  Both will provide the same result as the Python code. See The [Markov Model chapter][Markov Model] also.
  5 | 
  6 | ## Data Setup
  7 | 
  8 | ```{r hmm-setup}
  9 | library(tidyverse)
 10 | 
 11 | obs = c('normal', 'cold', 'dizzy')  # observed state
 12 | 
 13 | states = c('Healthy', 'Fever')      # latent states
 14 | 
 15 | start_p = c('Healthy' = 0.6, 'Fever' = 0.4) # starting probabilities
 16 | 
 17 | # transition matrix
 18 | trans_p = list(
 19 |   'Healthy' = c('Healthy' = 0.7, 'Fever' = 0.3), 
 20 |   'Fever'   = c('Healthy' = 0.4, 'Fever' = 0.6)
 21 | )
 22 | 
 23 | # emission matrix
 24 | emit_p = list(
 25 |   'Healthy' = c('normal' = 0.5, 'cold' = 0.4, 'dizzy' = 0.1),
 26 |   'Fever'   = c('normal' = 0.1, 'cold' = 0.3, 'dizzy' = 0.6)
 27 | )
 28 | ```
 29 | 
 30 | 
 31 | ## Function
 32 | 
 33 | This first function takes a Python-esque approach in the manner of the original, allowing for easier comparison.
 34 | 
 35 | ```{r viterbi1}
 36 | viterbi <- function(obs, states, start_p, trans_p, emit_p) {
 37 |   V = vector('list', length(obs))
 38 |   
 39 |   for (st in seq_along(states)) {
 40 |     V[[1]][[states[st]]] = list("prob" = start_p[st] * emit_p[[st]][obs[1]], 
 41 |                                 "prev" = NULL)
 42 |   }
 43 |   
 44 |   for (t in 2:length(obs)) {
 45 |     
 46 |     for (st in seq_along(states)) {
 47 |       max_tr_prob = numeric()
 48 |       
 49 |       for (prev_st in states) {
 50 |         max_tr_prob[prev_st] = V[[t-1]][[prev_st]][["prob"]] * trans_p[[prev_st]][[st]]
 51 |       }
 52 |       
 53 |       max_tr_prob = max(max_tr_prob)
 54 |       
 55 |       for (prev_st in states) {
 56 |         flag =  V[[t-1]][[prev_st]][["prob"]] * trans_p[[prev_st]][[st]] == max_tr_prob
 57 |         if (flag) {
 58 |           max_prob = max_tr_prob * emit_p[[st]][obs[t]]
 59 |           V[[t]][[states[st]]] = list('prob' = max_prob, 'prev' = prev_st)
 60 |         }
 61 |       }
 62 |       
 63 |     }
 64 |     
 65 |   }
 66 |   
 67 |   # I don't bother duplicating the text output code of the original
 68 |   df_out = rbind(
 69 |     Healthy = sapply(V, function(x) x$Healthy$prob),
 70 |     Fever   = sapply(V, function(x) x$Fever$prob)
 71 |   )
 72 |   
 73 |   colnames(df_out) = obs
 74 |   print(df_out)
 75 |   
 76 |   m = paste0(
 77 |     'The steps of states are: ', 
 78 |     paste(rownames(df_out)[apply(df_out, 2, which.max)], collapse = ' '), 
 79 |     paste('\nHighest probability: ', max(df_out[, ncol(df_out)]))
 80 |   )
 81 |   
 82 |   message(m)
 83 |   
 84 |   V
 85 | }
 86 | ```
 87 | 
 88 | 
 89 | This approach is much more R-like.
 90 | 
 91 | ```{r viterbi2}
 92 | viterbi_2 <- function(obs, states, start_p, trans_mat, emit_mat) {
 93 |   prob_mat = matrix(NA, nrow = length(states), ncol = length(obs))
 94 |   colnames(prob_mat) = obs
 95 |   rownames(prob_mat) = states
 96 | 
 97 |   prob_mat[,1] = start_p * emit_mat[,1]
 98 | 
 99 |   for (t in 2:length(obs)) {
100 |     prob_tran    = prob_mat[,t-1] * trans_mat
101 |     max_tr_prob  = apply(prob_tran, 2, max)
102 |     prob_mat[,t] = max_tr_prob * emit_mat[, obs[t]]
103 |   }
104 |   
105 |   print(prob_mat)
106 |   
107 |   m = paste0(
108 |     'The steps of states are: ', 
109 |     paste(states[apply(prob_mat, 2, which.max)], collapse = ' '), 
110 |     paste('\nHighest probability: ', max(prob_mat[, ncol(prob_mat)]))
111 |   )
112 |   
113 |   message(m)
114 | }
115 | ```
116 | 
117 | 
118 | 
119 | 
120 | 
121 | ## Estimation
122 | 
123 | First we demo the initial function.
124 | 
125 | ```{r viterbi1-est}
126 | test = viterbi(
127 |   obs,
128 |   states,
129 |   start_p,
130 |   trans_p,
131 |   emit_p
132 | )
133 | 
134 | # test
135 | 
136 | set.seed(123)
137 | obs = sample(obs, 6, replace = TRUE)
138 | 
139 | test = viterbi(
140 |   obs,
141 |   states,
142 |   start_p,
143 |   trans_p,
144 |   emit_p
145 | )
146 | # test
147 | ```
148 | 
149 | 
150 | Now the vectorized approach.
151 | 
152 | ```{r viterbi2-est}
153 | set.seed(123)
154 | 
155 | obs = c('normal', 'cold', 'dizzy')
156 | obs = sample(obs, 6, replace = T)
157 | 
158 | # need matrices now
159 | emit_mat  = do.call(rbind, emit_p)
160 | trans_mat = do.call(rbind, trans_p)
161 | 
162 | viterbi_2(
163 |   obs, 
164 |   states, 
165 |   start_p, 
166 |   trans_mat, 
167 |   emit_mat
168 | )
169 | ```
170 | 
171 | 
172 | 
173 | 
174 | 
175 | 
176 | ## Supplemental demo
177 | 
178 | This example comes from the [hidden markov model wikipedia page](https://en.wikipedia.org/wiki/Hidden_Markov_model).
179 | 
180 | ```{r viterbi-supp}
181 | states = c('Rainy', 'Sunny')
182 | 
183 | observations = c('walk', 'shop', 'clean')
184 | 
185 | start_probability = c('Rainy' = 0.6, 'Sunny' = 0.4)
186 | 
187 | transition_probability = rbind(
188 |   'Rainy' = c('Rainy' = 0.7, 'Sunny' = 0.3),
189 |   'Sunny' = c('Rainy' = 0.4, 'Sunny' = 0.6)
190 | )
191 | 
192 | emission_probability = rbind(
193 |   'Rainy' = c('walk' = 0.1, 'shop' = 0.4, 'clean' = 0.5),
194 |   'Sunny' = c('walk' = 0.6, 'shop' = 0.3, 'clean' = 0.1)
195 | )
196 | 
197 | viterbi_2(
198 |   observations,
199 |   states,
200 |   start_probability,
201 |   transition_probability,
202 |   emission_probability
203 | )
204 | ```
205 | 
206 | 
207 | ## Source
208 | 
209 | Original code for R found at
210 | https://github.com/m-clark/Miscellaneous-R-Code/blob/master/ModelFitting/hmm_viterbi.R
211 | 
212 | Original code for Python found at
213 | https://github.com/m-clark/Miscellaneous-R-Code/blob/master/ModelFitting/hmm_viterbi.py
214 | 


--------------------------------------------------------------------------------
/img/198R.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/m-clark/models-by-example/b544c35a3fdd63baecee7f904469c1174862ced3/img/198R.png


--------------------------------------------------------------------------------
/img/R.ico:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/m-clark/models-by-example/b544c35a3fdd63baecee7f904469c1174862ced3/img/R.ico


--------------------------------------------------------------------------------
/img/mc.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/m-clark/models-by-example/b544c35a3fdd63baecee7f904469c1174862ced3/img/mc.png


--------------------------------------------------------------------------------
/img/mc_logo.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/m-clark/models-by-example/b544c35a3fdd63baecee7f904469c1174862ced3/img/mc_logo.png


--------------------------------------------------------------------------------
/img/mc_sunset_2.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/m-clark/models-by-example/b544c35a3fdd63baecee7f904469c1174862ced3/img/mc_sunset_2.png


--------------------------------------------------------------------------------
/img/nineteeneightyR.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/m-clark/models-by-example/b544c35a3fdd63baecee7f904469c1174862ced3/img/nineteeneightyR.png


--------------------------------------------------------------------------------
/img/priorpost.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/m-clark/models-by-example/b544c35a3fdd63baecee7f904469c1174862ced3/img/priorpost.png


--------------------------------------------------------------------------------
/img/title_plot.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/m-clark/models-by-example/b544c35a3fdd63baecee7f904469c1174862ced3/img/title_plot.png


--------------------------------------------------------------------------------
/index.Rmd:
--------------------------------------------------------------------------------
 1 | ---
 2 | title: Model Estimation by Example
 3 | subtitle: Demonstrations with R
 4 | author:  |
 5 |   <span class="noem">Michael Clark</span> <br>
 6 |   [m-clark.github.io](https://m-clark.github.io/)
 7 | # date: "`r Sys.Date()`"
 8 | site: bookdown::bookdown_site
 9 | output:
10 |   bookdown::gitbook:
11 |     anchor_sections: FALSE
12 | documentclass: book
13 | # bibliography: refs.bib
14 | biblio-style: apalike
15 | always_allow_html: true
16 | link-citations: yes
17 | description: "This document provides 'by-hand' demonstrations of various models and algorithms. The goal is to take away some of the mystery by providing clean code examples that are easy to run and compare with other tools."
18 | cover-image: 'img/title_plot.svg'
19 | favicon: 'img/R.ico'
20 | url: 'https\://m-clark.github.io/models-by-example/'  
21 | github-repo:  'm-clark/models-by-example/'
22 | ---
23 | 
24 | 
25 | 
26 | 
27 | ```{r chunk_setup, include=FALSE, eval=TRUE}
28 | knitr::opts_chunk$set(
29 |   # code
30 |   echo      = TRUE,
31 |   message   = FALSE,
32 |   warning   = FALSE,
33 |   error     = FALSE,
34 |   comment   = NA,
35 |   R.options = list(width = 220),
36 |   # viz
37 |   dev.args  = list(bg = 'transparent'),
38 |   dev       = 'svglite',
39 |   fig.align = 'center',
40 |   out.width = '75%',
41 |   fig.asp   = .75,
42 |   # cache
43 |   cache.rebuild = FALSE,
44 |   cache         = TRUE
45 | )
46 | ```
47 | 
48 | ```{r load_common_packages, echo=FALSE, cache=FALSE, eval=TRUE}
49 | library(tidyverse)
50 | library(kableExtra)
51 | library(patchwork)
52 | 
53 | kable_df = function(data, digits = 3, ...) {
54 |   kableExtra::kable(
55 |     data,
56 |     digits = digits,
57 |     format = 'html',
58 |     booktabs = T,
59 |     # longtable = F,
60 |     linesep = "", 
61 |     ...,
62 |   ) %>% 
63 |     kableExtra::kable_styling(full_width = F)
64 | }
65 | 
66 | theme_set(visibly::theme_clean())
67 | ```
68 | 
69 | ####
70 | 
71 | ```{r rimg, fig.align='center',  out.width=800, out.height=600, echo=FALSE, cache=FALSE}
72 | knitr::include_graphics('img/title_plot.svg', dpi = NA)
73 | ```
74 | 
75 | ```{r ccimg, fig.align='center', out.width=0, fig.show='hide', echo=FALSE}
76 | knitr::include_graphics('img/mc_logo.png', dpi = NA)
77 | ```
78 | 


--------------------------------------------------------------------------------
/introduction.Rmd:
--------------------------------------------------------------------------------
 1 | # Introduction
 2 | 
 3 | This document provides 'by-hand' demonstrations of various models and
 4 | algorithms. The goal is to take away some of the mystery of them by providing
 5 | clean code examples that are easy to run and compare with other tools.
 6 | 
 7 | The code was collected over several years, so is not exactly consistent in
 8 | style, but now has been cleaned up to make it more so. Within each demo, you
 9 | will generally find some imported/simulated data, a primary estimating function,
10 | a comparison of results with some R package, and a link to the old code that was
11 | the initial demonstration.
12 | 
13 | The document has several sections:
14 | 
15 | - **Models**: More or less standard/traditional statistical models and more
16 | - **Bayesian**: Demonstrations of models using Stan
17 | - **Estimation**: Algorithms used in model estimation (e.g. penalized likelihood, stochastic gradient descent)
18 | - **Supplemental**: A handful of examples in languages other than R, possibly other miscellany
19 | 
20 | Note that this code is not meant to be extensive, or used in production, and in
21 | fact, some of these demos would probably be considered of historical interest
22 | only.  To be clear, almost everything here has a package/module that would do
23 | the same thing far better and efficiently.  Note also, the document itself is
24 | also not intended to be an introduction to any of these methods, and in fact
25 | sometimes contains very little expository text, assuming the reader has some
26 | familiarity with the model/approach and possibly some reference text. This
27 | document is just a learning tool for those with some background in place, but
28 | who want to dive a little deeper.
29 | 
30 | 
31 | Note the following color coding used in this document:
32 | 
33 | - <span class="emph">emphasis</span>
34 | - <span class="pack">package</span>
35 | - <span class="func">function</span>
36 | - <span class="objclass">object/class</span>
37 | - [link]() (with hover underline)
38 | 
39 | 
40 | Many examples require some initial data processing or visualization via <span class="pack" style = "">ggplot2</span>, so it's assumed the <span class="pack" style = "">tidyverse</span> set of packages is loaded for all demonstrations.
41 | 
42 | While I'm happy to fix any glaring errors and broken links, this is pretty much a completed document for the time being, except on the off chance I add a demo on rare occasion, or perhaps non-R code. This code has accumulated over years, and I just wanted it in a nicer format, which has been accomplished.  Perhaps if others would like to add to it via pull requests, I would do so.
43 | 
44 | 
45 | 
46 | The original code for these demonstrations may be found at their first home here: https://github.com/m-clark/Miscellaneous-R-Code.
47 | 
48 | 
49 | Last updated: `r Sys.Date()`.


--------------------------------------------------------------------------------
/lasso.Rmd:
--------------------------------------------------------------------------------
  1 | ## L1 (lasso) regularization
  2 | 
  3 | See Tibshirani (1996) for the original paper, or Murphy PML (2012) for a nice
  4 | overview (watch for typos in depictions). 
  5 | 
  6 | 
  7 | ### Data Setup
  8 | 
  9 | ```{r lasso-setup}
 10 | library(tidyverse)
 11 | 
 12 | set.seed(8675309)
 13 | 
 14 | N = 500
 15 | p = 10
 16 | X = scale(matrix(rnorm(N*p), ncol = p))
 17 | b = c(.5, -.5, .25, -.25, .125, -.125, rep(0, p - 6))
 18 | y = scale(X %*% b + rnorm(N, sd = .5))
 19 | lambda = .1
 20 | ```
 21 | 
 22 | 
 23 | ### Function
 24 | 
 25 | Coordinate descent function.
 26 | 
 27 | ```{r lasso}
 28 | lasso <- function(
 29 |   X,                   # model matrix
 30 |   y,                   # target
 31 |   lambda  = .1,        # penalty parameter
 32 |   soft    = TRUE,      # soft vs. hard thresholding
 33 |   tol     = 1e-6,      # tolerance
 34 |   iter    = 100,       # number of max iterations
 35 |   verbose = TRUE       # print out iteration number
 36 | ) {
 37 |   
 38 |   # soft thresholding function
 39 |   soft_thresh <- function(a, b) {
 40 |     out = rep(0, length(a))
 41 |     out[a >  b] = a[a > b] - b
 42 |     out[a < -b] = a[a < -b] + b
 43 |     out
 44 |   }
 45 |   
 46 |   w  = solve(crossprod(X) + diag(lambda, ncol(X))) %*% crossprod(X,y)
 47 |   tol_curr = 1
 48 |   J  = ncol(X)
 49 |   a  = rep(0, J)
 50 |   c_ = rep(0, J)
 51 |   i  = 1
 52 |   
 53 |   while (tol < tol_curr && i < iter) {
 54 |     w_old = w 
 55 |     a  = colSums(X^2)
 56 |     l  = length(y)*lambda  # for consistency with glmnet approach
 57 |     c_ = sapply(1:J, function(j)  sum( X[,j] * (y - X[,-j] %*% w_old[-j]) ))
 58 |     
 59 |     if (soft) {
 60 |       for (j in 1:J) {
 61 |         w[j] = soft_thresh(c_[j]/a[j], l/a[j])
 62 |       }
 63 |     }
 64 |     else {
 65 |       w = w_old
 66 |       w[c_< l & c_ > -l] = 0
 67 |     }
 68 |     
 69 |     tol_curr = crossprod(w - w_old)  
 70 |     
 71 |     i = i + 1
 72 |     
 73 |     if (verbose && i%%10 == 0) message(i)
 74 |   }
 75 |   
 76 |   w
 77 | }
 78 | ```
 79 | 
 80 | 
 81 | 
 82 | 
 83 | ### Estimation
 84 | 
 85 | Note, if `lambda = 0`, i.e. no penalty, the result is the same as what you would get from the base R  <span class="func" style = "">lm.fit</span>.
 86 | 
 87 | ```{r lasso-est}
 88 | fit_soft = lasso(
 89 |   X,
 90 |   y,
 91 |   lambda = lambda,
 92 |   tol    = 1e-12,
 93 |   soft   = TRUE
 94 | )
 95 | 
 96 | fit_hard = lasso(
 97 |   X,
 98 |   y,
 99 |   lambda = lambda,
100 |   tol    = 1e-12,
101 |   soft   = FALSE
102 | )
103 | ```
104 | 
105 | 
106 | 
107 | The <span class="pack" style = "">glmnet</span> approach is by default a mixture
108 | of ridge and lasso penalties, setting `alpha = 1` reduces to lasso (`alpha = 0`
109 | would be ridge). We set the lambda to a couple values while only wanting the one
110 | set to the same lambda value as above (`s`).
111 | 
112 | ```{r lasso-glmnet}
113 | library(glmnet)
114 | 
115 | fit_glmnet = coef(
116 |   glmnet(
117 |     X,
118 |     y,
119 |     alpha  = 1,
120 |     lambda = c(10, 1, lambda),
121 |     thresh = 1e-12,
122 |     intercept = FALSE
123 |   ),
124 |   s = lambda
125 | )
126 | 
127 | library(lassoshooting)
128 | 
129 | fit_ls = lassoshooting(
130 |   X = X,
131 |   y = y,
132 |   lambda = length(y) * lambda,
133 |   thr = 1e-12
134 | )
135 | 
136 | ```
137 | 
138 | 
139 | 
140 | ### Comparison
141 | 
142 | We can now compare the coefficients of all our results.
143 | 
144 | ```{r lasso-compare, echo=FALSE}
145 | data.frame(
146 |   lm = coef(lm(y ~ . - 1, data.frame(X))),
147 |   lasso_soft = fit_soft,
148 |   lasso_hard = fit_hard,
149 |   lspack = fit_ls$coef,
150 |   glmnet = fit_glmnet[-1, 1],
151 |   truth  = b
152 | ) %>% 
153 |   kable_df()
154 | ```
155 | 
156 | 
157 | 
158 | 
159 | 
160 | 
161 | ### Source
162 | 
163 | Original code available at https://github.com/m-clark/Miscellaneous-R-Code/blob/master/ModelFitting/lasso.R
164 | 


--------------------------------------------------------------------------------
/linear-regression.Rmd:
--------------------------------------------------------------------------------
  1 | # (PART\*)  Models {-}
  2 | 
  3 | 
  4 | 
  5 | # Linear Regression
  6 | 
  7 | We start our demonstrations with a standard regression model via maximum
  8 | likelihood or least squares loss. Also included are examples for QR
  9 | decomposition and normal equations. This can serve as an entry point for those
 10 | starting out in the wider world of computational statistics, as maximum
 11 | likelihood is the fundamental approach used in most applied statistics, but
 12 | which is also a key aspect of the Bayesian approach. Least squares loss is not
 13 | confined to the standard regression setting, but is widely used in more
 14 | predictive/'algorithmic' approaches e.g. in machine learning and elsewhere.  You can find a [Python version of the code in the supplemental section](#python-linreg).
 15 | 
 16 | 
 17 | ## Data Setup
 18 | 
 19 | We will simulate some data to make our results known and easier to manipulate.
 20 | 
 21 | ```{r lm-setup}
 22 | library(tidyverse)
 23 | 
 24 | set.seed(123)  # ensures replication
 25 | 
 26 | # predictors and target
 27 | N = 100 # sample size
 28 | k = 2   # number of desired predictors
 29 | X = matrix(rnorm(N * k), ncol = k)  
 30 | y = -.5 + .2*X[, 1] + .1*X[, 2] + rnorm(N, sd = .5)  # increasing N will get estimated values closer to these
 31 | 
 32 | dfXy = data.frame(X, y)
 33 | ```
 34 | 
 35 | 
 36 | ## Functions 
 37 | 
 38 | A maximum likelihood approach.
 39 | 
 40 | ```{r lm_ml}
 41 | lm_ml <- function(par, X, y) {
 42 |   # par: parameters to be estimated
 43 |   # X: predictor matrix with intercept column
 44 |   # y: target
 45 |   
 46 |   # setup
 47 |   beta   = par[-1]                             # coefficients
 48 |   sigma2 = par[1]                              # error variance
 49 |   sigma  = sqrt(sigma2)
 50 |   N = nrow(X)
 51 |   
 52 |   # linear predictor
 53 |   LP = X %*% beta                              # linear predictor
 54 |   mu = LP                                      # identity link in the glm sense
 55 |   
 56 |   # calculate likelihood
 57 |   L = dnorm(y, mean = mu, sd = sigma, log = TRUE) # log likelihood
 58 |   # L =  -.5*N*log(sigma2) - .5*(1/sigma2)*crossprod(y-mu)    # alternate log likelihood form
 59 | 
 60 |   -sum(L)                                      # optim by default is minimization, and we want to maximize the likelihood 
 61 |                                                # (see also fnscale in optim.control)
 62 | }
 63 | ```
 64 | 
 65 | 
 66 | 
 67 | An approach via least squares loss function.
 68 | 
 69 | 
 70 | ```{r lm_ls}
 71 | lm_ls <- function(par, X, y) {
 72 |   # arguments- 
 73 |   # par: parameters to be estimated
 74 |   # X: predictor matrix with intercept column
 75 |   # y: target
 76 |   
 77 |   # setup
 78 |   beta = par                                   # coefficients
 79 |   
 80 |   # linear predictor
 81 |   LP = X %*% beta                              # linear predictor
 82 |   mu = LP                                      # identity link
 83 |   
 84 |   # calculate least squares loss function
 85 |   L = crossprod(y - mu)
 86 | }
 87 | ```
 88 | 
 89 | 
 90 | ## Estimation
 91 | 
 92 | Setup for use with <span class="func" style = "">optim</span>.
 93 | 
 94 | 
 95 | ```{r lm-model-matrix}
 96 | X = cbind(1, X)
 97 | ```
 98 | 
 99 | Initial values. Note we'd normally want to handle the sigma differently as it's
100 | bounded by zero, but we'll ignore for demonstration.  Also `sigma2` is not
101 | required for the LS approach as it is the objective function.
102 | 
103 | ```{r lm-est}
104 | init = c(1, rep(0, ncol(X)))
105 | names(init) = c('sigma2', 'intercept', 'b1', 'b2')
106 | 
107 | fit_ML = optim(
108 |   par = init,
109 |   fn  = lm_ml,
110 |   X   = X,
111 |   y   = y,
112 |   control = list(reltol = 1e-8)
113 | )
114 | 
115 | fit_LS = optim(
116 |   par = init[-1],
117 |   fn  = lm_ls,
118 |   X   = X,
119 |   y   = y,
120 |   control = list(reltol = 1e-8)
121 | )
122 | 
123 | pars_ML = fit_ML$par
124 | pars_LS = c(sigma2 = fit_LS$value / (N-k-1), fit_LS$par)  # calculate sigma2 and add
125 | ```
126 | 
127 | ##  Comparison
128 |  
129 | Compare to `lm` which uses QR decomposition.
130 | 
131 | ```{r lm}
132 | fit_lm = lm(y ~ ., dfXy)
133 | ```
134 | 
135 | 
136 | Example of QR.  Not shown.
137 | 
138 | ```{r QR}
139 | # QRX = qr(X)
140 | # Q = qr.Q(QRX)
141 | # R = qr.R(QRX)
142 | # Bhat = solve(R) %*% crossprod(Q, y)
143 | # alternate: qr.coef(QRX, y)
144 | ```
145 | 
146 | ```{r lm-compare, echo=FALSE}
147 | rbind(
148 |     fit_ML = pars_ML,
149 |     fit_LS = pars_LS,
150 |     fit_lm = c(summary(fit_lm)$sigma^2, coef(fit_lm))
151 | ) %>% 
152 |   kable_df()
153 | ```
154 | 
155 | 
156 | The slight difference in sigma is roughly dividing by N vs. N-k-1 in the
157 | traditional least squares approach. It diminishes with increasing N as both tend
158 | toward whatever `sd^2` you specify when creating the `y` target above.
159 | 
160 | Compare to <span class="func" style = "">glm</span>, which by default assumes gaussian family with identity link
161 | and uses `lm.fit`.
162 | 
163 | ```{r glm-compare}
164 | fit_glm = glm(y ~ ., data = dfXy)
165 | summary(fit_glm)
166 | ```
167 | 
168 | Via normal equations.
169 | 
170 | ```{r lm-normal}
171 | coefs = solve(t(X) %*% X) %*% t(X) %*% y  # coefficients
172 | ```
173 | 
174 | 
175 | Compare.
176 | 
177 | ```{r lm-compare2, results='hold'}
178 | sqrt(crossprod(y - X %*% coefs) / (N - k - 1))
179 | summary(fit_lm)$sigma
180 | sqrt(fit_glm$deviance / fit_glm$df.residual) 
181 | c(sqrt(pars_ML[1]), sqrt(pars_LS[1]))
182 | 
183 | 
184 | # rerun by adding 3-4 zeros to the N
185 | ```
186 | 
187 | ## Python
188 | 
189 | The above is available as a Python demo in the [supplemental section](#python-linreg).
190 | 
191 | ## Source
192 | 
193 | Original code available at https://github.com/m-clark/Miscellaneous-R-Code/blob/master/ModelFitting/standard_lm.R
194 | 


--------------------------------------------------------------------------------
/logistic-regression.Rmd:
--------------------------------------------------------------------------------
  1 | # Logistic Regression
  2 | 
  3 | 
  4 | The following demo regards a standard logistic regression model via maximum
  5 | likelihood or exponential loss. This can serve as an entry point for those
  6 | starting out to the wider world of computational statistics as maximum
  7 | likelihood is the fundamental approach used in most applied statistics, but
  8 | which is also a key aspect of the Bayesian approach.  Exponential loss is not
  9 | confined to the standard GLM setting, but is widely used in more
 10 | predictive/'algorithmic' approaches e.g. in machine learning and elsewhere.
 11 | 
 12 | This follows the [linear regression model][Linear Regression] approach.
 13 | 
 14 | 
 15 | 
 16 | ## Data Setup 
 17 | 
 18 | Predictors and target.  This follows the same approach as the linear regression example, but now draws the target variable from the binomial distribution with `size = 1`.
 19 | 
 20 | ```{r data-setup-logreg}
 21 | library(tidyverse)
 22 | 
 23 | set.seed(1235)  # ensures replication
 24 | 
 25 | N = 10000 # sample size
 26 | k = 2     # number of desired predictors
 27 | X = matrix(rnorm(N * k), ncol = k)
 28 | 
 29 | # the linear predictor
 30 | lp = -.5 + .2*X[, 1] + .5*X[, 2] # increasing N will get estimated values closer to these
 31 | 
 32 | y = rbinom(N, size = 1, prob = plogis(lp))
 33 | 
 34 | dfXy = data.frame(X, y)
 35 | ```
 36 | 
 37 | ## Functions 
 38 |  
 39 | A maximum likelihood approach.
 40 | 
 41 | ```{r logreg_ml}
 42 | logreg_ml <- function(par, X, y) {
 43 |   # Arguments
 44 |   # par: parameters to be estimated
 45 |   # X: predictor matrix with intercept column
 46 |   # y: target
 47 |   
 48 |   # setup
 49 |   beta = par                                # coefficients
 50 |   N = nrow(X)
 51 |   
 52 |   # linear predictor
 53 |   LP = X %*% beta                           # linear predictor
 54 |   mu = plogis(LP)                           # logit link
 55 |   
 56 |   # calculate likelihood
 57 |   L = dbinom(y, size = 1, prob = mu, log = TRUE)         # log likelihood
 58 |   #   L =  y*log(mu) + (1 - y)*log(1-mu)    # alternate log likelihood form
 59 |   
 60 |   -sum(L)                                   # optim by default is minimization, and we want to maximize the likelihood 
 61 |   # (see also fnscale in optim.control)
 62 | }
 63 | ```
 64 | 
 65 | 
 66 | Another approach via exponential loss function.
 67 | 
 68 | ```{r logreg_exp}
 69 | logreg_exp <- function(par, X, y) {
 70 |   # Arguments
 71 |   # par: parameters to be estimated
 72 |   # X: predictor matrix with intercept column
 73 |   # y: target
 74 |   
 75 |   # setup
 76 |   beta = par                                   # coefficients
 77 |   
 78 |   # linear predictor
 79 |   LP = X %*% beta                              # linear predictor
 80 | 
 81 |   # calculate exponential loss function (convert y to -1:1 from 0:1)
 82 |   L = sum(exp(-ifelse(y, 1, -1) * .5 * LP))
 83 | }
 84 | ```
 85 | 
 86 | 
 87 | 
 88 | 
 89 | ## Estimation
 90 | 
 91 | Setup for use with <span class="func" style = "">optim</span>.
 92 | 
 93 | ```{r logreg-est}
 94 | X = cbind(1, X)
 95 | 
 96 | # initial values
 97 | 
 98 | init = rep(0, ncol(X))
 99 | names(init) = c('intercept', 'b1', 'b2')
100 | 
101 | fit_ml = optim(
102 |   par = init,
103 |   fn  = logreg_ml,
104 |   X   = X,
105 |   y   = y,
106 |   control = list(reltol = 1e-8)
107 | )
108 | 
109 | fit_exp = optim(
110 |   par = init,
111 |   fn  = logreg_exp,
112 |   X   = X,
113 |   y   = y, 
114 |   control = list(reltol = 1e-15)
115 | )
116 | 
117 | pars_ml  = fit_ml$par
118 | pars_exp = fit_exp$par
119 | ```
120 | 
121 | 
122 | ## Comparison
123 |  
124 | Compare to `glm`.
125 | 
126 | ```{r logreg-compare}
127 | fit_glm = glm(y ~ ., dfXy, family = binomial)
128 | ```
129 | 
130 | ```{r logreg-compare-show, echo=FALSE}
131 | rbind(
132 |   fit_ml  = pars_ml,
133 |   fit_exp = pars_exp,
134 |   fit_glm = coef(fit_glm)
135 | ) %>% 
136 |   kable_df()
137 | ```
138 | 
139 | 
140 | ## Python
141 | 
142 | The above is available as a Python demo in the [supplemental section](#python-logreg).
143 | 
144 | ## Source
145 | 
146 | Original code available at https://github.com/m-clark/Miscellaneous-R-Code/blob/master/ModelFitting/standard_logistic.R
147 | 


--------------------------------------------------------------------------------
/marginal-structural.Rmd:
--------------------------------------------------------------------------------
  1 | # Marginal Structural Model
  2 | 
  3 | This is a demonstration of a simple marginal structural model for estimation of so-called 'causal' effects using inverse probability weighting.
  4 | 
  5 | Example data is from, and comparison made to, the <span class="pack" style = "">ipw</span> package.  See more [here](https://www.jstatsoft.org/article/view/v043i13/v43i13.pdf).
  6 | 
  7 | 
  8 | ## Data Setup
  9 | 
 10 | This example is from the helpfile at `?ipwpoint`.
 11 | 
 12 | ```{r msm-setup}
 13 | library(tidyverse)
 14 | library(ipw)
 15 | 
 16 | set.seed(16)
 17 | 
 18 | n = 1000
 19 | simdat = data.frame(l = rnorm(n, 10, 5))
 20 | a_lin  = simdat$l - 10
 21 | pa = plogis(a_lin)
 22 | 
 23 | simdat = simdat %>% 
 24 |   mutate(
 25 |     a = rbinom(n, 1, prob = pa),
 26 |     y = 10 * a + 0.5 * l + rnorm(n, -10, 5)
 27 |   )
 28 | 
 29 | ipw_result = ipwpoint(
 30 |   exposure = a,
 31 |   family   = "binomial",
 32 |   link     = "logit",
 33 |   numerator   = ~ 1,
 34 |   denominator = ~ l,
 35 |   data = simdat
 36 | )
 37 | 
 38 | summary(ipw_result$ipw.weights)
 39 | ipwplot(ipw_result$ipw.weights)
 40 | ```
 41 | 
 42 | 
 43 | 
 44 | 
 45 | We create the weights as follows using the probabilities from a logistic regression.
 46 | 
 47 | ```{r msm-weights}
 48 | ps_num = fitted(glm(a ~ 1, data = simdat, family = 'binomial'))
 49 | ps_num[simdat$a == 0] = 1 - ps_num[simdat$a == 0]
 50 | 
 51 | ps_den = fitted(glm(a ~ l, data = simdat, family = 'binomial'))
 52 | ps_den[simdat$a == 0] = 1 - ps_den[simdat$a == 0]
 53 | 
 54 | wts = ps_num / ps_den
 55 | ```
 56 | 
 57 | Compare the weights.
 58 | 
 59 | ```{r msm-wts-compare}
 60 | rbind(summary(wts), summary(ipw_result$ipw.weights))
 61 | ```
 62 | 
 63 | 
 64 | Add inverse probability weights to the data if desired.
 65 | 
 66 | ```{r msm-add-weights}
 67 | simdat = simdat %>% 
 68 |   mutate(sw = ipw_result$ipw.weights)
 69 | ```
 70 | 
 71 | 
 72 | ## Function
 73 | 
 74 | Create the likelihood function for using the weights.
 75 | 
 76 | ```{r msm-func}
 77 | msm_ll <- function(
 78 |   par,             # parameters to be estimated; first is taken to be sigma
 79 |   X,               # model matrix
 80 |   y,               # target variable
 81 |   wts              # estimated weights
 82 | ) {
 83 |   beta  = par[-1]
 84 |   lp    = X %*% beta
 85 |   sigma = exp(par[1])  # exponentiated value to stay positive
 86 |   
 87 |   ll = dnorm(y, mean = lp, sd = sigma, log = TRUE)  
 88 |   -sum(ll * wts)   # weighted likelihood
 89 |   
 90 |   # same as
 91 |   # ll = dnorm(y, mean = lp, sd = sigma)^wts
 92 |   # -sum(log(ll))
 93 | }
 94 | ```
 95 | 
 96 | 
 97 | ## Estimation
 98 | 
 99 | We want to estimate the marginal structural model for the causal effect of `a` on `y` corrected for confounding by `l`, using inverse probability weighting with robust standard error from the <span class="pack" style = "">survey</span> package.  Create the matrices for estimation, estimate the model, and extract results.
100 | 
101 | ```{r msm-ml}
102 | X = cbind(1, simdat$a)
103 | y = simdat$y
104 | 
105 | fit = optim(
106 |   par = c(sigma = 0, intercept = 0, b = 0),
107 |   fn  = msm_ll,
108 |   X   = X,
109 |   y   = y,
110 |   wts = wts,
111 |   hessian = TRUE,
112 |   method  = 'BFGS',
113 |   control = list(abstol = 1e-12)
114 | )
115 | 
116 | dispersion = exp(fit$par[1])^2
117 | beta = fit$par[-1]
118 | ```
119 | 
120 | Now we compute the standard errors. The following uses the <span class="pack" style = "">survey</span> package raw version to get the appropriate standard errors, which the <span class="pack" style = "">ipw</span> approach uses.
121 | 
122 | 
123 | ```{r msm-se-1}
124 | glm_basic = glm(y ~ a, data = simdat, weights = wts)     # to get unscaled cov
125 | res = resid(glm_basic, type = 'working')                 # residuals
126 | glm_vcov_unsc = summary(glm_basic)$cov.unscaled          # weighted vcov unscaled by dispersion solve(crossprod(qr(X)))
127 | estfun = X * res * wts                  
128 | x = estfun %*% glm_vcov_unsc 
129 | ```
130 | 
131 | 
132 | ## Comparison
133 | 
134 | ```{r msm-svy}
135 | library("survey")
136 | 
137 | fit_msm = svyglm(
138 |   y ~ a,
139 |   design = svydesign(~ 1, weights = ~ sw, data = simdat)
140 | )
141 | 
142 | summary(fit_msm)
143 | ```
144 | 
145 | Now  get the standard errors.
146 | 
147 | ```{r msm-se-2}
148 | se = sqrt(diag(crossprod(x) * n/(n-1)))                  # a robust standard error
149 | se_robust = sqrt(diag(sandwich::sandwich(glm_basic)))    # an easier way to get it
150 | se_msm    = sqrt(diag(vcov(fit_msm)))                        # extract from msm model
151 | ```
152 | 
153 | Compare standard errors.
154 | 
155 | ```{r msm-se-compare}
156 | tibble(se, se_robust, se_msm)
157 | ```
158 | 
159 | Inspect the general fit and compare with the other.
160 | 
161 | ```{r msm-comparison- show, echo=FALSE}
162 | tibble(
163 |   Estimate  = beta,
164 |   init_se   = sqrt(diag(solve(fit$hessian)))[c('intercept', 'b')],  # same as scaled se from glm_basic
165 |   se_robust = se_robust,
166 |   t = Estimate/se,
167 |   p = 2*pt(abs(t), df = n - ncol(X), lower.tail = FALSE),  
168 |   dispersion = dispersion             
169 | ) %>% 
170 |   kable_df(caption = 'msm_ll')
171 | 
172 | broom::tidy(fit_msm) %>% 
173 |   kable_df(caption = 'svyglm')
174 | ```
175 | 
176 | 
177 | ## Source
178 | 
179 | Original code available at https://github.com/m-clark/Miscellaneous-R-Code/blob/master/ModelFitting/ipw.R
180 | 


--------------------------------------------------------------------------------
/markov.Rmd:
--------------------------------------------------------------------------------
  1 | # Markov Model
  2 | 
  3 | 
  4 | Here we demonstrate a [Markov model](https://en.wikipedia.org/wiki/Markov_model). We start by showing how to create some data and estimate such a model via the <span class="pack" style = "">markovchain</span> package. You may want to play with it to get a better feel for how it works, as we will use it for comparison later. 
  5 | 
  6 | ```{r markov-chain-demo}
  7 | library(tidyverse)
  8 | 
  9 | library(markovchain)
 10 | 
 11 | A = matrix(c(.7, .3, .9, .1), nrow = 2, byrow = TRUE)
 12 | 
 13 | dtmcA = new(
 14 |   'markovchain',
 15 |   transitionMatrix = A,
 16 |   states = c('a', 'b'),
 17 |   name = 'MarkovChain A'
 18 | )
 19 | 
 20 | dtmcA
 21 | 
 22 | plot(dtmcA)
 23 | 
 24 | transitionProbability(dtmcA, 'b', 'b')
 25 | initialState = c(0, 1)
 26 | steps = 4
 27 | finalState = initialState * dtmcA^steps # using power operator
 28 | finalState
 29 | 
 30 | 
 31 | steadyStates(dtmcA)
 32 | 
 33 | 
 34 | observed_states = sample(c('a', 'b'), 50, c(.7, .3), replace = TRUE)
 35 | 
 36 | createSequenceMatrix(observed_states)
 37 | 
 38 | markovchainFit(observed_states)
 39 | ```
 40 | 
 41 | 
 42 | 
 43 | 
 44 | 
 45 | ## Data Setup
 46 | 
 47 | 
 48 | ### Data Functions
 49 | 
 50 | A recursive function to take a matrix power.
 51 | 
 52 | ```{r matrix-power}
 53 | mat_power <- function(M, N) {
 54 |   if (N == 1) return(M)
 55 |   
 56 |   M %*% mat_power(M, N - 1)
 57 | }
 58 | ```
 59 | 
 60 | 
 61 | A function to create a sequence.
 62 | 
 63 | ```{r create-sequence}
 64 | create_sequence  <- function(states, len, tmat) {
 65 |   # states: number of states
 66 |   # len: length of sequence
 67 |   # tmat: the transition matrix
 68 |   states_numeric = length(unique(states))
 69 |   out = numeric(len)
 70 |   out[1] = sample(states_numeric, 1, prob = colMeans(tmat)) # initial state
 71 |   
 72 |   for (i in 2:len){
 73 |     out[i] = sample(states_numeric, 1, prob = tmat[out[i - 1], ])
 74 |   }
 75 |   
 76 |   states[out]
 77 | }
 78 | ```
 79 | 
 80 | 
 81 | ```{r markov-setup}
 82 | # example
 83 | test_matrix = matrix(rep(2, 4), nrow = 2)
 84 | test_matrix
 85 | mat_power(test_matrix, 2)
 86 | 
 87 | # transition matrix
 88 | A = matrix(c(.7, .3, .4, .6), nrow = 2, byrow = TRUE)
 89 | 
 90 | mat_power(A, 10)
 91 | ```
 92 | 
 93 | 
 94 | 
 95 | ### Two states Demo
 96 | 
 97 | Note that a notably long sequence is needed to get close to recovering the true transition matrix.
 98 | 
 99 | ```{r two-state-demo}
100 | A = matrix(c(.7, .3, .9, .1), nrow = 2, byrow = TRUE)
101 | observed_states = create_sequence(c('a', 'b'), 500, tmat = A)
102 | 
103 | createSequenceMatrix(observed_states)
104 | prop.table(createSequenceMatrix(observed_states), 1)
105 | 
106 | fit = markovchainFit(observed_states)
107 | fit
108 | 
109 | # log likelihood
110 | sum(createSequenceMatrix(observed_states) * log(fit$estimate@transitionMatrix))
111 | ```
112 | 
113 | 
114 | 
115 | 
116 | 
117 | ### Three states demo
118 | 
119 | ```{r three-state-demo}
120 | A = matrix(
121 |   c(.70, .20, .10,
122 |     .20, .40, .40,
123 |     .05, .05, .90), 
124 |   nrow  = 3, 
125 |   byrow = TRUE
126 | )
127 | 
128 | observed_states = create_sequence(c('a', 'b', 'c'), 500, tmat = A)
129 | createSequenceMatrix(observed_states)
130 | 
131 | prop.table(createSequenceMatrix(observed_states), 1)
132 | markovchainFit(observed_states)
133 | ```
134 | 
135 | 
136 | 
137 | 
138 | ## Function
139 | 
140 | Now we create a function to calculate the (negative) log likelihood.
141 | 
142 | ```{r markov-ll}
143 | markov_ll <- function(par, x) {
144 |   # par should be the c(A) of transition probabilities A
145 |   nstates = length(unique(x))
146 |   
147 |   # create transition matrix
148 |   par = matrix(par, ncol = nstates)
149 |   par = t(apply(par, 1, function(x) x / sum(x)))
150 |   
151 |   # create seq matrix
152 |   seq_mat = table(x[-length(x)], x[-1])
153 |   
154 |   # calculate log likelihood
155 |   ll = sum(seq_mat * log(par))
156 |   
157 |   -ll
158 | }
159 | ```
160 | 
161 | ```{r data-gen}
162 | A = matrix(
163 |   c(.70, .20, .10,
164 |     .40, .20, .40,
165 |     .10, .15, .75),
166 |   nrow  = 3,
167 |   byrow = TRUE
168 | )
169 | 
170 | observed_states = create_sequence(c('a', 'b', 'c'), 1000, tmat = A)
171 | ```
172 | 
173 | ## Estimation
174 | 
175 | Note that initial state values will be transformed to rowsum to one, so the specific initial values don't matter (i.e. they don't have to be probabilities). With the basic <span class="func" style = "">optim</span> approach, sometimes log(0) will occur and produce a warning. Can be ignored, or use `LFBGS` as demonstrated at the end.
176 | 
177 | ```{r mm-est}
178 | initpar = rep(1, 9)
179 | 
180 | fit = optim(
181 |   par = initpar,
182 |   fn  = markov_ll,
183 |   x   = observed_states,
184 |   method  = 'BFGS',
185 |   control = list(reltol = 1e-12)
186 | )
187 | 
188 | # get estimates on prob scale
189 | est_mat = matrix(fit$par, ncol = 3)
190 | est_mat = t(apply(est_mat, 1, function(x)  x / sum(x)))
191 | ```
192 | 
193 | ## Comparison
194 | 
195 | Compare with <span class="pack" style = "">markovchain</span> package.
196 | 
197 | ```{r markov-compare}
198 | fit_compare = markovchainFit(observed_states)
199 | 
200 | # compare log likelihood
201 | c(-fit$value, fit_compare$logLikelihood)
202 | 
203 | # compare estimated transition matrix
204 | list(
205 |   `Estimated via optim` = est_mat,
206 |   `markovchain Package` = fit_compare$estimate@transitionMatrix,
207 |   `Analytical Solution` = prop.table(
208 |     table(observed_states[-length(observed_states)], observed_states[-1])
209 |     , 1)
210 | ) %>% 
211 |   purrr::map(round, 3)
212 | ```
213 | 
214 | 
215 | 
216 | 
217 | Visualize.
218 | 
219 | ```{r markov-vis}
220 | plot(
221 |   new(
222 |     'markovchain',
223 |     transitionMatrix = est_mat,
224 |     states = c('a', 'b', 'c'),
225 |     name = 'Estimated Markov Chain'
226 |   )
227 | )
228 | ```
229 | 
230 | 
231 | 
232 | 
233 | If you don't want warnings due to zeros use constraints (`?constrOptim`).
234 | 
235 | ```{r markov-est-constrained, eval=FALSE}
236 | fit = optim(
237 |   par = initpar,
238 |   fn  = markov_ll,
239 |   x   = observed_states,
240 |   method  = 'L-BFGS',
241 |   lower   = rep(1e-20, length(initpar)),
242 |   control = list(pgtol = 1e-12)
243 | )
244 | ```
245 | 
246 | 
247 | 
248 | ## Source
249 | 
250 | Original code available at
251 | https://github.com/m-clark/Miscellaneous-R-Code/blob/master/ModelFitting/markov_model.R
252 | 


--------------------------------------------------------------------------------
/mixed-model-one-factor.Rmd:
--------------------------------------------------------------------------------
  1 | ## One-factor Mixed Model
  2 | 
  3 | The following is an approach for one factor random effects model via maximum
  4 | likelihood in R (and Matlab and Julia in the [Supplemental
  5 | Section][One-factor]). It's based on Statistical Modeling and Computation (2014)
  6 | Chapter 10, example 10.10. Unfortunately I did this before knowing they had both
  7 | Matlab and R code on their website, though the R code here is a little cleaner
  8 | and has comments. 
  9 | 
 10 | 
 11 | ### Data Setup
 12 | 
 13 | The data regards crop yield from 10 randomly selected
 14 | locations and three collections at each location.
 15 | 
 16 | ```{r one-factor-re-setup}
 17 | library(tidyverse)
 18 | 
 19 | y = matrix(c(22.6, 20.5, 20.8,
 20 |              22.6, 21.2, 20.5,
 21 |              17.3, 16.2, 16.6,
 22 |              21.4, 23.7, 23.2,
 23 |              20.9, 22.2, 22.6,
 24 |              14.5, 10.5, 12.3,
 25 |              20.8, 19.1, 21.3,
 26 |              17.4, 18.6, 18.6,
 27 |              25.1, 24.8, 24.9,
 28 |              14.9, 16.3, 16.6), 
 29 |            10, 3, byrow = TRUE)
 30 | ```
 31 | 
 32 | 
 33 | ### Function 
 34 | 
 35 | The estimating function.
 36 | 
 37 | ```{r one-factor-re}
 38 | one_factor_re <- function(mu, sigma2_mu, sigma2){
 39 |   # Args
 40 |   # mu: intercept
 41 |   # sigma2_mu: variance of intercept
 42 |   # sigma2: residual variance of y
 43 |   
 44 |   # I follow their notation for consistency
 45 |   d  = nrow(y)
 46 |   ni = ncol(y)
 47 |   
 48 |   # covariance matrix of observations
 49 |   Sigmai = sigma2 * diag(ni) + sigma2_mu * matrix(1, ni, ni)
 50 |   
 51 |   # log likelihood
 52 |   l = rep(NA, 10)
 53 |   # iterate over the rows
 54 |   for(i in 1:d){
 55 |     l[i] = .5 * t(y[i, ] - mu) %*% chol2inv(chol(Sigmai)) %*% (y[i, ] - mu)  
 56 |   }
 57 |   
 58 |   ll =  -(ni*d) / 2*log(2*pi) - d / 2*log(det(Sigmai)) - sum(l)
 59 |   
 60 |   return(-ll)
 61 | }
 62 | ```
 63 | 
 64 | 
 65 | ### Estimation 
 66 | 
 67 | Starting values.
 68 | 
 69 | ```{r one-factor-re-starts}
 70 | starts = list(
 71 |   mu = mean(y),
 72 |   sigma2_mu = var(rowMeans(y)),
 73 |   sigma2    = mean(apply(y, 1, var))
 74 | )
 75 | ```
 76 | 
 77 | 
 78 | Estimate at the starting values.
 79 | 
 80 | ```{r one-factor-re-est}
 81 | one_factor_re(mu = starts[[1]],
 82 |               sigma2_mu = starts[[2]],
 83 |               sigma2    = starts[[3]])
 84 | ```
 85 | 
 86 | 
 87 | Package <span class="pack" style = "">bbmle</span> has an <span class="func" style = "">mle2</span> function for maximum likelihood estimation based on underlying R functions like <span class="func" style = "">optim</span>, and produces a nice summary table. *LBFGS-B* is used to place lower bounds on the variance estimates.
 88 | 
 89 | ```{r one-factor-re-bbmle}
 90 | library(bbmle)
 91 | 
 92 | fit_mle = mle2(
 93 |   one_factor_re ,
 94 |   start  = starts,
 95 |   method = 'L-BFGS-B',
 96 |   lower  = c(
 97 |     mu        = -Inf,
 98 |     sigma2_mu = 0,
 99 |     sigma2    = 0
100 |   ),
101 |   trace = TRUE
102 | )
103 | ```
104 | 
105 | 
106 | ### Comparison
107 | 
108 | 
109 | We can compare to the <span class="pack" style = "">lme4</span> model result.
110 | 
111 | 
112 | ```{r one-factor-re-compare}
113 | library(lme4)
114 | library(tidyverse)
115 | 
116 | d = data.frame(y) %>% 
117 |   pivot_longer(everything(), names_to = 'x', values_to = 'value') %>% 
118 |   arrange(x) %>% 
119 |   group_by(x) %>% 
120 |   mutate(group = 1:n())
121 | 
122 | fit_mer = lmer(value ~ 1 | group, data = d, REML = FALSE)
123 | 
124 | summary(fit_mle)
125 | summary(fit_mer)
126 | -2 * logLik(fit_mer)
127 | ```
128 | 
129 | 
130 | ### Source
131 | 
132 | Original code available at https://github.com/m-clark/Miscellaneous-R-Code/blob/master/ModelFitting/Mixed%20Models/one_factor_RE.R
133 | 


--------------------------------------------------------------------------------
/mixed-model-two-factor.Rmd:
--------------------------------------------------------------------------------
  1 | ## Two-factor Mixed Model
  2 | 
  3 | 
  4 | 
  5 | An approach for two factor random effects model via maximum likelihood in R Matlab and Julia. It's based on Statistical Modeling and Computation (2014) Chapter 10, example 10.10.   See the [previous chapter][One-factor Mixed Model] for a one factor model, and the [Supplemental Section][Two-factor] for the Matlab and Julia versions of this example. Note that the text has a typo on the `sigma2` variance estimate (value should be .0023 not .023).
  6 | 
  7 | 
  8 | ### Data Setup
  9 | 
 10 | The data regards the breeding value of a set of five sires in raising pigs. Each
 11 | sire is mated to a random group of dams, with the response being the average
 12 | daily weight gain in pounds of two piglets in each litter.
 13 | 
 14 | ```{r two-factor-re-setup}
 15 | library(tidyverse)
 16 | 
 17 | y = c(1.39,1.29,1.12,1.16,1.52,1.62,1.88,1.87,1.24,1.18,
 18 |       .95,.96,.82,.92,1.18,1.20,1.47,1.41,1.57,1.65)
 19 | 
 20 | # for use in lme4, but also a more conceptual representation of the data
 21 | d = expand.grid(sire = rep(1:5, 2), dam = 1:2)
 22 | d = data.frame(d[order(d$sire), ], y)
 23 | ```
 24 | 
 25 | 
 26 | ### Function
 27 | 
 28 | The function takes the log variances `eta` as input to keep positive.
 29 | 
 30 | ```{r two-factor-re}
 31 | two_factor_re <- function(mu, eta_alpha, eta_gamma, eta) {
 32 |   # Args 
 33 |   # mu: intercept 
 34 |   # eta_alpha: random effect one 
 35 |   # eta_gamma: random effect two
 36 |   # eta: residual variance of y
 37 |   
 38 |   sigma2_alpha = exp(eta_alpha)
 39 |   sigma2_gamma = exp(eta_gamma)
 40 |   sigma2 = exp(eta)
 41 |   n = length(y)
 42 |   
 43 |   # covariance matrix of observations
 44 |   Sigma = sigma2 * diag(n) + sigma2_alpha * tcrossprod(Xalpha) + 
 45 |     sigma2_gamma * tcrossprod(Xgamma)
 46 |   
 47 |   
 48 |   # log likelihood
 49 |   ll = -n / 2 * log(2 * pi) - sum(log(diag(chol(Sigma)))) -
 50 |     .5 * t(y - mu) %*% chol2inv(chol(Sigma)) %*% (y - mu)
 51 |   
 52 |   return(-ll)
 53 | }
 54 | ```
 55 | 
 56 | 
 57 | 
 58 | ### Estimation
 59 | 
 60 | Starting values and test.
 61 | 
 62 | ```{r two-factor-re-starts}
 63 | starts = list(
 64 |   mu = mean(y),
 65 |   eta_alpha = var(tapply(y, d$sire, mean)),
 66 |   eta_gamma = var(y) / 3,
 67 |   eta = var(y) / 3
 68 | )
 69 | 
 70 | Xalpha = diag(5) %x% rep(1, 4)
 71 | 
 72 | Xgamma = diag(10) %x% rep(1, 2)
 73 | ```
 74 | 
 75 | 
 76 | Estimate at starting values.
 77 | 
 78 | 
 79 | ```{r two-factor-re-est}
 80 | two_factor_re(
 81 |   mu  = starts[[1]],
 82 |   eta_alpha = starts[[2]],
 83 |   eta_gamma = starts[[3]],
 84 |   eta = starts[[4]]
 85 | )
 86 | ```
 87 | 
 88 | Package <span class="pack" style = "">bbmle</span> has an <span class="func" style = "">mle2</span> function for maximum likelihood estimation based on underlying R functions like <span class="func" style = "">optim</span>, and produces a nice summary table. LBFGS-B is used to place lower bounds on the variance estimates.
 89 | 
 90 | ```{r two-factor-re-bbmle}
 91 | library(bbmle)
 92 | 
 93 | fit_mle = mle2(two_factor_re, start = starts,  method = 'BFGS')
 94 | ```
 95 | 
 96 | 
 97 | ### Comparison
 98 | 
 99 | We can compare to the <span class="pack" style = "">lme4</span> model result.
100 | 
101 | ```{r two-factor-re-compare}
102 | ### lme4 comparison
103 | library(lme4)
104 | 
105 | fit_mer = lmer(y ~ (1 | sire) + (1 | dam:sire), d, REML = FALSE)
106 | 
107 | summary(fit_mle)
108 | exp(coef(fit_mle)[-1])
109 | 
110 | summary(fit_mer)
111 | ```
112 | 
113 | 
114 | ### Source
115 | 
116 | Original code available at https://github.com/m-clark/Miscellaneous-R-Code/blob/master/ModelFitting/Mixed%20Models/two_factor_RE.R
117 | 
118 | 
119 | 
120 | 
121 | 


--------------------------------------------------------------------------------
/mixed-models.Rmd:
--------------------------------------------------------------------------------
 1 | # Mixed Models
 2 | 
 3 | 
 4 | This chapter regards mixed models, a flexible expansion of standard regression methods to account for some covariance among the observations.  
 5 | 
 6 | ```{r child='mixed-model-one-factor.Rmd'}
 7 | ```
 8 | 
 9 | ```{r child='mixed-model-two-factor.Rmd'}
10 | ```
11 | 
12 | ```{r child='mixed-model-ML.Rmd'}
13 | ```
14 | 


--------------------------------------------------------------------------------
/models-by-example.Rproj:
--------------------------------------------------------------------------------
 1 | Version: 1.0
 2 | 
 3 | RestoreWorkspace: Default
 4 | SaveWorkspace: Default
 5 | AlwaysSaveHistory: Default
 6 | 
 7 | EnableCodeIndexing: Yes
 8 | UseSpacesForTab: Yes
 9 | NumSpacesForTab: 2
10 | Encoding: UTF-8
11 | 
12 | RnwWeave: knitr
13 | LaTeX: pdfLaTeX
14 | 
15 | BuildType: Website
16 | 
17 | PythonType: conda
18 | PythonVersion: 3.8.5
19 | PythonPath: ~/opt/anaconda3/envs/r-reticulate/bin/python
20 | 


--------------------------------------------------------------------------------
/naive-bayes.Rmd:
--------------------------------------------------------------------------------
 1 | # Naive Bayes 
 2 | 
 3 | 
 4 | ## Initialization
 5 | 
 6 | Demo for binary data. First we generate some data. We have several binary covariates and a binary target variable `y`.
 7 | 
 8 | ```{r naive-init}
 9 | library(tidyverse)
10 | 
11 | set.seed(123)
12 | 
13 | x  = matrix(sample(0:1, 50, replace = TRUE), ncol = 5)
14 | xf = map(data.frame(x), factor)
15 | y  = sample(0:1, 10, prob = c(.25, .75), replace = TRUE)
16 | ```
17 | 
18 | 
19 | ## Comparison
20 | 
21 | We can use <span class="pack" style = "">e1071</span> for comparison.
22 | 
23 | ```{r naive-compare}
24 | library(e1071)
25 | 
26 | m = naiveBayes(xf, y)
27 | 
28 | m
29 | ```
30 | 
31 | 
32 | Using base R for our model, we can easily obtain the 'predictions'...
33 | 
34 | ```{r naive-est}
35 | map(xf, function(var)
36 |   t(prop.table(table(' ' = var, y), margin = 2)))
37 | ```
38 | 
39 | 
40 | ## Source
41 | 
42 | Original code available at https://github.com/m-clark/Miscellaneous-R-Code/blob/master/ModelFitting/naivebayes.R
43 | 


--------------------------------------------------------------------------------
/newton-irls.Rmd:
--------------------------------------------------------------------------------
  1 | # Newton and IRLS
  2 | 
  3 | 
  4 | 
  5 | Here we demonstrate Newton's and Iterated Reweighted Least Squares approaches
  6 | with a logistic regression model.
  7 | 
  8 | For the following, I had Murphy's PML text open and more or less followed the
  9 | algorithms in chapter 8.  Note that for Newton's method, this doesn't implement
 10 | a line search to find a more optimal stepsize at a given iteration.
 11 | 
 12 | ## Data Setup
 13 | 
 14 | Predict graduate school admission based on gre, gpa, and school rank (higher is
 15 | more prestige). See corresponding demo
 16 | [here](https://stats.idre.ucla.edu/stata/dae/logistic-regression/). The only
 17 | difference is that I treat rank as numeric rather than categorical.  We will be
 18 | comparing results to base R <span class="func" style = "">glm</span> function,
 19 | so I will use it to create the model data.
 20 | 
 21 | 
 22 | ```{r newton-setup}
 23 | library(tidyverse)
 24 | 
 25 | admit = haven::read_dta('https://stats.idre.ucla.edu/stat/stata/dae/binary.dta')
 26 | 
 27 | fit_glm = glm(admit ~ gre + gpa + rank, data = admit, family = binomial)
 28 | 
 29 | # summary(fit_glm)
 30 | 
 31 | X = model.matrix(fit_glm)
 32 | y = fit_glm$y
 33 | ```
 34 | 
 35 | 
 36 | 
 37 | 
 38 | ## Functions
 39 | 
 40 | ### Newton's Method
 41 | 
 42 | ```{r newton}
 43 | newton <- function(
 44 |   X,
 45 |   y,
 46 |   tol  = 1e-12,
 47 |   iter = 500,
 48 |   stepsize = .5
 49 |   ) {
 50 |   
 51 |   # Args: 
 52 |   # X: model matrix
 53 |   # y: target
 54 |   # tol: tolerance
 55 |   # iter: maximum number of iterations
 56 |   # stepsize: (0, 1)
 57 |   
 58 |   # intialize
 59 |   int     = log(mean(y) / (1 - mean(y)))         # intercept
 60 |   beta    = c(int, rep(0, ncol(X) - 1))
 61 |   currtol = 1
 62 |   it = 0
 63 |   ll = 0
 64 |   
 65 |   while (currtol > tol && it < iter) {
 66 |     it = it +1
 67 |     ll_old = ll
 68 |     
 69 |     mu = plogis(X %*% beta)[,1]
 70 |     g  = crossprod(X, mu-y)               # gradient
 71 |     S  = diag(mu*(1-mu)) 
 72 |     H  = t(X) %*% S %*% X                 # hessian
 73 |     beta = beta - stepsize * solve(H) %*% g
 74 | 
 75 |     ll = sum(dbinom(y, prob = mu, size = 1, log = TRUE))
 76 |     currtol = abs(ll - ll_old)
 77 |   }
 78 |   
 79 |   list(
 80 |     beta = beta,
 81 |     iter = it,
 82 |     tol  = currtol,
 83 |     loglik = ll
 84 |   )
 85 | }
 86 | ```
 87 | 
 88 | ### IRLS 
 89 | 
 90 | Note that <span class="func" style = "">glm</span> is actually using IRLS, so
 91 | the results from this should be fairly spot on.
 92 | 
 93 | ```{r irls}
 94 | irls <- function(X, y, tol = 1e-12, iter = 500) {
 95 |   
 96 |   # intialize
 97 |   int  = log(mean(y) / (1 - mean(y)))   # intercept
 98 |   beta = c(int, rep(0, ncol(X) - 1))
 99 |   currtol = 1
100 |   it = 0
101 |   ll = 0
102 |   
103 |   while (currtol > tol && it < iter) {
104 |     it = it + 1
105 |     ll_old = ll
106 |     
107 |     eta  = X %*% beta
108 |     mu   = plogis(eta)[,1]
109 |     s    = mu * (1 - mu)
110 |     S    = diag(s)
111 |     z    = eta + (y - mu)/s
112 |     beta = solve(t(X) %*% S %*% X) %*% (t(X) %*% (S %*% z))
113 |     
114 |     ll = sum(
115 |       dbinom(
116 |         y,
117 |         prob = plogis(X %*% beta),
118 |         size = 1,
119 |         log  = TRUE
120 |       )
121 |     )
122 |     
123 |     currtol = abs(ll - ll_old)
124 |   }
125 |   
126 |   list(
127 |     beta = beta,
128 |     iter = it,
129 |     tol  = currtol,
130 |     loglik  = ll,
131 |     weights = plogis(X %*% beta) * (1 - plogis(X %*% beta))
132 |   )
133 | }
134 | ```
135 | 
136 | 
137 | ## Estimation
138 | 
139 | ```{r newton-est}
140 | fit_newton = newton(
141 |   X = X,
142 |   y = y,
143 |   stepsize = .9,
144 |   tol = 1e-8      # tol set to 1e-8 as in glm default
145 | ) 
146 | 
147 | fit_newton
148 | # fit_glm
149 | ```
150 | 
151 | 
152 | `tol` set to 1e-8 as in <span class="func" style = "">glm</span> default.
153 | 
154 | ```{r irls-est}
155 | irls_result = irls(X = X, y = y, tol = 1e-8) 
156 | 
157 | str(irls_result)
158 | # fit_glm
159 | ```
160 |  
161 | 
162 | 
163 | ## Comparison
164 | 
165 | 
166 | Compare all results.
167 | 
168 | ```{r irls-compare, echo=FALSE}
169 | rbind(
170 |   newton = unlist(fit_newton),
171 |   irls   = unlist(irls_result[-length(irls_result)]),
172 |   glm_default = c(
173 |     beta = coef(fit_glm),
174 |     fit_glm$iter,
175 |     tol = NA,
176 |     loglik = logLik(fit_glm)
177 |   )
178 | ) %>% 
179 |   kable_df()
180 | ```
181 | 
182 | Compare weights between the <span class="func" style = "">irls</span> and <span class="func" style = "">glm</span> results.
183 | 
184 | ```{r irls-compare-weights}
185 | head(cbind(irls_result$weights, fit_glm$weights))
186 | ```
187 | 
188 | 
189 | 
190 | ## Source
191 | 
192 | Original code available at https://github.com/m-clark/Miscellaneous-R-Code/blob/master/ModelFitting/newton_irls.R
193 | 


--------------------------------------------------------------------------------
/ordinal.Rmd:
--------------------------------------------------------------------------------
  1 | # Ordinal Regression
  2 | 
  3 | The following demonstrates a standard cumulative link ordinal regression model
  4 | via maximum likelihood. Default is with probit link function. Alternatively you
  5 | can compare it with a logit link, which will result in values roughly
  6 | 1.7*parameters estimates from the probit.
  7 | 
  8 | 
  9 | ## Data
 10 | 
 11 | This data generation is from the probit perspective, where the underlying continuous latent variable is normally distributed.
 12 | 
 13 | ```{r ordinal-setup}
 14 | library(tidyverse)
 15 | 
 16 | set.seed(808)
 17 | 
 18 | N = 1000                                       # Sample size
 19 | x = cbind(x1 = rnorm(N), x2 = rnorm(N))        # predictor variables
 20 | beta   = c(1,-1)                               # coefficients
 21 | y_star = rnorm(N, mean = x %*% beta)           # the underlying latent variable
 22 | y_1 = y_star > -1.5                            # -1.50 first cutpoint
 23 | y_2 = y_star > .75                             #  0.75 second cutpoint
 24 | y_3 = y_star > 1.75                            #  1.75 third cutpoint
 25 | y   = y_1 + y_2 + y_3 + 1                      # target
 26 | 
 27 | table(y)
 28 | 
 29 | d = data.frame(x, y = factor(y))
 30 | ```
 31 | 
 32 | 
 33 | ## Function
 34 | 
 35 | ```{r ordinal_ll}
 36 | ordinal_ll <- function(par, X, y, probit = TRUE) {
 37 |   K = length(unique(y))                        # number of classes K
 38 |   ncuts = K-1                                  # number of cutpoints/thresholds
 39 |   cuts  = par[(1:ncuts)]                       # cutpoints
 40 |   beta  = par[-(1:ncuts)]                      # regression coefficients
 41 |   lp    = X %*% beta                           # linear predictor
 42 |   ll    = rep(0, length(y))                    # log likelihood
 43 |   pfun  = ifelse(probit, pnorm, plogis)        # which link to use
 44 |   
 45 |   for(k in 1:K){
 46 |     if (k==1) {
 47 |       ll[y==k] = pfun((cuts[k] - lp[y==k]), log = TRUE)
 48 |     }
 49 |     else if (k < K) {
 50 |       ll[y==k] = log(pfun(cuts[k] - lp[y==k]) - pfun(cuts[k-1] - lp[y==k]))
 51 |     }
 52 |     else {
 53 |       ll[y==k] = log(1 - pfun(cuts[k-1] - lp[y==k])) 
 54 |     }
 55 |   }
 56 |   
 57 |   -sum(ll)
 58 | }
 59 | ```
 60 | 
 61 | 
 62 | ## Estimation
 63 | 
 64 | ```{r ordinal-init}
 65 | init = c(-1, 1, 2, 0, 0)         # initial values
 66 | ```
 67 | 
 68 | ```{r ordinal-est}
 69 | fit_probit = optim(
 70 |   init,
 71 |   ordinal_ll,
 72 |   y = y,
 73 |   X = x,
 74 |   probit  = TRUE,
 75 |   control = list(reltol = 1e-10)
 76 | )
 77 | 
 78 | fit_logit  = optim(
 79 |   init,
 80 |   ordinal_ll,
 81 |   y = y,
 82 |   X = x,
 83 |   probit  = FALSE,
 84 |   control = list(reltol = 1e-10)
 85 | )
 86 | ```
 87 | 
 88 | 
 89 | 
 90 | 
 91 | ## Comparison
 92 | 
 93 | We can compare our results with the <span class="pack" style = "">ordinal</span> package.
 94 | 
 95 | ```{r ordinal-compare}
 96 | library(ordinal)
 97 | fit_ordpack_probit = clm(y ~ x1 + x2, data = d, link = 'probit')
 98 | fit_ordpack_logit  = clm(y ~ x1 + x2, data = d, link = 'logit')
 99 | ```
100 | 
101 | 
102 | ```{r ordinal-compare-show, echo=FALSE}
103 | resprobit = data.frame(method = c('ordinal_ll', 'ordpack'),
104 |                        rbind(coef(fit_probit), coef(fit_ordpack_probit)))
105 | colnames(resprobit) = c('method', paste0('cut_', 1:3), 'beta1', 'beta2')
106 | 
107 | 
108 | 
109 | reslogit = data.frame(method = c('ordinal_ll', 'ordpack'),
110 |                       rbind(coef(fit_logit), coef(fit_ordpack_logit)))
111 | colnames(reslogit) = c('method', paste0('cut_', 1:3), 'beta1', 'beta2')
112 | 
113 | bind_rows(list(probit = resprobit, logit = reslogit), .id = '') %>% 
114 |   kable_df()
115 | ```
116 | 
117 | 
118 | 
119 | 
120 | ## Source
121 | 
122 | Original code available at https://github.com/m-clark/Miscellaneous-R-Code/blob/master/ModelFitting/ordinal_regression.R
123 | 


--------------------------------------------------------------------------------
/probit.Rmd:
--------------------------------------------------------------------------------
  1 | # Probit & Bivariate Probit
  2 | 
  3 | Stata users seem to be the primary audience concerned with probit models, but I
  4 | thought I'd play around with one even though I've never had reason to use it.
  5 | Stata examples come from the UCLA ATS website and the Stata manual, so one can
  6 | investigate the Stata result for comparison.
  7 | 
  8 | ## Standard Probit
  9 | 
 10 | The standard probit model is identical to the [logistic model][Logistic
 11 | Regression] but using a different link function.
 12 | 
 13 | ### Function
 14 | 
 15 | ```{r probit_ll}
 16 | probit_ll <- function(beta, X, y) {
 17 |   mu = X %*% beta
 18 |   
 19 |   # these produce identical results, but the second is the typical depiction
 20 |   ll = sum(dbinom(
 21 |     y,
 22 |     size = 1,
 23 |     prob = pnorm(mu),
 24 |     log = T
 25 |   ))
 26 |   
 27 |   # ll = sum(y * pnorm(mu, log = T) + (1 - y) * log(1 - pnorm(mu)))
 28 |   
 29 |   -ll
 30 | }
 31 | ```
 32 | 
 33 | 
 34 | ### Examples
 35 | 
 36 | Example 1 detail available [here](https://stats.idre.ucla.edu/stata/dae/probit-regression/).
 37 | 
 38 | ```{r probit-example-1}
 39 | library(tidyverse)
 40 | 
 41 | admit = haven::read_dta('https://stats.idre.ucla.edu/stat/stata/dae/binary.dta')
 42 | 
 43 | head(admit)
 44 | 
 45 | X = model.matrix(admit~ gre + gpa + factor(rank), admit)
 46 | y = admit$admit
 47 | 
 48 | init = rep(0, ncol(X))
 49 | 
 50 | fit = optim(
 51 |   fn  = probit_ll,
 52 |   par = init,
 53 |   X   = X,
 54 |   y   = y,
 55 |   method = 'BFGS'
 56 | )
 57 | 
 58 | fit 
 59 | ```
 60 | 
 61 | 
 62 | 
 63 | 
 64 | Example 2 from Stata manual on [standard probit](http://www.stata.com/manuals13/rprobit.pdf).
 65 | 
 66 | > We have data on the make, weight, and mileage rating of 22 foreign and 52 domestic automobiles. We wish to fit a probit model explaining whether a car is foreign based on its weight and mileage."
 67 | 
 68 | ```{r probit-example-2}
 69 | auto = haven::read_dta('http://www.stata-press.com/data/r13/auto.dta')
 70 | 
 71 | head(auto)
 72 | 
 73 | X = model.matrix(foreign~ weight + mpg, auto)
 74 | y = auto$foreign
 75 | 
 76 | init = rep(0, ncol(X))
 77 | 
 78 | fit = optim(
 79 |   fn  = probit_ll,
 80 |   par = init,
 81 |   X = X,
 82 |   y = y
 83 | )
 84 | 
 85 | fit
 86 | ```
 87 | 
 88 | 
 89 | 
 90 | ## Bivariate Probit
 91 | 
 92 | For the bivariate model, we are dealing with two binary outcomes and their correlation.
 93 | 
 94 | 
 95 | Here is the main function.
 96 | 
 97 | ```{r bivariate_probit_ll}
 98 | bivariate_probit_ll <- function(pars, X, y1, y2) {
 99 |   rho = pars[1]
100 |   mu1 = X %*% pars[2:(ncol(X) + 1)]
101 |   mu2 = X %*% pars[(ncol(X) + 2):length(pars)]
102 |   q1  = ifelse(y1 == 1, 1,-1)
103 |   q2  = ifelse(y2 == 1, 1,-1)
104 |   
105 |   require(mnormt)
106 |   eta1 = q1 * mu1
107 |   eta2 = q2 * mu2
108 |   
109 |   ll = matrix(NA, nrow = nrow(X))
110 |   
111 |   for (i in 1:length(ll)) {
112 |     corr = q1[i] * q2[i] * rho
113 |     corr = matrix(c(1, corr, corr, 1), 2)
114 |     ll[i] = log(
115 |       pmnorm(
116 |         x = c(eta1[i], eta2[i]),
117 |         mean   = c(0, 0),
118 |         varcov = corr
119 |       )
120 |     )
121 |   }
122 |   
123 |   # the loop is probably clearer, and there is no difference in time, but here's
124 |   # a oneliner ll = mapply(function(e1, e2, q1, q2) log(pmnorm(x = c(e1, e2),
125 |   # varcov = matrix(c(1,q1*q2*rho,q1*q2*rho,1),2))), eta1, eta2, q1, q2)
126 |   
127 |   -sum(ll)
128 | }
129 | ```
130 | 
131 | 
132 | 
133 | 
134 | ### Example 
135 | 
136 | From the Stata manual on bivariate probit:
137 | 
138 | > We wish to model the bivariate outcomes of whether children attend private 
139 | school and whether the head of the household voted for an increase in property
140 | tax based on the other covariates.
141 | 
142 | ```{r probit-example-3}
143 | school = haven::read_dta('http://www.stata-press.com/data/r13/school.dta')
144 | 
145 | head(school)
146 | 
147 | X  = model.matrix(private ~ years + logptax + loginc, school)
148 | y1 = school$private
149 | y2 = school$vote
150 | 
151 | init = c(0, rep(0, ncol(X)*2))
152 | 
153 | # you'll probably get a warning or two, ignore; takes a couple seconds
154 | fit = optim(
155 |   fn  = bivariate_probit_ll,
156 |   par = init,
157 |   X   = X,
158 |   y1  = y1,
159 |   y2  = y2,
160 |   method = 'BFGS'
161 | )
162 | 
163 | 
164 | loglik = fit$value
165 | rho    = fit$par[1]
166 | coefs_private = fit$par[2:(ncol(X) + 1)]
167 | coefs_vote = fit$par[(ncol(X) + 2):length(init)]
168 | names(coefs_private) = names(coefs_vote) = c('Int', 'years', 'logptax', 'loginc')
169 | 
170 | list(
171 |   loglik  = loglik,
172 |   rho     = rho,
173 |   Private = coefs_private,
174 |   Vote    = coefs_vote
175 | )
176 | ```
177 | 
178 | 
179 | 
180 | 
181 | ## Source
182 | 
183 | Original code available at https://github.com/m-clark/Miscellaneous-R-Code/blob/master/ModelFitting/bivariateProbit.R
184 | 


--------------------------------------------------------------------------------
/quantile-regression.Rmd:
--------------------------------------------------------------------------------
  1 | 
  2 | # Quantile Regression
  3 | 
  4 | ## Data Setup
  5 | 
  6 | We'll use the <span class="pack" style = "">quantreg</span> package for comparison, and the classic data set on Belgian household income and food expenditure.  Scale income if you want a meaningful 'centercept'.
  7 | 
  8 | ```{r qr-setup}
  9 | library(tidyverse)
 10 | 
 11 | library(quantreg)
 12 | 
 13 | data(engel)          
 14 | # engel$income = scale(engel$income)
 15 | 
 16 | X = cbind(1, engel$income)
 17 | colnames(X) = c('Intercept', 'income')
 18 | ```
 19 | 
 20 | ## Function
 21 | 
 22 | Loss function.  It really is this simple.
 23 | 
 24 | ```{r qr-func}
 25 | qreg <- function(par, X, y, tau) {
 26 |   lp = X%*%par
 27 |   res = y - lp
 28 |   loss = ifelse(res < 0 , -(1 - tau)*res, tau*res)
 29 |   sum(loss)
 30 | }
 31 | ```
 32 | 
 33 | ## Estimation
 34 | 
 35 | We'll estimate the median to start. Compare `optim` output with <span class="pack" style = "">quantreg</span> package.
 36 | 
 37 | ```{r qr-est}
 38 | optim(
 39 |   par = c(intercept = 0, income = 0),
 40 |   fn  = qreg,
 41 |   X   = X,
 42 |   y   = engel$foodexp,
 43 |   tau = .5
 44 | )$par
 45 | 
 46 | rq(foodexp ~ income, tau = .5, data = engel)
 47 | ```
 48 | 
 49 | 
 50 | ### Other quantiles
 51 | 
 52 | Now we will add additional quantiles to estimate.
 53 | 
 54 | ```{r qr-quants}
 55 | # quantiles
 56 | qs = c(.05, .1, .25, .5, .75, .9, .95)
 57 | 
 58 | fit_rq = coef(rq(foodexp ~ income, tau = qs, data = engel))
 59 | 
 60 | fit_qreg = map_df(qs, function(tau)
 61 |   data.frame(t(
 62 |     optim(
 63 |       par = c(intercept = 0, income = 0),
 64 |       fn  = qreg,
 65 |       X   = X,
 66 |       y   = engel$foodexp,
 67 |       tau = tau
 68 |     )$par
 69 |   )))
 70 | ```
 71 | 
 72 | 
 73 | ## Comparison
 74 | 
 75 | Compare results.
 76 | 
 77 | ```{r qr-compare, echo =FALSE}
 78 | rbind(fit_rq, t(fit_qreg)) %>% 
 79 |   as.data.frame() %>% 
 80 |   rownames_to_column('coef') %>% 
 81 |   mutate(` ` = rep(c('fit_rq', 'fit_qreg'), each = 2)) %>% 
 82 |   select(` `, everything()) %>% 
 83 |   kable_df()
 84 | ```
 85 | 
 86 | 
 87 | ## Visualize
 88 | 
 89 | Let's visualize the results.
 90 | 
 91 | ```{r qr-vis, echo=FALSE}
 92 | engel %>%
 93 |   qplot(data = .,
 94 |         income,
 95 |         foodexp,
 96 |         color = I(scales::alpha('orange', .25))) +
 97 |   geom_abline(aes(
 98 |     intercept = intercept,
 99 |     slope = income,
100 |     color = group
101 |   ),
102 |   data = data.frame(fit_qreg, group = factor(qs))) +
103 |   scico::scale_color_scico_d(palette = 'vik')
104 | ```
105 | 
106 | 
107 | ## Python
108 | 
109 | The above is available as a Python demo in the [supplemental section](#python-qreg).
110 | 
111 | ## Source
112 | 
113 | Original code available at https://github.com/m-clark/Miscellaneous-R-Code/blob/master/ModelFitting/quantile_regression.Rmd
114 | 


--------------------------------------------------------------------------------
/ridge.Rmd:
--------------------------------------------------------------------------------
  1 | ## L2 (ridge) regularization
  2 | 
  3 | 
  4 | Compare to the [lasso section][L1 (lasso) regularization]. 
  5 | 
  6 | ### Data Setup
  7 | 
  8 | ```{r ridge-setup}
  9 | library(tidyverse)
 10 | 
 11 | set.seed(8675309)
 12 | 
 13 | N = 500
 14 | p = 10
 15 | X = scale(matrix(rnorm(N * p), ncol = p))
 16 | b = c(.5, -.5, .25, -.25, .125, -.125, rep(0, 4))
 17 | y = scale(X %*% b + rnorm(N, sd = .5))
 18 | ```
 19 | 
 20 | 
 21 | 
 22 | ### Function
 23 | 
 24 | ```{r ridge-function}
 25 | ridge <- function(w, X, y, lambda = .1) {
 26 |   # X: model matrix; 
 27 |   # y: target; 
 28 |   # lambda: penalty parameter; 
 29 |   # w: the weights/coefficients
 30 |   
 31 |   crossprod(y - X %*% w) + lambda * length(y) * crossprod(w)
 32 | }
 33 | ```
 34 | 
 35 | 
 36 | 
 37 | ### Estimation
 38 | 
 39 | Note, if `lambda = 0`, i.e. no penalty, the result is the same as what you would get from the base R  <span class="func" style = "">lm.fit</span>.
 40 | 
 41 | ```{r ridge-est}
 42 | fit_ridge = optim(
 43 |   rep(0, ncol(X)),
 44 |   ridge,
 45 |   X = X,
 46 |   y = y,
 47 |   lambda = .1,
 48 |   method = 'BFGS'
 49 | )
 50 | ```
 51 | 
 52 | 
 53 | Analytical result.
 54 | 
 55 | ```{r ridge-analytical}
 56 | fit_ridge2 = solve(crossprod(X) + diag(length(y)*.1, ncol(X))) %*% crossprod(X, y)
 57 | ```
 58 | 
 59 | 
 60 | An alternative approach using 'augmented' data (note `sigma` is ignored as it equals 1, but otherwise
 61 | X/sigma and y/sigma).
 62 | 
 63 | 
 64 | ```{r ridge-augmented}
 65 | X2 = rbind(X, diag(sqrt(length(y)*.1), ncol(X)))
 66 | y2 = c(y, rep(0, ncol(X)))
 67 | 
 68 | tail(X2)
 69 | tail(y2)
 70 | 
 71 | fit_ridge3 = solve(crossprod(X2)) %*% crossprod(X2, y2)
 72 | ```
 73 | 
 74 | The <span class="pack" style = "">glmnet</span> approach is by default a mixture
 75 | of ridge and lasso penalties, setting `alpha = 1` reduces to lasso (`alpha = 0`
 76 | would be ridge). We set the lambda to a couple values while only wanting the one
 77 | set to the same lambda value as above (`s`).
 78 | 
 79 | ```{r ridge-glmnet}
 80 | library(glmnet)
 81 | 
 82 | fit_glmnet = coef(
 83 |   glmnet(
 84 |     X,
 85 |     y,
 86 |     alpha = 0,
 87 |     lambda = c(10, 1, .1),
 88 |     thresh = 1e-12,
 89 |     intercept = F
 90 |   ), 
 91 |   s = .1
 92 | )
 93 | 
 94 | ```
 95 | 
 96 | 
 97 | ### Comparison
 98 | 
 99 | We can now compare the coefficients of all our results.
100 | 
101 | ```{r ridge-compare, echo=FALSE}
102 | data.frame(
103 |   lm     = coef(lm(y ~ . - 1, data.frame(X))),
104 |   ridge  = fit_ridge$par,
105 |   ridge2 = fit_ridge2,
106 |   ridge3 = fit_ridge3,
107 |   glmnet = fit_glmnet[-1, 1],
108 |   truth  = b
109 | ) %>% 
110 |   kable_df()
111 | ```
112 | 
113 | 
114 | 
115 | ### Source
116 | 
117 | Original code available at https://github.com/m-clark/Miscellaneous-R-Code/blob/master/ModelFitting/ridge.R
118 | 


--------------------------------------------------------------------------------
/rkhs_supplemental.pdf:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/m-clark/models-by-example/b544c35a3fdd63baecee7f904469c1174862ced3/rkhs_supplemental.pdf


--------------------------------------------------------------------------------
/title_plot.R:
--------------------------------------------------------------------------------
  1 | 
  2 | # from the GP chapter
  3 | 
  4 | set.seed(1234)
  5 | 
  6 | library(tidyverse)
  7 | 
  8 | l = 1            # for l, sigma_f, sigma_n, see note at covariance function
  9 | sigma_f = 1      
 10 | sigma_n = .25 
 11 | k_eps   = 1e-8   # see note at Kstarstar
 12 | n_prior = 5      # number of prior draws
 13 | n_post_pred = 5  # number of posterior predictive draws
 14 | 
 15 | 
 16 | N = 25
 17 | X_train = 15 * (runif(N) - .5)  
 18 | n_train = length(X_train)
 19 | 
 20 | # kept sine function for comparison to noise free result
 21 | y_train = sin(X_train) + rnorm(n = n_train, sd = .1)  
 22 | 
 23 | X_test = seq(-7.5, 7.5, length = 200)
 24 | n_test = length(X_test)
 25 | 
 26 | gp_mu <- function(x) {
 27 |   map_dbl(x, function(x) x = 0)
 28 | }
 29 | 
 30 | gp_K <- function(
 31 |   x,
 32 |   y = NULL,
 33 |   l = 1,
 34 |   sigma_f = 1,
 35 |   sigma_n = .5
 36 | ) {
 37 |   
 38 |   if(!is.null(y)){
 39 |     sigma_f * exp( -(1/(2 * l^2)) * as.matrix(dist(x, upper = TRUE, diag = TRUE) ^ 2) ) +
 40 |       sigma_n*diag(length(x))    
 41 |   }
 42 |   else{
 43 |     sigma_f * exp( -(1/(2 * l^2)) * as.matrix(dist(x, upper = TRUE, diag = TRUE) ^ 2) )
 44 |   }  
 45 | }
 46 | 
 47 | Ky = gp_K(
 48 |   x = X_train,
 49 |   y = y_train,
 50 |   l = l,
 51 |   sigma_f = sigma_f,
 52 |   sigma_n = sigma_n
 53 | )
 54 | 
 55 | # initial matrix
 56 | K_ = gp_K(
 57 |   c(X_train, X_test),
 58 |   l = l,
 59 |   sigma_f = sigma_f,
 60 |   sigma_n = sigma_n
 61 | )
 62 | 
 63 | Kstar  = K_[1:n_train, (n_train+1):ncol(K_)]                    # dim = N x N*
 64 | tKstar = t(Kstar)                                               # dim = N* x N
 65 | Kstarstar = K_[(n_train+1):nrow(K_), (n_train+1):ncol(K_)] +    # dim = N* x N*
 66 |   k_eps*diag(n_test)      # the k_eps part is for positive definiteness
 67 | 
 68 | Kyinv = solve(Ky)
 69 | 
 70 | post_mu = gp_mu(X_test) + tKstar %*% Kyinv %*% (y_train - gp_mu(X_train))
 71 | post_K  = Kstarstar - tKstar %*% Kyinv %*% Kstar
 72 | s2 = diag(post_K)
 73 | 
 74 | 
 75 | y_pp = data.frame(t(MASS::mvrnorm(n_post_pred, mu = post_mu, Sigma = post_K)))
 76 | 
 77 | pp_data = data.frame(
 78 |   x = X_test,
 79 |   y = y_pp,
 80 |   fmean = post_mu, 
 81 |   se_lower = post_mu - 2 * sqrt(s2),
 82 |   se_upper = post_mu + 2 * sqrt(s2)
 83 | ) %>% 
 84 |   pivot_longer(starts_with('y'), names_to = 'variable')
 85 | 
 86 | 
 87 | ggplot(aes(x = x, y = value), data = pp_data) +
 88 |   geom_ribbon(aes(ymin = se_lower, ymax = se_upper, group = variable),
 89 |               fill = 'gray95') +
 90 |   geom_line(aes(group = variable), color = '#ff550040', size = .5) +
 91 |   geom_point(
 92 |     aes(x = X_train, y = y_train),
 93 |     data = data.frame(X_train, y_train),
 94 |     color = '#00aaff80',
 95 |     size = 2
 96 |   ) +
 97 |   labs(x = '', y = '') +
 98 |   theme_void()
 99 | 
100 | ggsave('img/title_plot.svg',  bg = "transparent")
101 | ggsave('img/title_plot.png',  bg = "transparent")
102 | 


--------------------------------------------------------------------------------
/tobit.Rmd:
--------------------------------------------------------------------------------
  1 | # Tobit Regression
  2 | 
  3 | 
  4 | The following is a simple demonstration of tobit regression via maximum
  5 | likelihood. The issue is one where data is censored such that while we observe
  6 | the value, it is not the true value, which would extend beyond the range of the
  7 | observed data. This is very commonly seen in cases where the dependent variable
  8 | has been given some arbitrary cutoff at the lower or upper end of the range,
  9 | often resulting in floor or ceiling effects respectively. The conceptual idea is
 10 | that we are interested in modeling the underlying latent variable that would not
 11 | have such restriction if it was actually observed.
 12 | 
 13 | 
 14 | ## Censoring with an Upper Limit
 15 | 
 16 | ### Data Setup 
 17 | 
 18 | Data regards academic aptitude (GRE scores) with will be modeled using reading
 19 | and math test scores, as well as the type of program the student is enrolled in
 20 | (academic, general, or vocational).  See
 21 | [this](https://stats.idre.ucla.edu/r/dae/tobit-models/) for an applied example
 22 | and more detail.
 23 | 
 24 | ```{r tobit-setup}
 25 | library(tidyverse)
 26 | 
 27 | acad_apt = read_csv("https://stats.idre.ucla.edu/stat/data/tobit.csv") %>%
 28 |   mutate(prog = factor(prog, labels = c('acad', 'general', 'vocational')))
 29 | ```
 30 | 
 31 | 
 32 | Setup data and initial values.
 33 | 
 34 | ```{r tobit-initial}
 35 | initmod = lm(apt ~ read + math + prog, data = acad_apt)
 36 | X = model.matrix(initmod)
 37 | init = c(coef(initmod), log_sigma = log(summary(initmod)$sigma))
 38 | ```
 39 | 
 40 | 
 41 | ### Function
 42 | 
 43 | ```{r tobit-ll}
 44 | tobit_ll <- function(par, X, y, ul = -Inf, ll = Inf) {
 45 |   
 46 |   # this function only takes a lower OR upper limit
 47 |   
 48 |   # parameters
 49 |   sigma = exp(par[length(par)]) 
 50 |   beta  = par[-length(par)]
 51 |   
 52 |   # create indicator depending on chosen limit
 53 |   if (!is.infinite(ll)) {
 54 |     limit = ll
 55 |     indicator = y > ll
 56 |   } else {
 57 |     limit = ul
 58 |     indicator = y < ul
 59 |   }
 60 |   
 61 |   # linear predictor
 62 |   lp = X %*% beta
 63 |   
 64 |   # log likelihood
 65 |   ll = sum(indicator * log((1/sigma)*dnorm((y-lp)/sigma)) ) + 
 66 |     sum((1-indicator) * log(pnorm((lp-limit)/sigma, lower = is.infinite(ll))))
 67 |   
 68 |   -ll
 69 | }
 70 | ```
 71 | 
 72 | ### Estimation
 73 | 
 74 | Estimate via <span class="func" style = "">optim</span>.
 75 | 
 76 | ```{r tobit-estimate}
 77 | fit_tobit = optim(
 78 |   par = init,
 79 |   tobit_ll,
 80 |   y  = acad_apt$apt,
 81 |   X  = X,
 82 |   ul = 800,
 83 |   method  = 'BFGS',
 84 |   control = list(maxit = 2000, reltol = 1e-15)
 85 | )
 86 | 
 87 | 
 88 | # this would be more akin to the default Stata default approach
 89 | # optim(
 90 | #   par = init,
 91 | #   tobit_ll,
 92 | #   y = acad_apt$apt,
 93 | #   X = X,
 94 | #   ul = 800,
 95 | #   control = list(maxit = 16000, reltol = 1e-15)
 96 | # )
 97 | ```
 98 | 
 99 | 
100 | 
101 | ### Comparison
102 | 
103 | Compare to <span class="pack" style = "">AER</span> package tobit function.
104 | 
105 | ```{r tobit-compare-aer}
106 | library(survival)
107 | 
108 | fit_aer = AER::tobit(
109 |   apt ~ read + math + prog,
110 |   data = acad_apt,
111 |   left = -Inf,
112 |   right = 800
113 | )
114 | ```
115 | 
116 | 
117 | ```{r tobit-compare-aer-show, echo=FALSE}
118 | rbind(
119 |   fit_tobit = c(
120 |     fit_tobit$par[1:5],
121 |     sigma   = exp(fit_tobit$par[6]),
122 |     logLike = -fit_tobit$value
123 |   ),
124 |   AER = c(coef(fit_aer), fit_aer$scale, logLik(fit_aer))
125 | ) %>% 
126 |   kable_df()
127 | ```
128 | 
129 | 
130 | ```{r tobit-compare-aer}
131 | ```
132 | 
133 | 
134 | <span class="pack" style = "">AER</span> is actually just using <span
135 | class="func" style = "">survreg</span> from the <span class="pack" style =
136 | "">survival</span> package. Survival models are usually for modeling time to
137 | some event, e.g. death in medical studies, and the censoring comes from the fact
138 | that the observed event does not occur for some people. Like our tobit function,
139 | an indicator is needed to denote who is or isn't censored. In survival models,
140 | the indicator is for the event itself, and means they are NOT censored.  So
141 | we'll reverse the indicator used in the tobit function for <span class="func"
142 | style = "">survreg</span>.
143 | 
144 | ```{r tobit-surv}
145 | fit_surv = survreg(Surv(apt, apt < 800, type = 'right') ~ read + math + prog,
146 |                    data = acad_apt,
147 |                    dist = 'gaussian')
148 | ```
149 | 
150 | 
151 | Compare all results.
152 | 
153 | ```{r tobit-compare-surv, echo=FALSE}
154 | rbind(
155 |   fit_tobit = c(
156 |     fit_tobit$par[1:5],
157 |     sigma = exp(fit_tobit$par[6]),
158 |     logLike = -fit_tobit$value
159 |   ),
160 |   AER      = c(coef(fit_aer), fit_aer$scale, logLik(fit_aer)),
161 |   survival = c(coef(fit_surv), fit_surv$scale, logLik(fit_surv))
162 | ) %>% 
163 |   kable_df()
164 | ```
165 | 
166 | 
167 | 
168 | 
169 | 
170 | ## Censoring with a Lower Limit
171 | 
172 | Create a censored data situation for the low end.  The scale itself would be censored for anyone scoring a 200, but that basically doesn't happen. In this data, 15 are less than a score of 500, so we'll do that.
173 | 
174 | ```{r tobit-ll-setup}
175 | acad_apt = acad_apt %>%
176 |   mutate(apt2 = apt,
177 |          apt2 = if_else(apt2 < 500, 500, apt2))
178 | ```
179 | 
180 | Estimate and use <span class="pack" style = "">AER</span> for comparison.
181 | 
182 | ```{r tobit-ll-est}
183 | fit_tobit = optim(
184 |   par = init,
185 |   tobit_ll,
186 |   y  = acad_apt$apt2,
187 |   X  = X,
188 |   ll = 400,
189 |   method  = 'BFGS',
190 |   control = list(maxit = 2000, reltol = 1e-15)
191 | )
192 | 
193 | fit_aer = AER::tobit(apt2 ~ read + math + prog,
194 |                      data = acad_apt,
195 |                      left = 400)
196 | ```
197 | 
198 | 
199 | ### Comparison
200 | 
201 | ```{r tobit-ll-compare, echo=FALSE}
202 | rbind(
203 |   fit_tobit = c(
204 |     fit_tobit$par[1:5],
205 |     sigma   = exp(fit_tobit$par[6]),
206 |     logLike = -fit_tobit$value
207 |   ),
208 |   AER = c(coef(fit_aer), fit_aer$scale, logLik(fit_aer))
209 | ) %>% 
210 |   kable_df()
211 | ```
212 | 
213 | ## Source
214 | 
215 | Original code available at https://github.com/m-clark/Miscellaneous-R-Code/blob/master/ModelFitting/tobit.R
216 | 


--------------------------------------------------------------------------------