-
Notifications
You must be signed in to change notification settings - Fork 1
/
ZooarchMixMod Model Supplement.Rmd
888 lines (779 loc) · 84.7 KB
/
ZooarchMixMod Model Supplement.Rmd
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
---
title: "**MODEL SUPPLEMENT: A BAYESIAN MULTILEVEL MIXTURE MODEL FOR ZOOARCHAEOLOGICAL MEASUREMENTS**"
author:
- "Jesse Wolfhagen^1,2^"
- ^1^Department of Anthropology, Purdue University, West Lafayette, Indiana, USA
- ^2^Department of Archaeology, Max Planck Institute for Geoanthropology, Jena, Germany
- " "
- "email: jl.wolfhagen@gmail.com"
date:
- " "
- " "
- "*R Markdown version last compiled on `r lubridate::today()`*"
indent: yes
header-includes:
- \usepackage{setspace}\doublespacing
- \usepackage[labelfont=bf,width=1\textwidth,justification=raggedright,singlelinecheck=false]{caption}
- \captionsetup[figure]{labelfont=bf}
- \usepackage[left]{lineno}
output:
pdf_document:
latex_engine: xelatex
keep_md: false
word_document: default
html_document: default
link-citations: yes
bibliography: zooarch_mixmod_library.bib
---
```{r supplement setup, include=FALSE}
knitr::opts_chunk$set(echo = TRUE, warning = FALSE, message = FALSE)
options(kableExtra.auto_format = FALSE)
library("boot")
library("Cairo")
library("cmdstanr")
library("data.table")
library("doParallel")
library("ggdist")
library("ggplot2")
library("ggpubr")
library("ggrepel")
library("kableExtra")
library("knitr")
library("mixtools")
library("parallel")
library("readxl")
library("rnaturalearth")
library("rnaturalearthdata")
library("rstan")
library("sf")
library("zoolog")
#setting resources to do simulations with multicore processing (on Windows)
num_cores <- detectCores(logical = T)
cl <- makeCluster(num_cores - 4) #creating a virtual cluster
registerDoParallel(cl) #registering the cluster
```
\newpage
# *Model Supplement: A Bayesian Multilevel Mixture Model for Zooarchaeological Measurements*
The Bayesian model developed for this paper describes assemblages of faunal measurements as a mixture of immature animals, (adult-sized) females, and (adult-sized) males that have distinct average body sizes and expected variation around that average size. The model uses multiple measured dimensions [e.g., humerus distal breadth "humerus Bd", radius proximal breadth "radius Bp", abbreviations following @vondendriesch_1976], which are first converted into a logarithmic size index, or LSI, values with a natural logarithm base [@meadow_1999; @wolfhagen_2020]. LSI observations from measurement sets are grouped together within a specimen to create individuals grouped into defined “element portions” that serve as the basis for the mixture model analysis. Element portions relate to categories used for element fusion (e.g., distal humerus) to relate biometry and mortality profiles; specimens that contain multiple element portions—like complete limb bones—are grouped into the latest-fusing element portion [compare to "skeletal part type" in @breslawski_2023].
The multilevel structure of the model uses partial pooling to allow the parameters of the mixture model to vary between element portions while resisting overfitting. These element portion-specific parameters are related to each other through hyper-parameters, which describe the average value of the model parameters and the variability of model parameters across element portions [@wolfhagen_2020]. The following sections describe the details of the multilevel mixture model, including the model’s likelihood, the ways that the direct observations of measurements and demographic data are used by the model to account for measurement error, and the development of prior distributions for the model’s hyper-parameters and for parameters that govern the model’s multilevel structure. Finally, this supplement provides the full sets of equations for the single-site and multisite Bayesian multilevel mixture models and the prior distribution definitions used in the model applications described in the main text.
## *1. Definition of the Bayesian Multilevel Model*
The central likelihood of the mixture model uses parameters that are specific to each element portion. These parameters include the relative proportions for the different animal groups: immature animals, females, and males ($\pi_{1}$, $\pi_{2}$, $\pi_{3}$), the average size for each group ($\mu_{1}$, $\mu_{2}$, $\mu_{3}$), and the standard deviation for each group ($\sigma_{1}$, $\sigma_{2}$, $\sigma_{3}$). For each element portion, immature animals are described with the first set of parameters ($\pi_{1}$, $\mu_{1}$, $\sigma_{1}$), adult-sized females with the second set of parameters ($\pi_{2}$, $\mu_{2}$, $\sigma_{2}$), and adult-sized males with the third set of parameters ($\pi_{3}$, $\mu_{3}$, $\sigma_{3}$). This results in both a set of parameters that describe the composition of the assemblage (of measurements from that element portion) and an equation to estimate the probability that a particular specimen comes from an immature, adult female, or adult male individual.
*Mixture Model Likelihood Equation:*
\begin{equation}
\begin{split}
P(x|\pi_1,\pi_2,\pi_3,\mu_1,\mu_2,\mu_3,\sigma_1,\sigma_2,\sigma_3) = \\
& \pi_1 * \operatorname{Normal}(x, \mu_1, \sigma_1) + \\
& \pi_2 * \operatorname{Normal}(x, \mu_2, \sigma_2) + \\
& \pi_3 * \operatorname{Normal}(x, \mu_3, \sigma_3)
\end{split}
\end{equation}
In addition to a specimen’s LSI value, the model needs two additional observed variables to address the potential presence of immature animals in the assemblage. First, an indicator variable $\operatorname{Immature}[\operatorname{specimen}]$ describes whether the specimen could be from an immature animal based on the body part and the fusion characteristics (1 = potentially immature, 0 = cannot be immature). Data from known-age Shetland sheep show that specimens killed at younger than one year of age are significantly smaller than those killed at older ages, regardless of fusion status [@popkin_etal_2012]. Thus, any measurement from an element with an unfused epiphysis or from an element that does not fuse or could fuse before one year of age is considered potentially immature. Measurements from specimens with fused epiphyses that fuse after one year of age are considered ineligible to be immature, so the model does not consider that probability (it considers $\pi_{1}$ = 0 for fitting that specimen).
Second, the proportion of specimens from an element portion that could be immature ($\operatorname{proportion}_{\operatorname{immature}}$) determines how to re-weight the mixture components ($\pi_1$, $\pi_2$, and $\pi_3$) for potentially-immature specimens from that element portion. The mixture components describe the entire assemblage for an element portion (a combination of potentially-immature and non-immature specimens), meaning that if $\pi_{1}$ = 0.25 we should expect 25% of the specimens to be from immature animals. If every specimen could be immature—say, for specimens from an early-fusing element—then the mixture components do not need to be re-weighted. If, however, only half of the specimens could be immature, then the mixture components must be re-weighted to ensure that the whole-assemblage proportions are correct. In such a case, we would expect half of the potentially-immature animals to be from immature animals if $\pi_{1}$ = 0.25 for the whole assemblage and we know that $\operatorname{proportion}_{\operatorname{immature}}$ = $\left( \tfrac {0.25}{0.50} = 0.50 \right)$; this same re-weighting would make it less likely that potentially-immature animals are from adult-sized female or adult-sized male animals. The code includes checks to ensure that $\pi_{1}$ can never exceed 1.00 after accounting for the proportion of immature specimens in cases where there are very few potentially-immature specimens and/or a relatively high expected proportion of immature animals in the assemblage.
## *2. Measurement Error and Observations*
The model estimates measurement error for different observed quantities that are input into the model. Measurements on both the archaeological specimens and the standard values used to calculate LSI values are assumed to have a 1% measurement error [@breslawski_byers_2015; @popkin_etal_2012: Figure 6]. This 1% value comes from an evaluation of the @breslawski_byers_2015 measurement data, where the average standard deviation of repeated measurements on bison radius proximal breadth measurements was 1.1% the average value of the measurement. This means that each measurement is given a standard deviation based on the observed value, which is used to estimate the “modeled” measurement value based on the observation. These modeled measurements are then used to calculate the LSI value for that observation ($\operatorname{LSI}_{\operatorname{Measurement}}$).
Because specimens can have multiple measured dimensions that are included in the mixture model on them (e.g., a distal humerus with both Bd and BT observations or a complete radius with Bp and Bd observations), the mixture model calculates specimen-specific LSI values ($\operatorname{LSI}_{\operatorname{Specimen}}$) that are related to the observed measurement-specific LSI values ($\operatorname{LSI}_{\operatorname{Measurement}}$). $\operatorname{LSI}_{\operatorname{Measurement}}$ values are the “observations” with a standard deviation of 0.01 (in $\operatorname{LSI}_e$ scale) based on intra-individual variation of $\operatorname{LSI}_e$ values for the @popkin_etal_2012 sheep using the *Ovis orientalis* female standard animal (FMC 57951) from Uerpmann and Uerpmann [-@uerpmann_uerpmann_1994, Table 12].
*Observation Error Equations for Measurements:*
\begin{equation}
\begin{split}
\sigma_{\operatorname{measurement}} & = \operatorname{Measurement}_{\operatorname{observed}} * 0.01 \\
\operatorname{Measurement}_{\operatorname{observed}} & \sim \operatorname{Normal}(\operatorname{Measurement}_{\operatorname{modeled}}, \sigma_{\operatorname{measurement}}) \\
\sigma_{\operatorname{reference}} & = \operatorname{Reference}_{\operatorname{observed}} * 0.01 \\
\operatorname{Reference}_{\operatorname{observed}} & \sim \operatorname{Normal}(\operatorname{Reference}_{\operatorname{modeled}}, \sigma_{\operatorname{reference}}) \\
\operatorname{LSI}_{\operatorname{measurement}} & = \log_e(\operatorname{Measurement}_{\operatorname{modeled}}) - \log_e(\operatorname{Reference}_{\operatorname{modeled}}) \\
\operatorname{LSI}_{\operatorname{measurement}} & \sim \operatorname{Normal}(\operatorname{LSI}_{\operatorname{specimen}}, 0.01)
\end{split}
\end{equation}
The model also uses observations of sex ratios and fusion rates to estimate assemblage-level demographic proportions. This allows relevant data to inform the model about the expected relative proportions of different animal groups while still allowing these proportions to vary across different element portions. These observations are interpreted as binomial data: counts of some quantity (e.g., immature specimens) out of a total count of relevant specimens (e.g., total ageable specimens); this approach lets the model incorporate the uncertainty caused by small sample sizes. The observation of the average proportion of immature specimens ($\mu_{\pi_{1}}$) is based on the fusion rate of proximal and middle phalanges (the number of unfused phalanges $\operatorname{N}_{\operatorname{Unfused}}$ out of the total number of phalanges with fusion data $\operatorname{N}_{\operatorname{Ageable}}$), which fuse at around the same time as the estimated time that animals reach adult body size in the Shetland sheep population [@popkin_etal_2012]. The observation of the average adult sex ratio—the proportion of females among mature animals $\left( \tfrac {\mu_{\pi_2}}{\mu_{\pi_2} + \mu_{\pi_3}} \right)$—is based on the sex ratio of fused pelvises (the number of female pelvises $\operatorname{N}_{\operatorname{Female}}$ out of the total number of pelvises with a sex assignment $\operatorname{N}_{\operatorname{Sexable}}$). In each case, the number of observable specimens determines the measurement error using the binomial distribution. While this paper uses these quantities to estimate the relevant hyper-parameters, relevant observations from other elements can be incorporated into the model in the same fashion if there is a clear sense of the total number of specimens that could have potentially been immature or female.
*Observation Error Equations for Demographic Estimates:*
\begin{equation}
\begin{split}
N_{\operatorname{unfused}} & \sim \operatorname{Binomial}(N_{\operatorname{ageable}}, \mu_{\pi_1}) \\
N_{\operatorname{female}} & \sim \operatorname{Binomial}(N_{\operatorname{sexable}}, \dfrac{\mu_{\pi_2}} {\mu_{\pi_2} + \mu_{\pi_3}})
\end{split}
\end{equation}
## *3. Prior Distributions*
The prior distributions in this model are focused on describing previous beliefs about the value of the mixture model hyper-parameters, as the element portion-specific parameters are derived from these distributions. Mixture modeling performs well with unconstrained parameters values because it is more straightforward to estimate variation across element portions, meaning that constrained parameters-those where the range of possible values depends on the values of other parameters—must first be transformed into related unconstrained parameters [@betancourt_2017] . The following sub-sections describe the necessary transformations for different sets of the mixture model parameters, describing the unconstrained parameters that can be modeled and the transformations that result in the mixture model parameters. While these sections use the mixture model parameter notations, prior distributions are for the ‘central tendency’ hyper-parameter for the described unconstrained parameter.
It is important to remember that for all of these prior distributions are arbitrary choices made by the researcher, regardless of whether the distributions are based on specific animal populations or on reference priors. Other researchers could and should use different prior distributions to best reflect their intuition about likely parameter values for particular case studies. This also highlight the importance of reporting the prior distributions used in a Bayesian analysis to ensure replicability. Examining the implications of different prior distributions is an important step in the development of Bayesian models, one that should be regularly tested even before models are fit to datasets [@gelman_etal_2020_workflow].
### *3.1 Mixture Proportion Priors*
Prior distributions for the mixture proportions reflect our prior beliefs about the relative proportions of the three animal groups in the assemblage (immature, adult-sized females, and adult-sized males). The three mixture proportions ($\pi_{1}$, $\pi_{2}$, $\pi_{3}$) are a three-value unit simplex, meaning that the values are constrained as a group to sum up to one. Thus, the simplex can be described by only two variables because the third value cannot vary once those two values are known. The model uses two unconstrained variables ($\theta_{1}$ and $\theta_{2}$) to describe the $\pi$ values. These $\theta$ values are related back to $\pi$ values using a ‘stick-breaking’ transformation that iteratively estimates the relative proportions of the simplex taken up by each $\theta$ value [@stan_language_2.29: Section 10.7].
*Stick-Breaking Transformations:*
\begin{equation}
\begin{split}
\pi_1 & = \operatorname{logit}^{-1}(\theta_1 + \log(0.5)) \\
\pi_2 & = (1 - \pi_1) * \operatorname{logit}^{-1}(\theta_2 + \log(1)) \\
\pi_3 & = 1 - (\pi_1 + \pi_2)
\end{split}
\end{equation}
The $\theta_{1}$ value can be directly related to the $\pi_{1}$ value using the first line of the stick-breaking transformation, meaning that one can examine the associated $\pi_{1}$ estimate for a given $\theta_{1}$ value. Within the stick-breaking transformation, $\theta_{2}$ relates to the relative proportions of $\pi_{2}$ and $\pi_{3}$ after $\pi_{1}$ has been estimated, which is effectively the adult sex ratio. Just as we could examine the expected $\pi_{1}$ estimates from a distribution of $\theta_{1}$ values, we can thus use expected adult sex ratios $\left( \tfrac {\pi_2}{\pi_2 + \pi_3} \right)$ estimates from a particular prior distribution for $\theta_{2}$. Relating these $\theta$ values back to observable phenomena makes it easier to define reasonable prior distribution definitions for the parameters from domain expertise (see Section 2.2 and Figure 2 of the main text).
### *3.2 Average Body Size and Size Variability Priors*
While the average body sizes of the different components ($\mu_{1}$, $\mu_{2}$, $\mu_{3}$) are not intrinsically linked in the same way that $\pi$ values are, the model still requires some structure to aid interpretability. Bayesian mixture models that are fit using Markov Chain Monte Carlo (MCMC) methods, like the model in this paper, can suffer from an issue called “label switching” if $\mu$ values are not ordered in some way [@jasra_etal_2005]. MCMC methods rely on running multiple “chains”—separate iterations of the model that are independently fit and then combined together—to show that the results are independent of the initial conditions. Label switching describes a scenario where different chains fit the data well, but the parameter labels relate to different specimens (e.g., smaller specimens are assigned to $\mu_{1}$ in one chain and to $\mu_{2}$ in another). To avoid label switching, the average body sizes are strictly ordered, meaning that $\mu_{1} < \mu_{2} < \mu_{3}$ must be maintained. Note that this only affects average values, individual immature specimens can still be larger than female specimens or male specimens and individual female specimens can be larger than male specimens. This ordering is achieved by only estimating $\mu_{2}$ directly (average $\operatorname{LSI}_{e}$ value for females) and estimating the average $\operatorname{LSI}_{e}$ value for immature and male animals with offsets ($\delta_{1}$, $\delta_{2}$) from the female average. The $\delta$ values must be positive to maintain the ordering of the $\mu$ values, so each $\delta$ is modeled in a log-transformed space.
*Offset Equations for $\mu$ Values:*
\begin{equation}
\begin{split}
\mu_1 & = \mu_2 - \delta_1 \\
\mu_3 & = \mu_2 + \delta_2
\end{split}
\end{equation}
Conceptually, this expression of animal body size defines female animals as the standard “body size” that is subject to various selective pressures, with the offset for male animals reflecting sex-specific pressures on males. This interpretation of body size broadly fits the general pressures affecting adult body size in females and males across many ungulate taxa, including domestic herd animals [@perezbarberia_etal_2002; @tchernov_horwitz_1991]. The body size offset between immature animals and adult-sized females ($\delta_{1}$) is admittedly an *ad hoc* definition rather than one under strict biological constraints, as it can be affected by the age immature animals reach before being killed [@gillis_etal_2014]. The computational advantages of this definition arguably outweigh the awkwardness of the definition, however. Further, evaluation of $\delta_{1}$ and $\delta_{2}$ values across different sites could conceivably highlight variation in the timing of the killing of immature animals ($\delta_{1}$) and the degree of adult sexual dimorphism ($\delta_{2}$); both variables can be related to models of hunting intensity, animal domestication, and herd management [@gillis_etal_2014; @marom_baroz_2013; @zeder_hesse_2000].
The $\operatorname{LSI}_{e}$ size variability of animals within a group ($\sigma_{1}$, $\sigma_{2}$, $\sigma_{3}$) is a key variable in the Bayesian mixture model. The values of these standard deviation parameters play a major role in ensuring that the mixture components reflect biological entities rather than overfitting to specific sample noise. Coefficients of variance (CVs) for raw mammal bone measurements from a single sex have been found to be relatively consistent [@davis_1996; @popkin_etal_2012]. When transforming these measurements using a logarithm, this produces consistent standard deviations of the transformed measurement values [@wolfhagen_2020: Figure 1], suggesting that $\sigma$ values should be relatively stable across elements. While $\sigma$ parameters from different animal groups within the model are not directly related to each other, the values still need some transformations to be modeled consistently by the multilevel model. These values must be positive, which conflicts with the multilevel model’s need for unconstrained variables. To achieve this, the model uses the same log-transformation technique used for size offsets to create an unconstrained parameter, $\log_e \sigma$, that is then transformed to actual $\sigma$ values after estimating variation across element portions.
### *3.3 Developing Priors from a Simulated Prior Assemblage*
```{r supplement prior distributions for biological parameters, include = FALSE, eval = TRUE}
####SET SEED: REMOVE TO GENERALIZE####
set.seed(1234567890)
#Import data
sheep_data <- fread("./Data/1-s2.0-S0305440312000301-mmc1.csv", nrows = 356) #accessible from https://doi.org/10.1016/j.jas.2012.01.018 supplementary table, resaved as a .CSV
#Make variable for immature animals (`Days at Death` <= 365), female animals (not-immature), and male/castrated animals (not-immature)
sheep_data[, Immature := ifelse(`Days at Death` <= 365, 1, 0)]
sheep_data[, Female := ifelse(`Days at Death` > 365 & Sex %in% "Female", 1, 0)]
sheep_data[, Male := ifelse(`Days at Death` > 365 & Sex %in% c("Castrate", "Male"), 1, 0)]
#Reframe the sheep data to be set in a long format
sheep_longdata <- melt(sheep_data, id.vars = c("Accession no", "Sex", "Immature", "Female", "Male", "Sca_coracoid_fus", "Hum_prox_fus", "Hum_dist_fus", "Rad_prox_fus", "Rad_dist_fus", "Mtc_dist_fus", "Pel_acetabulum_fus", "Fem_caput_fus", "Fem_dist_fus", "Tib_prox_fus", "Tib_dist_fus", "Mtt_dist_fus", "Cal_prox_fus"), measure.vars = names(sheep_data[, Sca_GLP:Cal_GDde]), variable.name = "Measurement", value.name = "Measurement_value")
sheep_longdata[, Element := tstrsplit(Measurement, "_")[1]]
#Get the standard animal from zoolog
sheep_standard_animal <- data.table(referencesDatabase$`Ovis orientalis`$Uerpmann)
#Keep only limb breadth bone measurements for the mixture model
sheep_mixmod_data <- sheep_longdata[Measurement %in% c("Sca_GLP", "Hum_Bd", "Hum_BT", "Rad_Bp", "Rad_Bd", "Mtc_Bp", "Mtc_BFd", "Fem_Bd", "Tib_Bd", "Ast_Bd", "Mtt_Bp", "Mtt_BFd")]
#Rename standard animal measurements to match the names in the dataset
sheep_standard_animal[EL %in% "Scapula", c("Element", "Measurement") := .("Sca", paste("Sca", Measure, sep = "_"))]
sheep_standard_animal[EL %in% "Humerus", c("Element", "Measurement") := .("Hum", paste("Hum", Measure, sep = "_"))]
sheep_standard_animal[EL %in% "Radius", c("Element", "Measurement") := .("Rad", paste("Rad", Measure, sep = "_"))]
sheep_standard_animal[EL %in% "Metacarpus", c("Element", "Measurement") := .("Mtc", paste("Mtc", Measure, sep = "_"))]
sheep_standard_animal[EL %in% "Femur", c("Element", "Measurement") := .("Fem", paste("Fem", Measure, sep = "_"))]
sheep_standard_animal[EL %in% "Tibia", c("Element", "Measurement") := .("Tib", paste("Tib", Measure, sep = "_"))]
sheep_standard_animal[EL %in% "Astragalus", c("Element", "Measurement") := .("Ast", paste("Ast", Measure, sep = "_"))]
sheep_standard_animal[EL %in% "Metatarsus", c("Element", "Measurement") := .("Mtt", paste("Mtt", Measure, sep = "_"))]
#Rename some measurement name mismatches
sheep_mixmod_data[Measurement %in% "Mtc_BFd", Measurement := "Mtc_Bd"]
sheep_mixmod_data[Measurement %in% "Mtt_BFd", Measurement := "Mtt_Bd"]
#Join the standard animal reference to the dataset (allows for easier identification of relevant standard measurement)
sheep_mixmod_data <- sheep_mixmod_data[sheep_standard_animal[, .(Measurement, Reference_value = Standard)], on = "Measurement"][!is.na(`Accession no`)]
#Create "element portion" and "measurement set" numbers for the model (needs numeric labels)
#note that, by default, these are ordered alphabetically. Can also assign specific orders if desirable
sheep_mixmod_data[, c("Dimension", "Element_Portion") := .(as.numeric(as.factor(Measurement)), as.numeric(as.factor(Element)))]
#Create "specimen" labels to link meausrements from the same bone specimen (model needs numeric labels)
sheep_mixmod_data[, "Specimen_No" := as.numeric(as.factor(paste(`Accession no`, Element, sep = "_")))]
sheep_mixmod_data[, "Individual_No" := as.numeric(as.factor(`Accession no`))]
#Calculate measurement error for observed measurements and reference data (2%, based on Breslawksi and Byers 2015)
sheep_mixmod_data[, c("Measurement_sd", "Reference_sd") := .((Measurement_value * 0.01), (Reference_value * 0.01))]
#Summarize the Popkin, et al. (2012) sheep data
popkin_sheep_summary <- list(
total_individual_n = sheep_mixmod_data[, .N, .(Individual_No)][, .N],
immature_individual_n = sheep_mixmod_data[, .N, .(Individual_No, Immature, Female, Male)][, sum(Immature)],
female_individual_n = sheep_mixmod_data[, .N, .(Individual_No, Immature, Female, Male)][, sum(Female)],
male_individual_n = sheep_mixmod_data[, .N, .(Individual_No, Immature, Female, Male)][, sum(Male)],
total_specimen_n = sheep_mixmod_data[, .N, .(Specimen_No)][, .N],
immature_age_range = sheep_data[Immature %in% 1, max(`Days at Death`) - min(`Days at Death`)]
)
#Subsampling the measurements for measurement error since this may be causing an issue
subsample_n <- 150
mixmod_data_msrmnt_error <- rbind(
sheep_mixmod_data[Specimen_No %in% sheep_mixmod_data[Immature %in% 1, .N, Specimen_No][, sample(Specimen_No, subsample_n, replace = F)]],
sheep_mixmod_data[Specimen_No %in% sheep_mixmod_data[Female %in% 1, .N, Specimen_No][, sample(Specimen_No, subsample_n, replace = F)]],
sheep_mixmod_data[Specimen_No %in% sheep_mixmod_data[Male %in% 1, .N, Specimen_No][, sample(Specimen_No, subsample_n, replace = F)]]
)
mixmod_data_msrmnt_error[, Dimension := as.numeric(as.factor(Dimension))]
mixmod_data_msrmnt_error[, Element_Portion := as.numeric(as.factor(Element_Portion))]
mixmod_data_msrmnt_error[, Specimen_No := as.numeric(as.factor(Specimen_No))]
#Set up the data for Stan modeling
shetland_sheep_mixmod_standata_msrmnt_error <- list(
N_Specimens = mixmod_data_msrmnt_error[, .N, Specimen_No][, .N],
N_Measurements = mixmod_data_msrmnt_error[, .N],
N_Element_Portions = mixmod_data_msrmnt_error[, .N, Element_Portion][, .N],
N_Dimensions = mixmod_data_msrmnt_error[, .N, Dimension][, .N],
Element_Portion = mixmod_data_msrmnt_error[, .N, .(Element_Portion, Specimen_No)][order(Specimen_No), Element_Portion],
Group = mixmod_data_msrmnt_error[, .N, .(Specimen_No, Group = ifelse(Immature %in% 1, 1, ifelse(Female %in% 1, 2, 3)))][order(Specimen_No), Group],
Immature = mixmod_data_msrmnt_error[, .N, .(Immature, Female, Male, Specimen_No)][order(Specimen_No), Immature],
Female = mixmod_data_msrmnt_error[, .N, .(Immature, Female, Male, Specimen_No)][order(Specimen_No), Female],
Male = mixmod_data_msrmnt_error[, .N, .(Immature, Female, Male, Specimen_No)][order(Specimen_No), Male],
Measurement_obs = mixmod_data_msrmnt_error[, Measurement_value],
Measurement_sd = mixmod_data_msrmnt_error[, Measurement_sd],
Reference_obs = mixmod_data_msrmnt_error[, .N, .(Reference_value, Reference_sd, Dimension)][order(Dimension), Reference_value],
Reference_sd = mixmod_data_msrmnt_error[, .N, .(Reference_value, Reference_sd, Dimension)][order(Dimension), Reference_sd],
Dimension = mixmod_data_msrmnt_error[, Dimension],
Specimen = mixmod_data_msrmnt_error[, Specimen_No]
)
#Run the Stan model
reference_pop_msrmnt_error_LSI_model <- cmdstan_model("./Scripts/LSI_known_specimens.stan")
shetland_sheep_samples <- reference_pop_msrmnt_error_LSI_model$sample(
data = shetland_sheep_mixmod_standata_msrmnt_error,
chains = 4,
parallel_chains = 4,
refresh = 250,
adapt_delta = 0.80,
seed = 122839029, #remove this line to generalize/if changing the random seed for the dataset
max_treedepth = 15
)
#Save the posterior results
#Function to save the results from a cmdstan object
cmdstanr_extract_samples <- function(fit_obj) {
#credit to Andrew Johnson for this code (source: https://discourse.mc-stan.org/t/rstan-read-stan-csv-throwing-error-with-cmdstan-models-versions-2-35/35665/7)
vars <- fit_obj$metadata()$stan_variables
draws <- posterior::as_draws_rvars(fit_obj$draws())
lapply(vars, \(var_name){
posterior::draws_of(draws[[var_name]], with_chains = FALSE)
}) |> setNames(vars)
}
shetland_sheep_post <- cmdstanr_extract_samples(shetland_sheep_samples)
```
Relevant prior estimates of the biologically-relevant parameters were derived from the biometry of `r popkin_sheep_summary$total_individual_n` known-age and known-sex Shetland sheep described in @popkin_etal_2012 (see Section 2.2). Castrated individuals were included as males and animals killed under one year of age were considered immature; this resulted in an assemblage of `r popkin_sheep_summary$immature_individual_n` immature animals, `r popkin_sheep_summary$female_individual_n` females, and `r popkin_sheep_summary$male_individual_n` males/castrates. The element portion definitions and included measurements are shown Table 4 of the main text. From the `r popkin_sheep_summary$total_specimen_n` element portions in the full assemblage, `r subsample_n` immature, female, and male element portions were randomly selected to create an assemblage of `r shetland_sheep_mixmod_standata_msrmnt_error$N_Specimens` element portions for analysis. $\operatorname{LSI}_e$ values are calculated using the *Ovis orientalis* female standard animal (FMC 57951) from Uerpmann and Uerpmann [-@uerpmann_uerpmann_1994: Table 12]. These specimens were modeled using a Bayesian multilevel mixture model that used their known identities to estimate the biologically relevant parameters directly ($\mu_2$, $\delta_1$, $\delta_2$, $\sigma_1$, $\sigma_2$, $\sigma_3$). The resulting hyper-parameters, which average across anatomical variation in the parameter values, are used as a baseline for defining prior distributions of the parameter in the archaeological model (see Figure 3 in the main text).
The prior distributions used in this Bayesian multilevel mixture model on the reference population are more straightforward. While the same transformations to create unconstrained parameters are necessary (e.g., modeling average size as $\mu_2$ with offsets for immature and male animals), the definition of these prior distributions can be broadly described as weakly-informative priors [@gelman_etal_2008]. These weakly-informative prior distributions are reasonable in this case—and not in the archaeological case—because all the mixture model parameters have direct observations rather than relying on latent state estimations. That is, parameters like the size difference between males and females ($\delta_2$) and the size variability in female animals ($\sigma_2$) can be directly observed because the group identities of every specimen are known. With these direct observations, the prior distributions have a more muted influence on the resulting posterior distributions. This does not mean that the prior distributions have no effect, however, which is why objective priors can have undesirable impacts on modeling results [@gabry_etal_2019].
*Prior Distribution Definitions for the Known-Identity Model Hyper-Parameters*
\begin{equation}
\begin{split}
\mu_2 & \sim \operatorname{Normal}(-0.1, 0.1) \\
\log \delta_1 & \sim \operatorname{Normal}(-3, 0.5) \\
\log \delta_2 & \sim \operatorname{Normal}(-3, 0.5) \\
\log \sigma_1 & \sim \operatorname{Normal}(-3, 0.1) \\
\log \sigma_2 & \sim \operatorname{Normal}(-3, 0.1) \\
\log \sigma_3 & \sim \operatorname{Normal}(-3, 0.1) \\
\sigma_{\operatorname{Element}}[1,2,3,4,5,6] & \sim \operatorname{Half-Normal}(0, 0.05) \\
\end{split}
\end{equation}
The average $\operatorname{LSI}_e$ value for females ($\mu_2$) is likely to vary across contexts in reaction to different selective pressures, both anthropogenic and ecological [e.g., @davis_1981; @manning_etal_2015; @wright_vinerdaniels_2015]. While the posterior distribution is extremely focused on this specific population, there is no reason to think that this value should be centered at any particular value since that relates to the standard animal used [@meadow_1999; @wolfhagen_2020]. Therefore, the prior distribution used in archaeological models for $\mu_2$ uses a larger standard deviation, $\mu_2 \sim \operatorname{Normal}(0, 0.1)$, to encompass likely $\operatorname{LSI}_e$ values (Figure 3A in the main text). Under this definition, there is a 95% probability that the $\mu_2$ value lies within the range of `r format(round(qnorm(0.025, 0, 0.1), 2), nsmall = 2)` and `r format(round(qnorm(0.975, 0, 0.1), 2), nsmall = 2)` on the $\operatorname{LSI}_e$ scale, which translates to roughly `r paste0(round(100 * exp(qnorm(0.025, 0, 0.1)), 0), "-", round(100 * (exp(qnorm(0.975, 0, 0.1))), 0), "%")` the size of the standard animal’s measurement.
For the average size difference between immature and female animals ($\delta_1$), the narrowness of the posterior distribution likely reflects the fact that immature animals in the sample cover a narrow age range. Animals killed under one year of age span only `r popkin_sheep_summary$immature_age_range` days and the youngest animals are nearly half a year old [178-214 days: @popkin_etal_2012]. Thus while the posterior results provide a useful starting point for estimating this offset, there is a good potential for larger $\delta_1$ values (i.e., greater size differences between immature and adult-sized female animals) in other contexts that could include animals killed at a younger age (Figure 3B in the main text). To capture this possibility, the archaeological model uses a prior distribution with a larger standard deviation and a slightly higher center, $\log \delta_1 \sim \operatorname{Normal}(-3.5, 0.4)$, which results in an average size difference of `r round(exp(-3.5), 2)` on the $\operatorname{LSI}_e$ scale and a 95% probability that the size difference is between `r round(exp(qnorm(0.025, -3.5, 0.4)), 2)` and `r round(exp(qnorm(0.975, -3.5, 0.4)), 2)`. This translates into expecting the average body size of immature animals in an assemblage being `r paste0(round(100 * (exp(exp(-3.5)) - 1), 0), "%")` smaller than the average body size of adult-sized female animals, but also plausibly believing that this size difference could range from `r paste0(round(100 * (exp(exp(qnorm(0.025, -3.5, 0.4))) - 1), 0), "-", round(100 * (exp(exp(qnorm(0.975, -3.5, 0.4))) - 1), 0), "%")` smaller.
The average size difference between adult males and females ($\delta_2$), also known as the index of sexual dimorphism [@fernandez_monchot_2007], is likely to be under stricter biological control than the other “average body size” parameters in the model. This does not mean that this difference could not vary between contexts, however. Some models of animal domestication argue that initial domestication removed sexual selective pressures on male body size, reducing sexual dimorphism [e.g., @tchernov_horwitz_1991]. In a similar fashion, specialized hunting strategies could also reduce sexual dimorphism by targeting large-bodied males, for example [@zeder_2012; @proaktor_etal_2007; @milner_etal_2007]. Again, the posterior distribution of the extent of sexual dimorphism in the Shetland sheep population provides a useful starting point to describe a prior distribution for the model (Figure 3C in the main text). Increasing the standard deviation of the distribution slightly, $\log \delta_2 \sim \operatorname{Normal}(-2.7, 0.1)$, produces a distribution centered at `r round(exp(-2.7), 2)` $\operatorname{LSI}_e$ units with a 95% probability that the value is between `r paste0(round(exp(qnorm(0.025, -2.7, 0.1)), 2), "-", round(exp(qnorm(0.975, -2.7, 0.1)), 2))`, translating to the average male being `r paste0(round(100 * (exp(exp(qnorm(0.025, -2.7, 0.1))) - 1), 0), "-", round(100 * (exp(exp(qnorm(0.975, -2.7, 0.1))) - 1), 0), "%")` larger than the average female relative to a standard measurement. The smaller standard deviation in the prior distribution of $\delta_2$ than for $\delta_1$ reflects our understanding that the extent of sexual dimorphism, as a biological phenomenon, is less likely to have extreme values than the average size difference between immature and female animals, since $\delta_2$ is unaffected by the specific age structure of the assemblage.
As in the average body size parameters, prior distributions for the size variability model parameters are developed from the Bayesian model of known-identity Shetland sheep measurements. The resulting $\sigma$ hyper-parameters provide a baseline for establishing hyper-parameter prior distributions in archaeological cases. Figure 3D-F of the main text shows the posterior distributions of these $\sigma$ hyper-parameters in both the log-transformed values and associated $\operatorname{LSI}_e$ values. Average size variability within an element portion for immature animals ($\sigma_1$) is higher, on average, than for females ($\sigma_2$) and males ($\sigma_3$). The immature category includes both male and female animals, so larger size variability makes sense; again, it is possible that $\sigma_1$ is relatively low in this population relative to other contexts given the narrow age range of immature animals in the Shetland sheep population. Unlike the average body size parameters, there are not compelling reasons to believe that size variability parameters for females and males ($\sigma_2$ and $\sigma_3$) should vary widely in different contexts given the consistency of coefficients of variation in mammals broadly [@davis_1996]. Thus, the results of this analysis are used for the prior distributions of $\log \sigma_2$ and $\log \sigma_3$, while the prior distribution of $\log \sigma_1$ is given an increased standard deviation and slightly increased average value. Overall, however, these prior distributions suggest that the average size variability within an element portion is between `r paste0(round(exp(qnorm(0.025, -3.05, 0.1)), 2), "-", round(exp(qnorm(0.975, -3.05, 0.1)), 2))` for females and males and is between `r paste0(round(exp(qnorm(0.025, -3.1, 0.1)), 2), "-", round(exp(qnorm(0.975, -3.1, 0.1)), 2))` for immature animals. Note that even though $\sigma_2$ and $\sigma_3$ have the same prior distributions, these values can still vary from each other in different contexts.
## *4. Multilevel Structure of the Model*
The previous section described prior distributions that describe the *average* value for different mixture model parameters across all element portions. To create parameter estimates that are specific to different element portions, it is necessary to estimate the *variation* around these average values that different parameters can have among different element portions. The model uses a Multivariate Normal definition of the model parameters to allow for correlations between different parameters; effectively, the possibility that multiple model parameters will covary from element portion to element portion. To do this, each hyper-parameter has an associated $\sigma_{\operatorname{element}}$ parameter that describes inter-element variation in parameter values. The model uses a non-centered parameterization, wherein the Multivariate Normal distribution is centered at zero to calculate offsets, $\nu_{\operatorname{element}}$, that are added to the average hyper-parameters to calculate model parameters for each element portion. This definition provides computational stability and makes it more straightforward to incorporate other levels of multilevel structure.
*Equations for Defining Inter-Element Variation (Multilevel Modeling):*
\begin{equation}
\begin{split}
\nu_{\operatorname{Element}} & \sim \operatorname{MultivariateNormal} \left(\begin{bmatrix} 0 \\ \vdots \\ 0 \\ \end{bmatrix}, \Sigma_{\operatorname{Element}}\right) \\
\Sigma_{\operatorname{Element}} & =
\begin{pmatrix}
\sigma_{\operatorname{Element}}[1] & \dots & 0 \\
\vdots & \ddots & \vdots \\
0 & \dots & \sigma_{\operatorname{Element}}[8] \\
\end{pmatrix}
\rho_{\operatorname{Element}}
\begin{pmatrix}
\sigma_{\operatorname{Element}}[1] & \dots & 0 \\
\vdots & \ddots & \vdots \\
0 & \dots & \sigma_{\operatorname{Element}}[8] \\
\end{pmatrix} \\
\rho_{\operatorname{Element}} & = LKJcorr(2) \\
\theta_1[\operatorname{Element}] & = \theta_1 + \nu_{\operatorname{Element}}[1] \\
\theta_2[\operatorname{Element}] & = \theta_2 + \nu_{\operatorname{Element}}[2] \\
\mu_2[\operatorname{Element}] & = \mu_2 + \nu_{\operatorname{Element}}[3] \\
\log \delta_1 [\operatorname{Element}] & = \log \delta_1 + \nu_{\operatorname{Element}}[4] \\
\log \delta_2 [\operatorname{Element}] & = \log \delta_2 + \nu_{\operatorname{Element}}[5] \\
\log \sigma_1 [\operatorname{Element}] & = \log \sigma_1 + \nu_{\operatorname{Element}}[6] \\
\log \sigma_2 [\operatorname{Element}] & = \log \sigma_2 + \nu_{\operatorname{Element}}[7] \\
\log \sigma_3 [\operatorname{Element}] & = \log \sigma_3 + \nu_{\operatorname{Element}}[8]
\end{split}
\end{equation}
The multilevel structure used to allow variation in parameter estimates across element portions can also be expanded to create multisite models that can directly compare sex-specific biometric estimates alongside the age/sex composition of different assemblages. Such comparisons can highlight variation in herd management strategies or diachronic body size trends related to population turnover [e.g., @arbuckle_atici_2013; @arbuckle_etal_2016]. To do this, an additional multilevel structure can be applied to the same mixture model parameters, using $\sigma_{Site}$ rather than $\sigma_{\operatorname{Element}}$ parameters. However, an additional set of multilevel structure parameters, $\sigma_{Interaction}$, are also necessary to ensure that elemental variation is different at different sites (e.g., the difference between $\mu_2$ for the distal humerus and $\mu_2$ for the distal radius is not necessarily the same at different sites). Again, weakly-informative priors are appropriate for both sets of parameters. Each additional term is included in the sum to create specific mixture model parameter values.
*Example of Parameter Definition for Inter-Site and Inter-Element Variation:*
$$\theta_1[\operatorname{Site}, \operatorname{Element}] = \theta_1 + \nu_{\operatorname{Site}}[\operatorname{Site}] + \nu_{\operatorname{Element}}[\operatorname{Element}] + \nu_{\operatorname{Interaction}}[\operatorname{Site}, \operatorname{Element}]$$
The inclusion of multiple sites changes the definition of the ‘grand mean’ variable ($\theta_1$ in the example equation) from a site-level estimate to an overall mean across the sites and elements. These parameter estimates thus describe the average composition of the entire set of assemblages. The details of the assemblages included in the analyses would affect how useful these estimates are for interpretation. Assemblage-specific estimates can be calculated for each model parameter by adding the relevant $\nu_{\operatorname{site}}$ estimate to the ‘grand mean’ parameter, which would again act to describe the average composition of the assemblage regardless of its elemental composition.
Prior distributions for $\sigma_{\operatorname{Element}}$ values (and $\sigma_{\operatorname{Site}}$ and $\sigma_{\operatorname{Interaction}}$ values in multisite models) are weakly-informative priors based on the scale of the parameter and the expectation for variation for the parameter. For example, there is likely more variation in $\theta$ parameters—that govern the relative composition of immature, female, and male animals—among element portions than variation in $\sigma$ parameters that govern size variability within each group. Similarly, it is expected that average body sizes of females $\mu_{2}$ will vary more between sites $\sigma_{\operatorname{Site}}[3]$ than between elements within a site $\sigma_{\operatorname{Element}}[3]$. The impacts of these prior distribution definitions were evaluated using prior predictive checking, suggesting that these prior distributions allow enough variability to encompass reasonable size estimates without providing too much prior support to implausible or impossible values (see Section 6 of the Model Supplement).
*Prior Distributions for Element-level Variation (Multilevel Component):*
\begin{equation}
\begin{split}
\sigma_{\operatorname{Element}}[1,2] & \sim \operatorname{Half-Normal}(0, 0.5) \\
\sigma_{\operatorname{Element}}[3,4,5,6,7,8] & \sim \operatorname{Half-Normal}(0, 0.05) \\
\end{split}
\end{equation}
*Prior Distributions for Site-level Variation (Multilevel Component):*
\begin{equation}
\begin{split}
\sigma_{\operatorname{Site}}[1,2] & \sim \operatorname{Half-Normal}(0, 0.5) \\
\sigma_{\operatorname{Site}}[3,4,5] & \sim \operatorname{Half-Normal}(0, 0.1) \\
\sigma_{\operatorname{Site}}[6,7,8] & \sim \operatorname{Half-Normal}(0, 0.05) \\
\rho_{\operatorname{Site}} & = LKJcorr(2)
\end{split}
\end{equation}
*Prior Distributions for Interaction Effect (Multilevel Component):*
\begin{equation}
\begin{split}
\sigma_{\operatorname{Interaction}}[1,2] & \sim \operatorname{Half-Normal}(0, 0.25) \\
\sigma_{\operatorname{Interaction}}[3,4,5] & \sim \operatorname{Half-Normal}(0, 0.1) \\
\sigma_{\operatorname{Interaction}}[6,7,8] & \sim \operatorname{Half-Normal}(0, 0.05) \\
\rho_{\operatorname{Interaction}} & = LKJcorr(2)
\end{split}
\end{equation}
## *5. Prior Distributions for the Model Hyper-Parameters (Simulations and Archaeological Cases)*
*Prior Distribution Definitions for the Single Assemblage Simulation Model Hyper-Parameters*
\begin{equation}
\begin{split}
\theta_1 & \sim \operatorname{Normal}(-0.5, 1.5) \\
\theta_2 & \sim \operatorname{Normal}(0.0, 1.5) \\
\mu_2 & \sim \operatorname{Normal}(0.0, 0.1) \\
\log \delta_1 & \sim \operatorname{Normal}(-3.5, 0.4) \\
\log \delta_2 & \sim \operatorname{Normal}(-2.7, 0.1) \\
\log \sigma_1 & \sim \operatorname{Normal}(-3.05, 0.1) \\
\log \sigma_2 & \sim \operatorname{Normal}(-3.10, 0.1) \\
\log \sigma_3 & \sim \operatorname{Normal}(-3.10, 0.1)
\end{split}
\end{equation}
*Prior Distribution Definitions for the Multisite Simulation Model Hyper-Parameters*
\begin{equation}
\begin{split}
\theta_1 & \sim \operatorname{Normal}(-0.5, 1.5) \\
\theta_2 & \sim \operatorname{Normal}(0.0, 1.5) \\
\mu_2 & \sim \operatorname{Normal}(0.0, 0.2) \\
\log \delta_1 & \sim \operatorname{Normal}(-3.5, 0.5) \\
\log \delta_2 & \sim \operatorname{Normal}(-2.7, 0.2) \\
\log \sigma_1 & \sim \operatorname{Normal}(-3.05, 0.1) \\
\log \sigma_2 & \sim \operatorname{Normal}(-3.10, 0.1) \\
\log \sigma_3 & \sim \operatorname{Normal}(-3.10, 0.1)
\end{split}
\end{equation}
*Prior Distribution Definitions for the Pinarbaşı B Sheep Model Hyper-Parameters*
\begin{equation}
\begin{split}
\theta_1 & \sim \operatorname{Normal}(-0.5, 1.5) \\
\theta_2 & \sim \operatorname{Normal}(0.0, 1.5) \\
\mu_2 & \sim \operatorname{Normal}(0.0, 0.1) \\
\log \delta_1 & \sim \operatorname{Normal}(-3.5, 0.4) \\
\log \delta_2 & \sim \operatorname{Normal}(-2.7, 0.1) \\
\log \sigma_1 & \sim \operatorname{Normal}(-3.05, 0.1) \\
\log \sigma_2 & \sim \operatorname{Normal}(-3.10, 0.1) \\
\log \sigma_3 & \sim \operatorname{Normal}(-3.10, 0.1)
\end{split}
\end{equation}
*Prior Distribution Definitions for the Northwest Anatolian Cattle Model Hyper-Parameters*
\begin{equation}
\begin{split}
\theta_1 & \sim \operatorname{Normal}(-0.5, 1.5) \\
\theta_2 & \sim \operatorname{Normal}(0.0, 1.5) \\
\mu_2 & \sim \operatorname{Normal}(-0.1, 0.1) \\
\log \delta_1 & \sim \operatorname{Normal}(-3.5, 0.5) \\
\log \delta_2 & \sim \operatorname{Normal}(-2.0, 0.5) \\
\log \sigma_1 & \sim \operatorname{Normal}(-3.05, 0.1) \\
\log \sigma_2 & \sim \operatorname{Normal}(-3.10, 0.1) \\
\log \sigma_3 & \sim \operatorname{Normal}(-3.10, 0.1)
\end{split}
\end{equation}
## *6. Simulating Assemblages from the Prior Distributions (Prior Predictive Checking)*
Prior predictive checks are a critical component of Bayesian model development workflows, ensuring that reasonable prior definitions are chosen [@gabry_etal_2019; @gelman_etal_2020_workflow]. This process uses the model's prior distribution definitions to simulate data, which can then be evaluated against domain knowledge and observed data. This is particularly important when dealing with model parameters that are difficult to examine in isolation, like parameters that govern inter-element variation ($\sigma_{\operatorname{Element}}$) in a multilevel model structure. Prior predictive checking is an iterative process, informing researchers about the potential consequences of their prior distribution definitions; in particular, it can highlight how excessively imprecise definitions can provide considerable prior weight on implausible and even impossible values for data [@gabry_etal_2019: Figure 4]. Thus, prior predictive checking allows researchers to create more accurate summaries of their domain knowledge but also produces more efficient MCMC performance because less time is spent evaluating parameter values that are inconsistent with even cursory prior knowledge about the problem being modeled.
```{r prior predictive checking, include = FALSE, eval = TRUE}
#Functions to run the prior predictive checks#
#samples from a normal distribution, but only accepts positive values
rposnorm <- function(n, mu, sigma) {
#samples from a defined normal distribution until it finds a positive value
accept = FALSE
while(!accept) {
value <- rnorm(n, mean = mu, sd = sigma)
if(sum(value > 0) == length(value)) accept <- TRUE
}
value
}
#creates a correlation matrix using the sampled marginal correlation values
rho_matrix_maker <- function(lkjcorr, K) {
Rho_matrix <- matrix(NA, ncol = K, nrow = K)
Rho_matrix[upper.tri(Rho_matrix)] <- lkjcorr
diag(Rho_matrix) <- 1
for(i in 1:K) {
for(j in 1:K) {
if(is.na(Rho_matrix[i,j])) {
Rho_matrix[i,j] <- Rho_matrix[j,i]
}
}
}
Rho_matrix
}
#Single Site simulation#
LSI_mixture_singlesite_prior_predictive_check <- function(N_Element_Portions = 5, grand_prior = singlesite_grand_prior_list, element_sigma_vals = singlesite_element_sigma_values, std_animal = priorpredict_sheep_standard_animal) {
#Simulating from the priors, start at the top
grand_theta_raw = c(rnorm(1, grand_prior$prior_theta_raw_1[1], grand_prior$prior_theta_raw_1[2]), rnorm(1, grand_prior$prior_theta_raw_2[1], grand_prior$prior_theta_raw_2[2]))
grand_mu_female = rnorm(1, grand_prior$prior_mu_female[1], grand_prior$prior_mu_female[2])
grand_logdelta_immature = rnorm(1, grand_prior$prior_logdelta_immature[1], grand_prior$prior_logdelta_immature[2])
grand_logdelta_male = rnorm(1, grand_prior$prior_logdelta_male[1], grand_prior$prior_logdelta_male[2])
grand_logsigma_immature = rnorm(1, grand_prior$prior_logsigma_immature[1], grand_prior$prior_logsigma_immature[2])
grand_logsigma_female = rnorm(1, grand_prior$prior_logsigma_female[1], grand_prior$prior_logsigma_female[2])
grand_logsigma_male = rnorm(1, grand_prior$prior_logsigma_male[1], grand_prior$prior_logsigma_male[2])
#Internal priors for the multilevel modeling
element_sigma <- c(rposnorm(1, 0, element_sigma_vals[1]),
rposnorm(1, 0, element_sigma_vals[2]),
rposnorm(1, 0, element_sigma_vals[3]),
rposnorm(1, 0, element_sigma_vals[4]),
rposnorm(1, 0, element_sigma_vals[5]),
rposnorm(1, 0, element_sigma_vals[6]),
rposnorm(1, 0, element_sigma_vals[7]),
rposnorm(1, 0, element_sigma_vals[8]))
#
z_element <- matrix(rnorm(8 * N_Element_Portions, 0, 1), ncol = N_Element_Portions, nrow = 8)
#number of random correlations: ((Number of parameters)^2 - (Number of parameters)) / 2
Rho_element <- rlkjcorr_marginal((length(element_sigma)^2 - length(element_sigma)) / 2, K = 8, eta = 2)
#Calculate a single set of the parameter values
v_element <- t(diag(element_sigma) %*% rho_matrix_maker(Rho_element, 8) %*% diag(element_sigma) %*% z_element)
#
#calculating the output variables (untransformed)
theta_raw <- matrix(NA, nrow = 2, ncol = N_Element_Portions)
theta_raw[1, ] <- grand_theta_raw[1] + v_element[, 1]
theta_raw[2, ] <- grand_theta_raw[2] + v_element[, 2]
mu_female = grand_mu_female + v_element[, 3]
logdelta_immature = grand_logdelta_immature + v_element[, 4];
logdelta_male = grand_logdelta_male + v_element[, 5];
logsigma_immature = grand_logsigma_immature + v_element[, 6];
logsigma_female = grand_logsigma_female + v_element[, 7];
logsigma_male = grand_logsigma_male + v_element[, 8];
#mu and sigma transformations
mu_immature = mu_female - exp(logdelta_immature)
mu_male = mu_female + exp(logdelta_male)
sigma_immature = exp(logsigma_immature)
sigma_female = exp(logsigma_female)
sigma_male = exp(logsigma_male)
#theta transformations
grand_theta <- rep(NA, 3)
grand_theta[1] = boot::inv.logit(grand_theta_raw[1] + log(0.5));
grand_theta[2] = (1 - grand_theta[1]) * boot::inv.logit(grand_theta_raw[2] + log(1));
grand_theta[3] = 1 - sum(grand_theta[1:2]);
theta <- matrix(NA, nrow = 3, ncol = N_Element_Portions)
for(i in 1:N_Element_Portions) {
theta[1, i] = boot::inv.logit(theta_raw[1, i] + log(0.5));
theta[2, i] = (1 - theta[1, i]) * boot::inv.logit(theta_raw[2, i] + log(1));
theta[3, i] = 1 - sum(theta[1:2, i]);
}
p_immature = grand_theta[1]
theta_female = grand_theta[2] / sum(grand_theta[2:3])
#
grand_mu_immature = grand_mu_female - exp(grand_logdelta_immature)
grand_mu_male = grand_mu_female + exp(grand_logdelta_male)
grand_sigma_immature = exp(grand_logsigma_immature)
grand_sigma_female = exp(grand_logsigma_female)
grand_sigma_male = exp(grand_logsigma_male)
#use the proportions to get a set number of immature, female, and male specimens (25 per element)
specimen_LSI_values <- data.table(Specimen_No = 1:(25 * N_Element_Portions), rbindlist(lapply(1:N_Element_Portions, function(x) data.table(Element_Portion = x, Sex = sample(c("Immature", "Female", "Male"), 25, prob = theta[, x], replace = T)))))
specimen_LSI_values[Sex %in% "Immature", LSI_specimen := rnorm(1, mu_immature[Element_Portion], sigma_immature[Element_Portion]), Specimen_No]
specimen_LSI_values[Sex %in% "Female", LSI_specimen := rnorm(1, mu_female[Element_Portion], sigma_female[Element_Portion]), Specimen_No]
specimen_LSI_values[Sex %in% "Male", LSI_specimen := rnorm(1, mu_male[Element_Portion], sigma_male[Element_Portion]), Specimen_No]
#turn these into broad measurements
#Element_Portion 1: Humerus Bd and Humerus BT
#Element_Portion 2: Radius Bp
#Element_Portion 3: Metacarpal Bp
#Element_Portion 4: Metatarsal Bp
#Element_Portion 5: Astragalus Bd
measurement_LSI_calc <- function(Specimen_No, Element_Portion, LSI, N_measurements) {
data.table(Specimen_No, Element_Portion, Measurement = paste0(Element_Portion, ".", 1:N_measurements), LSI_measurement = rnorm(N_measurements, LSI, 0.02))
}
measurement_LSI_values <- rbind(
rbindlist(lapply(specimen_LSI_values[Element_Portion %in% 1, Specimen_No], function(x) measurement_LSI_calc(Specimen_No = x, Element_Portion = 1, LSI = specimen_LSI_values[Specimen_No %in% x, LSI_specimen], 2))),
rbindlist(lapply(specimen_LSI_values[Element_Portion %in% 2, Specimen_No], function(x) measurement_LSI_calc(Specimen_No = x, Element_Portion = 2, LSI = specimen_LSI_values[Specimen_No %in% x, LSI_specimen], 1))),
rbindlist(lapply(specimen_LSI_values[Element_Portion %in% 3, Specimen_No], function(x) measurement_LSI_calc(Specimen_No = x, Element_Portion = 3, LSI = specimen_LSI_values[Specimen_No %in% x, LSI_specimen], 1))),
rbindlist(lapply(specimen_LSI_values[Element_Portion %in% 4, Specimen_No], function(x) measurement_LSI_calc(Specimen_No = x, Element_Portion = 4, LSI = specimen_LSI_values[Specimen_No %in% x, LSI_specimen], 1))),
rbindlist(lapply(specimen_LSI_values[Element_Portion %in% 5, Specimen_No], function(x) measurement_LSI_calc(Specimen_No = x, Element_Portion = 5, LSI = specimen_LSI_values[Specimen_No %in% x, LSI_specimen], 1)))
)
measurement_values <- measurement_LSI_values[std_animal[!is.na(Measurement), .(EL, Measurement, Measure, Reference_value = Standard)], on = "Measurement"]
measurement_values[, Measurement_value := exp(LSI_measurement) * Reference_value]
#
list(Overall_Parameters = c(grand_theta, grand_mu_immature, grand_mu_female, grand_mu_male, grand_sigma_immature, grand_sigma_female, grand_sigma_male, p_immature, theta_female), Element_Parameters = cbind(t(theta), mu_immature, mu_female, mu_male, sigma_immature, sigma_female, sigma_male), Specimens = specimen_LSI_values, Measurements = measurement_values)
}
#Multisite simulation#
LSI_mixture_multisite_prior_predictive_check <- function(N_Element_Portions = 5, N_Sites = 3, grand_prior = multisite_grand_prior_list, site_sigma_vals = multisite_site_sigma_values, element_sigma_vals = multisite_element_sigma_values, interaction_sigma_vals = multisite_interaction_sigma_values, std_animal = priorpredict_sheep_standard_animal) {
#Simulating from the priors, start at the top
grand_theta_raw = c(rnorm(1, grand_prior$prior_theta_raw_1[1], grand_prior$prior_theta_raw_1[2]), rnorm(1, grand_prior$prior_theta_raw_2[1], grand_prior$prior_theta_raw_2[2]))
grand_mu_female = rnorm(1, grand_prior$prior_mu_female[1], grand_prior$prior_mu_female[2])
grand_logdelta_immature = rnorm(1, grand_prior$prior_logdelta_immature[1], grand_prior$prior_logdelta_immature[2])
grand_logdelta_male = rnorm(1, grand_prior$prior_logdelta_male[1], grand_prior$prior_logdelta_male[2])
grand_logsigma_immature = rnorm(1, grand_prior$prior_logsigma_immature[1], grand_prior$prior_logsigma_immature[2])
grand_logsigma_female = rnorm(1, grand_prior$prior_logsigma_female[1], grand_prior$prior_logsigma_female[2])
grand_logsigma_male = rnorm(1, grand_prior$prior_logsigma_male[1], grand_prior$prior_logsigma_male[2])
#Internal priors for the multilevel modeling
element_sigma <- c(rposnorm(1, 0, element_sigma_vals[1]),
rposnorm(1, 0, element_sigma_vals[2]),
rposnorm(1, 0, element_sigma_vals[3]),
rposnorm(1, 0, element_sigma_vals[4]),
rposnorm(1, 0, element_sigma_vals[5]),
rposnorm(1, 0, element_sigma_vals[6]),
rposnorm(1, 0, element_sigma_vals[7]),
rposnorm(1, 0, element_sigma_vals[8]))
#
z_element <- matrix(rnorm(8 * N_Element_Portions, 0, 1), ncol = N_Element_Portions, nrow = 8)
#number of random correlations: ((Number of parameters)^2 - (Number of parameters)) / 2
Rho_element <- rlkjcorr_marginal((length(element_sigma)^2 - length(element_sigma)) / 2, K = 8, eta = 2)
#
site_sigma <- c(rposnorm(1, 0, site_sigma_vals[1]),
rposnorm(1, 0, site_sigma_vals[2]),
rposnorm(1, 0, site_sigma_vals[3]),
rposnorm(1, 0, site_sigma_vals[4]),
rposnorm(1, 0, site_sigma_vals[5]),
rposnorm(1, 0, site_sigma_vals[6]),
rposnorm(1, 0, site_sigma_vals[7]),
rposnorm(1, 0, site_sigma_vals[8]))
#
z_site <- matrix(rnorm(8 * N_Sites, 0, 1), ncol = N_Sites, nrow = 8)
Rho_site <- rlkjcorr_marginal((length(site_sigma)^2 - length(site_sigma)) / 2, K = 8, eta = 2)
#
interaction_sigma <- c(rposnorm(1, 0, interaction_sigma_vals[1]),
rposnorm(1, 0, interaction_sigma_vals[2]),
rposnorm(1, 0, interaction_sigma_vals[3]),
rposnorm(1, 0, interaction_sigma_vals[4]),
rposnorm(1, 0, interaction_sigma_vals[5]),
rposnorm(1, 0, interaction_sigma_vals[6]),
rposnorm(1, 0, interaction_sigma_vals[7]),
rposnorm(1, 0, interaction_sigma_vals[8]))
#
z_interaction <- matrix(rnorm(8 * N_Sites * N_Element_Portions, 0, 1), ncol = N_Sites * N_Element_Portions, nrow = 8)
Rho_interaction <- rlkjcorr_marginal((length(interaction_sigma)^2 - length(interaction_sigma)) / 2, K = 8, eta = 2)
#Calculate a single set of the parameter values
v_element <- t(diag(element_sigma) %*% rho_matrix_maker(Rho_element, 8) %*% diag(element_sigma) %*% z_element)
v_site <- t(diag(site_sigma) %*% rho_matrix_maker(Rho_site, 8) %*% diag(site_sigma) %*% z_site)
v_interaction <- t(diag(interaction_sigma) %*% rho_matrix_maker(Rho_interaction, 8) %*% diag(interaction_sigma) %*% z_interaction)
#
#calculating site-level outputs variables (untransformed)
site_theta_raw <- matrix(NA, nrow = 2, ncol = N_Sites)
site_theta_raw[1, ] <- grand_theta_raw[1] + v_site[, 1]
site_theta_raw[2, ] <- grand_theta_raw[2] + v_site[, 2]
site_mu_female = grand_mu_female + v_site[, 3]
site_logdelta_immature = grand_logdelta_immature + v_site[, 4]
site_logdelta_male = grand_logdelta_male + v_site[, 5]
site_logsigma_immature = grand_logsigma_immature + v_site[, 6]
site_logsigma_female = grand_logsigma_female + v_site[, 7]
site_logsigma_male = grand_logsigma_male + v_site[, 8]
#calculating the site + element output variables (untransformed)
theta_raw <- array(NA, dim = c(2, N_Sites, N_Element_Portions))
mu_female <- matrix(NA, nrow = N_Sites, ncol = N_Element_Portions)
logdelta_immature <- matrix(NA, nrow = N_Sites, ncol = N_Element_Portions)
logdelta_male <- matrix(NA, nrow = N_Sites, ncol = N_Element_Portions)
logsigma_immature <- matrix(NA, nrow = N_Sites, ncol = N_Element_Portions)
logsigma_female <- matrix(NA, nrow = N_Sites, ncol = N_Element_Portions)
logsigma_male <- matrix(NA, nrow = N_Sites, ncol = N_Element_Portions)
for(i in 1:N_Sites) {
for(j in 1:N_Element_Portions) {
theta_raw[1, i, j] = grand_theta_raw[1] + v_site[i, 1] + v_element[j, 1] + v_interaction[N_Element_Portions * (i - 1) + j, 1];
theta_raw[2, i, j] = grand_theta_raw[2] + v_site[i, 2] + v_element[j, 2] + v_interaction[N_Element_Portions * (i - 1) + j, 2];
mu_female[i, j] = grand_mu_female + v_site[i, 3] + v_element[j, 3] + v_interaction[N_Element_Portions * (i - 1) + j, 3];
logdelta_immature[i, j] = grand_logdelta_immature + v_site[i, 4] + v_element[j, 4] + v_interaction[N_Element_Portions * (i - 1) + j, 4];
logdelta_male[i, j] = grand_logdelta_male + v_site[i, 5] + v_element[j, 5] + v_interaction[N_Element_Portions * (i - 1) + j, 5];
logsigma_immature[i, j] = grand_logsigma_immature + v_site[i, 6] + v_element[j, 6] + v_interaction[N_Element_Portions * (i - 1) + j, 6];
logsigma_female[i, j] = grand_logsigma_female + v_site[i, 7] + v_element[j, 7] + v_interaction[N_Element_Portions * (i - 1) + j, 7];
logsigma_male[i, j] = grand_logsigma_male + v_site[i, 8] + v_element[j, 8] + v_interaction[N_Element_Portions * (i - 1) + j, 8];
}
}
#mu and sigma transformations
site_mu_immature = site_mu_female - exp(site_logdelta_immature)
site_mu_male = site_mu_female + exp(site_logdelta_male)
site_sigma_immature = exp(site_logsigma_immature)
site_sigma_female = exp(site_logsigma_female)
site_sigma_male = exp(site_logsigma_male)
mu_immature = mu_female - exp(logdelta_immature)
mu_male = mu_female + exp(logdelta_male)
sigma_immature = exp(logsigma_immature)
sigma_female = exp(logsigma_female)
sigma_male = exp(logsigma_male)
#theta transformations
grand_theta <- rep(NA, 3)
grand_theta[1] = boot::inv.logit(grand_theta_raw[1] + log(0.5));
grand_theta[2] = (1 - grand_theta[1]) * boot::inv.logit(grand_theta_raw[2] + log(1));
grand_theta[3] = 1 - sum(grand_theta[1:2]);
#site-level and site+element-level
site_theta <- matrix(NA, nrow = 3, ncol = N_Sites)
theta <- array(NA, dim = c(3, N_Sites, N_Element_Portions))
site_p_immature <- rep(NA, N_Sites)
site_theta_female <- rep(NA, N_Sites)
for(i in 1:N_Sites) {
site_theta[1, i] = boot::inv.logit(site_theta_raw[1, i] + log(0.5));
site_theta[2, i] = (1 - site_theta[1, i]) * boot::inv.logit(site_theta_raw[2, i] + log(1));
site_theta[3, i] = 1 - sum(site_theta[1:2, i]);
site_p_immature[i] = site_theta[1, i];
site_theta_female[i] = site_theta[2, i] / sum(site_theta[2:3, i]);
for(j in 1:N_Element_Portions) {
theta[1, i, j] = boot::inv.logit(theta_raw[1, i, j] + log(0.5));
theta[2, i, j] = (1 - theta[1, i, j]) * boot::inv.logit(theta_raw[2, i, j] + log(1));
theta[3, i, j] = 1 - sum(theta[1:2, i, j]);
}
}
#
grand_mu_immature = grand_mu_female - exp(grand_logdelta_immature)
grand_mu_male = grand_mu_female + exp(grand_logdelta_male)
grand_sigma_immature = exp(grand_logsigma_immature)
grand_sigma_female = exp(grand_logsigma_female)
grand_sigma_male = exp(grand_logsigma_male)
#use the proportions to get a set number of immature, female, and male specimens (25 per element per site)
specimen_LSI_simulate <- function(Site_No, N_Element_Portions, theta, mu_immature, mu_female, mu_male, sigma_immature, sigma_female, sigma_male) {
specimen_LSI_values <- data.table(Site_No = Site_No, Specimen = paste0(Site_No, ".", 1:(25 * N_Element_Portions)), rbindlist(lapply(1:N_Element_Portions, function(x) data.table(Element_Portion = x, Sex = sample(c("Immature", "Female", "Male"), 25, prob = theta[, Site_No, x], replace = T)))))
specimen_LSI_values[Sex %in% "Immature", LSI_specimen := rnorm(1, mu_immature[Site_No, Element_Portion], sigma_immature[Site_No, Element_Portion]), Specimen]
specimen_LSI_values[Sex %in% "Female", LSI_specimen := rnorm(1, mu_female[Site_No, Element_Portion], sigma_female[Site_No, Element_Portion]), Specimen]
specimen_LSI_values[Sex %in% "Male", LSI_specimen := rnorm(1, mu_male[Site_No, Element_Portion], sigma_male[Site_No, Element_Portion]), Specimen]
specimen_LSI_values
}
specimen_LSI_values <- rbindlist(lapply(1:N_Sites, function(x) specimen_LSI_simulate(Site_No = x, N_Element_Portions = N_Element_Portions, theta = theta, mu_immature = mu_immature, mu_female = mu_female, mu_male = mu_male, sigma_immature = sigma_immature, sigma_female = sigma_female, sigma_male = sigma_male)))
specimen_LSI_values[, Specimen_No := as.numeric(as.factor(Specimen))]
#turn these into broad measurements
#Element_Portion 1: Humerus Bd and Humerus BT
#Element_Portion 2: Radius Bp
#Element_Portion 3: Metacarpal Bp
#Element_Portion 4: Metatarsal Bp
#Element_Portion 5: Astragalus Bd
measurement_LSI_calc <- function(Site_No, Specimen_No, Element_Portion, LSI, N_measurements) {
data.table(Site_No, Specimen_No, Element_Portion, Measurement = paste0(Element_Portion, ".", 1:N_measurements), LSI_measurement = rnorm(N_measurements, LSI, 0.02))
}
measurement_LSI_values <- rbind(
rbindlist(lapply(specimen_LSI_values[Element_Portion %in% 1, Specimen_No], function(x) measurement_LSI_calc(Site_No = specimen_LSI_values[Specimen_No %in% x, Site_No], Specimen_No = x, Element_Portion = 1, LSI = specimen_LSI_values[Specimen_No %in% x, LSI_specimen], 2))),
rbindlist(lapply(specimen_LSI_values[Element_Portion %in% 2, Specimen_No], function(x) measurement_LSI_calc(Site_No = specimen_LSI_values[Specimen_No %in% x, Site_No], Specimen_No = x, Element_Portion = 2, LSI = specimen_LSI_values[Specimen_No %in% x, LSI_specimen], 1))),
rbindlist(lapply(specimen_LSI_values[Element_Portion %in% 3, Specimen_No], function(x) measurement_LSI_calc(Site_No = specimen_LSI_values[Specimen_No %in% x, Site_No], Specimen_No = x, Element_Portion = 3, LSI = specimen_LSI_values[Specimen_No %in% x, LSI_specimen], 1))),
rbindlist(lapply(specimen_LSI_values[Element_Portion %in% 4, Specimen_No], function(x) measurement_LSI_calc(Site_No = specimen_LSI_values[Specimen_No %in% x, Site_No], Specimen_No = x, Element_Portion = 4, LSI = specimen_LSI_values[Specimen_No %in% x, LSI_specimen], 1))),
rbindlist(lapply(specimen_LSI_values[Element_Portion %in% 5, Specimen_No], function(x) measurement_LSI_calc(Site_No = specimen_LSI_values[Specimen_No %in% x, Site_No], Specimen_No = x, Element_Portion = 5, LSI = specimen_LSI_values[Specimen_No %in% x, LSI_specimen], 1)))
)
measurement_values <- measurement_LSI_values[std_animal[!is.na(Measurement), .(EL, Measurement, Measure, Reference_value = Standard)], on = "Measurement"]
measurement_values[, Measurement_value := exp(LSI_measurement) * Reference_value]
#
list(Overall_Parameters = c(grand_theta, grand_mu_immature, grand_mu_female, grand_mu_male, grand_sigma_immature, grand_sigma_female, grand_sigma_male), Site_Parameters = cbind(t(site_theta), site_mu_immature, site_mu_female, site_mu_male, site_sigma_immature, site_sigma_female, site_sigma_male, site_p_immature, site_theta_female), Element_Parameters = list(theta, mu_immature, mu_female, mu_male, sigma_immature, sigma_female, sigma_male), Specimens = specimen_LSI_values, Measurements = measurement_values)
}
priorpredict_sheep_standard_animal <- data.table(referencesDatabase$`Ovis orientalis`$Uerpmann)
priorpredict_sheep_standard_animal[EL %in% "Humerus" & Measure %in% "Bd", Measurement := "1.1"]
priorpredict_sheep_standard_animal[EL %in% "Humerus" & Measure %in% "BT", Measurement := "1.2"]
priorpredict_sheep_standard_animal[EL %in% "Radius" & Measure %in% "Bp", Measurement := "2.1"]
priorpredict_sheep_standard_animal[EL %in% "Metacarpus" & Measure %in% "Bp", Measurement := "3.1"]
priorpredict_sheep_standard_animal[EL %in% "Metatarsus" & Measure %in% "Bp", Measurement := "4.1"]
priorpredict_sheep_standard_animal[EL %in% "Astragalus" & Measure %in% "Bd", Measurement := "5.1"]
```
```{r prior predict (single site), include = FALSE, eval = TRUE}
#Single assemblage run#
priorpredict_iterations <- 1000
singlesite_N_Element_Portions <- 5
singlesite_grand_prior_list <- list(
prior_theta_raw_1 = c(-0.5, 1.5),
prior_theta_raw_2 = c(0, 1.5),
prior_mu_female = c(0, 0.1),
prior_logdelta_immature = c(-3.5, 0.4),
prior_logdelta_male = c(-2.7, 0.1),
prior_logsigma_immature = c(-3.05, 0.1),
prior_logsigma_female = c(-3.1, 0.1),
prior_logsigma_male = c(-3.1, 0.1)
)
singlesite_element_sigma_values <- c(
0.5, #theta_1
0.5, #theta_2
0.05, #mu_female
0.05, #delta_immature
0.05, #delta_male
0.05, #sigma_immature
0.05, #sigma_female
0.05 #sigma_male
)
clusterExport(cl, list('data.table', 'rbindlist', 'rposnorm', 'rho_matrix_maker', 'rlkjcorr_marginal', 'inv.logit', 'LSI_mixture_singlesite_prior_predictive_check', 'singlesite_N_Element_Portions', 'singlesite_grand_prior_list', 'singlesite_element_sigma_values', 'priorpredict_sheep_standard_animal'))
singlesite_predicted_assemblages <- parLapply(cl = cl, 1:priorpredict_iterations, fun = function(x) LSI_mixture_singlesite_prior_predictive_check(N_Element_Portions = singlesite_N_Element_Portions))
```
```{r prior predict (multisite), include = FALSE, eval = TRUE}
multisite_N_Sites <- 3
multisite_N_Element_Portions <- 5
multisite_grand_prior_list <- list(
prior_theta_raw_1 = c(-0.5, 1.5),
prior_theta_raw_2 = c(0, 1.5),
prior_mu_female = c(0, 0.2),
prior_logdelta_immature = c(-3.5, 0.5),
prior_logdelta_male = c(-2.7, 0.2),
prior_logsigma_immature = c(-3.05, 0.1),
prior_logsigma_female = c(-3.1, 0.1),
prior_logsigma_male = c(-3.1, 0.1)
)
multisite_site_sigma_values <- c(
0.5, #theta_1
0.5, #theta_2
0.1, #mu_female
0.1, #delta_immature
0.1, #delta_male
0.05, #sigma_immature
0.05, #sigma_female
0.05 #sigma_male
)
multisite_element_sigma_values <- c(
0.5, #theta_1
0.5, #theta_2
0.05, #mu_female
0.05, #delta_immature
0.05, #delta_male
0.05, #sigma_immature
0.05, #sigma_female
0.05 #sigma_male
)
multisite_interaction_sigma_values <- c(
0.25, #theta_1
0.25, #theta_2
0.05, #mu_female
0.05, #delta_immature
0.05, #delta_male
0.05, #sigma_immature
0.05, #sigma_female
0.05 #sigma_male
)
clusterExport(cl, list('data.table', 'rbindlist', 'rposnorm', 'rho_matrix_maker', 'rlkjcorr_marginal', 'inv.logit', 'LSI_mixture_multisite_prior_predictive_check', 'multisite_N_Sites', 'multisite_N_Element_Portions', 'multisite_grand_prior_list', 'multisite_site_sigma_values', 'multisite_element_sigma_values', 'multisite_interaction_sigma_values', 'priorpredict_sheep_standard_animal'))
multisite_predicted_assemblages <- parLapply(cl = cl, 1:1000, fun = function(x) LSI_mixture_multisite_prior_predictive_check(N_Sites = multisite_N_Sites, N_Element_Portions = multisite_N_Element_Portions))
```
```{r making the prior prediction tables and figures, include = FALSE, eval = TRUE}
#Model Supplement Table 1: the element portions and related measurements
model_supplement_table_1 <- data.table(
`Element Portion` = c("Humerus", "Humerus", "Radius", "Metacarpus", "Metatarsus", "Astragalus"),
`Measured Dimension` = c("Bd", "BT", "Bp", "Bp", "Bp", "Bd"),
`Reference Value (mm)` = c(priorpredict_sheep_standard_animal[!is.na(Measurement)][order(Measurement), Standard])
)
#Model Supplement Figure 1#
singlesite_proportions <- rbindlist(lapply(singlesite_predicted_assemblages, function(x) x$Specimens[, .(Proportion = .N / 125), Sex]))
singlesite_proportion_plot <- ggplot(singlesite_proportions[, .(group = factor(Sex, levels = c("Immature", "Female", "Male")), Proportion)]) + aes(x = group, y = Proportion) +
stat_slab(normalize = "groups", aes(fill = group, fill_ramp = stat(cut_cdf_qi(cdf, .width = c(1, 0.95, 0.80), labels = scales::percent_format())))) +
stat_pointinterval(.width = c(0.8, 0.95), aes(color = group), position = position_dodge(width = 0.2, preserve = "single")) +
scale_fill_ramp_discrete(name = "Interval", range = c(0.8, 0.3), na.translate = F) +
scale_color_manual(name = "Group", values = c("black", "blue", "red"), na.translate = F) +
scale_fill_manual(name = "Group", values = c("black", "blue", "red"), na.translate = F) +
scale_x_discrete(name = NULL, breaks = NULL) +
scale_y_continuous(name = "Proportion", limits = c(0, 1)) +
labs(title = "Single Assemblage") +
theme_classic() + theme(legend.text = element_text(size = 10), legend.position = "bottom", legend.justification = c("center"), legend.box.just = "right", legend.margin = margin(6, 6, 6, 6), axis.text.x = element_text(size = 10), axis.title = element_text(size = 16), axis.text.y = element_text(angle = 90, size = 10, hjust = 0.5))
#
multisite_proportions <- rbindlist(lapply(multisite_predicted_assemblages, function(x) x$Specimens[, .(Proportion = .N / (3 * 125)), Sex]))
multisite_proportion_plot <- ggplot(multisite_proportions[, .(group = factor(Sex, levels = c("Immature", "Female", "Male")), Proportion)]) + aes(x = group, y = Proportion) +
stat_slab(normalize = "groups", aes(fill = group, fill_ramp = stat(cut_cdf_qi(cdf, .width = c(1, 0.95, 0.80), labels = scales::percent_format())))) +
stat_pointinterval(.width = c(0.8, 0.95), aes(color = group), position = position_dodge(width = 0.2, preserve = "single")) +
scale_fill_ramp_discrete(name = "Interval", range = c(0.8, 0.3), na.translate = F) +
scale_color_manual(name = "Group", values = c("black", "blue", "red"), na.translate = F) +
scale_fill_manual(name = "Group", values = c("black", "blue", "red"), na.translate = F) +
scale_x_discrete(name = NULL, breaks = NULL) +
scale_y_continuous(name = "Proportion", limits = c(0, 1)) +
labs(title = "Multisite") +
theme_classic() + theme(legend.text = element_text(size = 10), legend.position = "bottom", legend.justification = c("center"), legend.box.just = "right", legend.margin = margin(6, 6, 6, 6), axis.text.x = element_text(size = 10), axis.title = element_text(size = 16), axis.text.y = element_text(angle = 90, size = 10, hjust = 0.5))
#
singlesite_simulated_proportions <- list(
simulated_p_immature = paste0(100 * round(quantile(singlesite_proportions[Sex %in% "Immature", Proportion], 0.025), 2), "-", 100 * round(quantile(singlesite_proportions[Sex %in% "Immature", Proportion], 0.975), 2), "%"),
simulated_p_female = paste0(100 * round(quantile(singlesite_proportions[Sex %in% "Female", Proportion], 0.025), 2), "-", 100 * round(quantile(singlesite_proportions[Sex %in% "Female", Proportion], 0.975), 2), "%"),
simulated_p_male = paste0(100 * round(quantile(singlesite_proportions[Sex %in% "Male", Proportion], 0.025), 2), "-", 100 * round(quantile(singlesite_proportions[Sex %in% "Male", Proportion], 0.975), 2), "%")
)
#
multisite_simulated_proportions <- list(
simulated_p_immature = paste0(100 * round(quantile(multisite_proportions[Sex %in% "Immature", Proportion], 0.025), 2), "-", 100 * round(quantile(multisite_proportions[Sex %in% "Immature", Proportion], 0.975), 2), "%"),
simulated_p_female = paste0(100 * round(quantile(multisite_proportions[Sex %in% "Female", Proportion], 0.025), 2), "-", 100 * round(quantile(multisite_proportions[Sex %in% "Female", Proportion], 0.975), 2), "%"),
simulated_p_male = paste0(100 * round(quantile(multisite_proportions[Sex %in% "Male", Proportion], 0.025), 2), "-", 100 * round(quantile(multisite_proportions[Sex %in% "Male", Proportion], 0.975), 2), "%")
)
#
singlesite_humbd <- data.table(Model = "Single Assemblage", Hum_Bd = c(sapply(singlesite_predicted_assemblages, function(x) x$Measurements[Measurement %in% "1.1", Measurement_value])))
multisite_humbd <- data.table(Model = "Multisite", Hum_Bd = c(sapply(multisite_predicted_assemblages, function(x) x$Measurements[Measurement %in% "1.1", Measurement_value])))
singlesite_humbd_histogram <- ggplot(data = singlesite_humbd) + aes(x = Hum_Bd) +
geom_histogram(binwidth = 2.5, alpha = 0.8) +
geom_vline(data = data.table(Hum_Bd = priorpredict_sheep_standard_animal[Measurement %in% "1.1", Standard]), aes(xintercept = Hum_Bd), col = "black", linetype = "dashed") +
geom_vline(data = data.table(Hum_Bd = c(25, 39)), aes(xintercept = Hum_Bd), col = "black", linetype = "dotted") +
stat_pointinterval(.width = c(0.8, 0.95), y = -50) +
scale_x_continuous(limits = c(10, 75)) +
labs(x = "Simulated Humerus Bd (mm)", y = "Frequency", title = "", subtitle = "") +
theme_classic() + theme(legend.text = element_text(size = 10), legend.position = "bottom", legend.justification = c("center"), legend.box.just = "right", legend.margin = margin(6, 6, 6, 6), axis.text.x = element_text(angle = 90, size = 10), axis.title = element_text(size = 16), axis.text.y = element_text(angle = 90, size = 10, hjust = 0.5))
multisite_humbd_histogram <- ggplot(data = multisite_humbd) + aes(x = Hum_Bd) +
geom_histogram(binwidth = 2.5, alpha = 0.8) +
geom_vline(data = data.table(Hum_Bd = priorpredict_sheep_standard_animal[Measurement %in% "1.1", Standard]), aes(xintercept = Hum_Bd), col = "black", linetype = "dashed") +
geom_vline(data = data.table(Hum_Bd = c(25, 39)), aes(xintercept = Hum_Bd), col = "black", linetype = "dotted") +
stat_pointinterval(.width = c(0.8, 0.95), y = -50) +
scale_x_continuous(limits = c(10, 75)) +
labs(x = "Simulated Humerus Bd (mm)", y = "Frequency", title = "", subtitle = "") +
theme_classic() + theme(legend.text = element_text(size = 10), legend.position = "bottom", legend.justification = c("center"), legend.box.just = "right", legend.margin = margin(6, 6, 6, 6), axis.text.x = element_text(angle = 90, size = 10), axis.title = element_text(size = 16), axis.text.y = element_text(angle = 90, size = 10, hjust = 0.5))
model_supplement_figure_1 <- ggarrange(singlesite_proportion_plot, multisite_proportion_plot, singlesite_humbd_histogram, multisite_humbd_histogram, nrow = 2, ncol = 2, labels = c("A", "", "B", ""), common.legend = T, legend = "bottom")
Cairo(width = 8, height = 10, units = "in", file = "./Output/Figures/model_supplement_figure_1.png", type = "png", dpi = 600)
model_supplement_figure_1
dev.off()
#text summary#
humbd_summary <- list(
singlesite_humbd_95CI = paste0(round(quantile(singlesite_humbd[, Hum_Bd], c(0.025)), 0), "-", round(quantile(singlesite_humbd[, Hum_Bd], c(0.975)), 0)),
multisite_humbd_95CI = paste0(round(quantile(multisite_humbd[, Hum_Bd], c(0.025)), 0), "-", round(quantile(multisite_humbd[, Hum_Bd], c(0.975)), 0))
)
```
Prior predictive checks were developed for both the single-assemblage and multisite model fits, using the prior distribution definitions used in the sheep simulations in the main text (see Section 5 of the Model Supplement). In each simulation, 25 $\operatorname{LSI}_{\operatorname{Specimen}}$ values were calculated for each of the `r singlesite_N_Element_Portions` element portions based on the relevant prior distributions and model structures; for the multisite simulation, this was done for `r multisite_N_Sites` assemblages. To evaluate the feasibility of these prior distribution definitions, the $\operatorname{LSI}_{\operatorname{Specimen}}$ were converted into simulated measurement values based on the reference values of the *Ovis orientalis* female standard animal (FMC 57951) from Uerpmann and Uerpmann [-@uerpmann_uerpmann_1994: Table 12]. Table 1 shows how the five element portions were converted into measurements from specific dimensions, following the equations in Section 2 of this model supplement. Each simulation was run `r priorpredict_iterations` times, producing `r priorpredict_iterations` assemblages of relevant simulated measurement values.
```{r model_supplement_table_1, echo = FALSE}
kbl(model_supplement_table_1, caption = "Values used to convert simulated LSI values into measurements in the prior predictive simulations. Dimension definitions follow von den Driesch (1976). Reference value refers to the female standard mouflon FMC 57951 (Uerpmann and Uerpmann 1994: Table 12).", booktabs = T, escape = FALSE, linesep = c('', '\\addlinespace', rep('\\addlinespace', 4)))
```
Figure 1 shows two results for the single assemblage (left) and multisite (right) prior prediction simulations. The top row shows the simulated proportions of immature, female, and male specimens in the simulated assemblages (Figure 1A). These proportions were sampled directly from the element-specific mixture proportion variables, showing the range of potential distributions the model is expecting before seeing any data. The 95% quantiles of the single assemblage model's proportion of immature specimens ranges from `r singlesite_simulated_proportions$simulated_p_immature`, `r singlesite_simulated_proportions$simulated_p_female` for female specimens, and `r singlesite_simulated_proportions$simulated_p_male` for male specimens. It is noteworthy that the simulated proportion of immature specimens for the single assemblage model does not reach the extreme value seen in the Pinarbaşı B sheep data, which may explain some of the long tails in the element-specific compositional estimates (Figure 9 of the main text). The multisite model has similar expected ranges (immature: `r multisite_simulated_proportions$simulated_p_immature`, female: `r multisite_simulated_proportions$simulated_p_female`, male: `r multisite_simulated_proportions$simulated_p_male`).
```{r model_supplement_figure_1, echo = FALSE, message = FALSE, warning = FALSE, fig.align = "center", out.width = "\\textwidth", fig.cap = "Single Assemblage and Multisite Prior Predictive Checks. Top row (A): Estimates of the proportion of immature, female, and male specimens. Bottom row (B): Histograms of simulated humerus Bd measurements from the simulations. Vertical lines show the value of the standard reference value (dashed) and two extreme archaeological samples (dotted)."}
knitr::include_graphics("./Output/Figures/model_supplement_figure_1.png")
```
The bottom row shows the distribution of simulated humerus Bd measurements for the assemblages (Figure 1B). These plots include all simulated specimens, showing the range of sheep humerus Bd values the model expects before seeing any data. Several vertical lines on the plots give a sense of domain knowledge about sheep humerus Bd values. First, the standard value (33.0 mm) from the *Ovis orientalis* female standard animal (FMC 57951) from Uerpmann and Uerpmann [-@uerpmann_uerpmann_1994: Table 12] is shown in the red dashed line. Second, vertical blue lines show ranges of observed archaeological sheep humerus Bd values: the largest sheep (technically *Ovis orientalis*) humerus Bd (39.0 mm) from the 10th millennium BP site of Körtik Tepe, in southeastern Anatolia [@arbuckle_ozkaya_2006: Table b] and the smallest sheep (*Ovis aries*) humerus Bd (25.0 mm) from the fifth-sixth century CE site of West Stow, United Kingdom [@crabtree_1990: Table 29]. These plots highlight how the multisite model's structure allows for much more variation in body size, especially large measurements. While the 95% quantiles of the single assemblage model's simulated measurements (`r humbd_summary$singlesite_humbd_95CI` mm) do not exactly encapsulate the range of the observed extreme measurements, the multisite model's simulated measurements go well beyond the range (`r humbd_summary$multisite_humbd_95CI` mm). While one may not expect this full range of measurements in a single assemblage, the results of the prior predictive checks show that the multisite model could plausibly encapsulate variation in body size across diverse assemblages, though possibly at the cost of being somewhat inefficient (i.e., evaluating parameter values that are somewhat beyond reasonable expectations).
These prior predictive checks show that the Bayesian multilevel mixture model's structure is robust for diverse archaeological applications. The chosen prior distribution definitions for the multilevel variation components of the model encapsulate a reasonable range of expected variation and thus do not require extensive retooling as they are applied to new archaeological situations or taxa. Moreover, the multilevel model appears to have enough variability to model drastic changes in body size, making the models' structure relevant for examining broad spatial and temporal variation in animal biometry. While experts are encouraged to use domain knowledge to update and adjust the models to better fit the questions they ask, these models are widely-applicable tools that are suitable for asking many questions about animal body size and the composition of zooarchaeological assemblages.
## References
<div id = "refs"></div>