├── README.md
├── additional-reading.txt
├── day1
├── change-detection
│ ├── advanced-process-models.html
│ ├── advanced-process-models.rmd
│ ├── change-detection.Rmd
│ ├── change-detection.html
│ ├── data
│ │ ├── reshape-rouder-data.R
│ │ ├── rouder08-data-0.5.dat
│ │ └── rouder08-data-full.dat
│ ├── mle-rouder08-group.R
│ ├── mle-rouder08-indiv.R
│ └── pictures
│ │ ├── MUlogoRGB.png
│ │ ├── SP.pdf
│ │ ├── SP.png
│ │ └── rouder08.png
├── intro-to-R
│ ├── data
│ │ ├── example_fun.csv
│ │ ├── example_rm.csv
│ │ └── teachers.RData
│ ├── intro-script.R
│ ├── intro.html
│ ├── intro.rmd
│ └── pictures
│ │ ├── Expectations-reality.png
│ │ ├── MUlogoRGB.png
│ │ └── Rlogo.png
├── intro-to-process-models
│ ├── high-threshold.html
│ ├── high-threshold.rmd
│ ├── pictures
│ │ ├── Expectations-reality.png
│ │ ├── MUlogoRGB.png
│ │ └── Rlogo.png
│ ├── script-for-slides.R
│ ├── signal-detection.html
│ ├── signal-detection.rmd
│ └── stats101.R
└── maximum-likelihood
│ ├── max-lik.Rmd
│ └── max-lik.html
├── day2
├── bayesian-models
│ ├── bayes-cog-models.Rmd
│ ├── bayes-cog-models.html
│ ├── confidence-rating
│ │ ├── HierSDT_model.txt
│ │ ├── fit-selker-model.R
│ │ └── pratte10.RData
│ ├── delayed-estimation
│ │ ├── jags-zhang-luck08.R
│ │ ├── mle-zhang-luck08.R
│ │ ├── models
│ │ │ ├── mixture_k.txt
│ │ │ ├── z-l-mixture.txt
│ │ │ └── z-l-resource.txt
│ │ └── zhang-luck08.dat
│ ├── jags-change-det
│ │ ├── jags-rouder08.R
│ │ ├── rouder08-longdata-0.5.dat
│ │ └── rouder08-longdata-full.dat
│ └── pictures
│ │ └── zhang-luck.png
├── change-detection
│ ├── advanced-process-models.html
│ ├── advanced-process-models.rmd
│ ├── change-detection.Rmd
│ ├── change-detection.html
│ ├── data
│ │ ├── reshape-rouder-data.R
│ │ ├── rouder08-data-0.5.dat
│ │ └── rouder08-data-full.dat
│ ├── mle-rouder08-group.R
│ ├── mle-rouder08-indiv.R
│ └── pictures
│ │ ├── MUlogoRGB.png
│ │ ├── SP.pdf
│ │ ├── SP.png
│ │ └── rouder08.png
└── intro-to-bayes
│ ├── bayes-jags-intro.Rmd
│ ├── bayes-jags-intro.html
│ ├── metropolis-example.R
│ ├── rjags-basic-hier.R
│ └── rjags-basics.R
├── gettingstarted.txt
├── mcpr-description.Rmd
└── mcpr-description.pdf
/README.md:
--------------------------------------------------------------------------------
1 | # Workshop on Mathematical Modeling of Cognitive Processes
2 |
3 | This workshop is developed by Stephen Rhodes (@stephenrho) and Julia Haaf (@JuliaHaaf) at the Department of Psychological Sciences, University of Missouri.
4 |
5 | ## Description
6 |
7 | Cognitive process models provide a powerful tool to disentangle different cognitive processes contributing to the same observable responses. These models are successfully applied in many fields of psychology (e.g., memory, decision making, and social cognition). This two day workshop covers the essentials of cognitive modeling using the programming language `R`. Attendees will be introduced to several commonly used models in cognitive psychology and how to fit them using both maximum likelihood and hierarchical Bayesian methods. While the workshop is specifically aimed at graduate students in cognitive psychology, this workshop will be of interest to anyone looking to build their `R` modeling skills.
8 |
9 | ## Prerequisites
10 |
11 | These are not absolutely required but would be useful:
12 |
13 | - Passing familiarity with the [`R` programming language](https://www.r-project.org/). You can find a free online introduction [here](https://www.datacamp.com/courses/free-introduction-to-r).
14 | - Familiarity with statistical concepts such as likelihood.
15 |
16 | ## Plan
17 |
18 | | **Day** | **Topic** |
19 | | --------------- | ------------------------------------------------------------------------------------------- |
20 | | 1. Morning | Introduction to R; Introduction to Maximum Likelihood |
21 | | 1. Afternoon | Modeling groups: Signal-detection theory and Multinomial Processing Tree Models I |
22 | | 2. Morning | Modeling individuals: SDT and MPT II |
23 | | 2. Afternoon | Bayesian hierarchical process modeling |
24 |
--------------------------------------------------------------------------------
/additional-reading.txt:
--------------------------------------------------------------------------------
1 |
2 | # Suggested readings (in addition to references in the slides)
3 |
4 | Efron and Morris (1977) - on shrinkage
5 | http://statweb.stanford.edu/~ckirby/brad/other/Article1977.pdf
6 |
7 |
8 | Rouder & Morey (2018) - teaching Bayes' theorem
9 | https://osf.io/qnguh/
10 |
11 |
12 | An interesting set of blog posts on Bayesian estimation of SDT models in R using Stan via the package brms
13 | https://vuorre.netlify.com/post/2017/bayesian-estimation-of-signal-detection-theory-models-part-1/
14 |
15 |
16 | Aho et al. (2014) - on AIC and BIC
17 | https://sciences.ucf.edu/biology/d4lab/wp-content/uploads/sites/125/2017/01/Aho-etal-2014.pdf
--------------------------------------------------------------------------------
/day1/change-detection/advanced-process-models.rmd:
--------------------------------------------------------------------------------
1 | ---
2 | title: "Advanced Modeling Options"
3 | author: "Julia Haaf & Stephen Rhodes"
4 | output:
5 | ioslides_presentation:
6 | logo: pictures/MUlogoRGB.png
7 | widescreen: true
8 | ---
9 |
10 | ```{r setup, echo = F, warning=FALSE}
11 | # MLE Rouder et al (2008) PNAS
12 | cd = read.table(file = "data/rouder08-data-0.5.dat")
13 |
14 | # the data frame gives numbers of hits, misses, false-alarms, and correct rejections
15 | # for three set sizes: N = 2,5,8
16 | N = c(2,5,8)
17 | N_i = rep(1:length(N), each=4) # index
18 |
19 | #Multinomial Negative Log-Likelihood
20 | negLL <- function(y,p){
21 | a=ifelse(y==0 & p==0,0, y*log(p))
22 | -sum(a)
23 | }
24 |
25 | cowan_k <- function(k, a, g, N){
26 | d = min(1,k/N) # p(probe in memory)
27 | p = 1:4
28 | p[1] = a*(d+(1-d)*g)+(1-a)*g # p(hit)
29 | p[2] = 1-p[1] # p(miss)
30 | p[3] = a*(1-d)*g+(1-a)*g # p(false-alarm)
31 | p[4] = 1-p[3] # p(correct rejection)
32 | return(p)
33 | }
34 |
35 | sdt <- function(d, c, s){
36 | # this is a simplified version of the sdt
37 | # model used by rouder et al.
38 | p = 1:4
39 | p[1] = pnorm((d - c)/s) # p(hit)
40 | p[2] = 1 - p[1] # p(miss)
41 | p[3] = pnorm(- c) # p(false-alarm)
42 | p[4] = 1 - p[3] # p(correct rejection)
43 | return(p)
44 | }
45 |
46 | # Likelihood functions
47 |
48 | ## Binomial Model
49 | ll.vacuous <- function(y){
50 | ll = 0
51 | lenY = length(y)
52 | y1 = y[rep(c(T, F), lenY/2)]
53 | y2 = y[rep(c(F, T), lenY/2)]
54 | n = (rep((y1+y2), each=2))
55 | p = y/n
56 | ll = negLL(y, p)
57 | return(ll)
58 | }
59 |
60 | ## Fixed Capacity Model
61 | ll.fixed_k <- function(par, y){
62 | # length(par) == 3 (k, a, g)
63 | ll = 0
64 | for(i in 1:length(N)){ # for each set size
65 | p = cowan_k(k = par[1], a = par[2], g = par[3], N = N[i])
66 | ll = ll + negLL(y[N_i==i], p)
67 | }
68 | if(any(c(par < rep(0,3), par > c(max(N),1,1)))){
69 | ll = ll + 10000 # penalty for going out of range
70 | }
71 | return(ll)
72 | }
73 |
74 | ## Varying Capacity Model
75 | ll.vary_k <- function(par, y){
76 | # length(par) == 5 (k*3, a, g)
77 | ll=0
78 | for(i in 1:length(N)){ # for each set size
79 | p = cowan_k(k = par[i], a = par[4], g = par[5], N = N[i])
80 | ll = ll + negLL(y[N_i==i], p)
81 | }
82 | if(any(c(par < rep(0,5), par > c(rep(max(N), 3),1,1)))){
83 | ll = ll + 10000 # penalty for going out of range
84 | }
85 | return(ll)
86 | }
87 |
88 | ## Equal-Variance Signal Detection Model
89 | ll.sdt.ev <- function(par, y){
90 | # length(par) == 4 (d1, d2, d3, c)
91 | ll=0
92 | for(i in 1:length(N)){ # for each set size
93 | p = sdt(d = par[i], c = par[length(N)+1], s = 1)
94 | ll = ll + negLL(y[N_i==i], p)
95 | }
96 | return(ll)
97 | }
98 |
99 | # function to calculate fit statistics from -LL
100 | fit_stats <- function(nLL, n, p){
101 | # nLL = negative log liklihood
102 | # n = number of observations
103 | # p = number of parameters
104 |
105 | deviance = 2*nLL
106 | aic = deviance + 2*p
107 | bic = deviance + p*log(n)
108 |
109 | return(list("D" = deviance, "AIC" = aic, "BIC" = bic))
110 | }
111 | #### FIT TO INDIVIDUALS ----
112 |
113 | S = nrow(cd) # number of participants
114 |
115 | # create matrices to hold the resulting parameter estimates
116 | # 1 row per participant, 1 column per parameter
117 | estimates_fix_k <- matrix(NA, nrow = S, ncol = 3)
118 | colnames(estimates_fix_k) <- c("k", "a", "g")
119 |
120 | estimates_vary_k <- matrix(NA, nrow = S, ncol = 5)
121 | colnames(estimates_vary_k) <- c("k1", "k2", "k3", "a", "g")
122 |
123 | estimates_sdt <- matrix(NA, nrow = S, ncol = 4)
124 | colnames(estimates_sdt) <- c("d1", "d2", "d3", "c")
125 |
126 | # create a matrix to hold the -log likelihood for each individual (row)
127 | # and each model (col)
128 | fit_statistics <- matrix(NA, nrow = S, ncol = 5)
129 | colnames(fit_statistics) <- c("LL_vac", "LL_fix_k", "LL_vary_k", "LL_sdt", "N_obs")
130 |
131 | # this loop takes the data from each row (participant) and fits the three models
132 | for (s in 1:S){
133 | # get the data for this subject
134 | tmp.dat = as.integer(cd[s,])
135 |
136 | # model that freely estimates response frequencies
137 | fit_statistics[s,1] <- ll.vacuous(y = tmp.dat)
138 |
139 | # fixed k
140 | par = runif(n = 3, min = 0, max = c(max(N), 1, 1))
141 | k_res_s = optim(par, ll.fixed_k, y = tmp.dat)
142 |
143 | fit_statistics[s,2] <- k_res_s$value # add estimates and LL to matrices
144 | estimates_fix_k[s,] <- k_res_s$par
145 |
146 | # variable k
147 | par = runif(n = 5, min = 0, max = c(rep(max(N),3), 1, 1))
148 | vary_k_res_s = optim(par, ll.vary_k, y = tmp.dat)
149 |
150 | fit_statistics[s,3] <- vary_k_res_s$value
151 | estimates_vary_k[s,] <- vary_k_res_s$par
152 |
153 | ## sdt model
154 | par = runif(n = 4, min = 0, max = c(5, 5, 5, 5))
155 | sdt_res_s = optim(par, ll.sdt.ev, y = tmp.dat)
156 |
157 | fit_statistics[s,4] <- sdt_res_s$value
158 | estimates_sdt[s,] <- sdt_res_s$par
159 |
160 | fit_statistics[s,5] = sum(tmp.dat)
161 | }
162 | # remove stuff we no longer need...
163 | rm(list = c("tmp.dat", "k_res_s", "vary_k_res_s", "sdt_res_s"))
164 | ```
165 |
166 | ## Good To Know
167 |
168 | - Advanced models
169 | - General high-threshold model
170 | - Unequal-variance signal detection model
171 | - Model comparison with "unrelated" models
172 | - AIC
173 | - BIC
174 | - Problems & Fixes: Null counts
175 |
176 | # Advanced Models
177 |
178 | ## General High-Threshold Model (GHT)
179 |
180 | Extension of the double-high-threshold model
181 |
182 | ```{r twohtmodelb,engine='tikz',fig.ext='svg',fig.width=7, echo = F, fig.align='center'}
183 | \begin{tikzpicture}[level 1/.style={sibling distance=4cm}, level 2/.style={sibling distance=3cm}, grow=right, yscale=-1, xscale=1.4]
184 |
185 | % target tree
186 | \node [rectangle, draw] (a) {Signal}
187 | child {node [rectangle, draw] (b) {Detect Signal} % detect
188 | child {node [rectangle, draw] (c) [anchor=west] {hit}}}
189 | child {node [rectangle, draw] (d) {Fail to Detect} % not detect
190 | child {node [rectangle, draw] (e) [anchor=west] {hit}}
191 | child {node [rectangle, draw] (f) [anchor=west] {miss}}};
192 | % non-target tree
193 | \node [rectangle, draw] (g) [right =6.5cm] {Noise}
194 | child {node [rectangle, draw] (h) {Detect Noise} % detect
195 | child {node [rectangle, draw] (i) [anchor=west] {correct rejection}}}
196 | child {node [rectangle, draw] (j) {Fail to Detect} % not detect
197 | child {node [rectangle, draw] (k) [anchor=west] {false alarm}}
198 | child {node [rectangle, draw] (l) [anchor=west] {correct rejection}}};
199 | % add lines and labels
200 | \draw[->,>=stealth] (a) -- node[midway,fill=white] {$d$} (b);
201 | \draw[->,>=stealth] (a) -- node[midway,fill=white] {$1 - d$} (d);
202 | \draw[->,>=stealth] (d) -- node[midway,fill=white] {$g$} (e);
203 | \draw[->,>=stealth] (d) -- node[midway,fill=white] {$1 - g$} (f);
204 | \draw[->,>=stealth] (b) -- (c);
205 | \draw[->,>=stealth] (g) -- node[midway,fill=white] {$d$} (h);
206 | \draw[->,>=stealth] (g) -- node[midway,fill=white] {$1 - d$} (j);
207 | \draw[->,>=stealth] (j) -- node[midway,fill=white] {$g$} (k);
208 | \draw[->,>=stealth] (j) -- node[midway,fill=white] {$1 - g$} (l);
209 | \draw[->,>=stealth] (h) -- (i);
210 |
211 | \end{tikzpicture}
212 | ```
213 |
214 | ## General High-Threshold Model
215 |
216 | ```{r ghtmodelb,engine='tikz',fig.ext='svg',fig.width=7, echo = F, fig.align='center'}
217 | \begin{tikzpicture}[level 1/.style={sibling distance=4cm}, level 2/.style={sibling distance=3cm}, grow=right, yscale=-1, xscale=1.4]
218 |
219 | % target tree
220 | \node [rectangle, draw] (a) {Signal}
221 | child {node [rectangle, draw] (b) {Detect Signal} % detect
222 | child {node [rectangle, draw] (c) [anchor=west] {hit}}}
223 | child {node [rectangle, draw] (d) {Fail to Detect} % not detect
224 | child {node [rectangle, draw] (e) [anchor=west] {hit}}
225 | child {node [rectangle, draw] (f) [anchor=west] {miss}}};
226 | % non-target tree
227 | \node [rectangle, draw] (g) [right =6.5cm] {Noise}
228 | child {node [rectangle, draw] (h) {Detect Noise} % detect
229 | child {node [rectangle, draw] (i) [anchor=west] {correct rejection}}}
230 | child {node [rectangle, draw] (j) {Fail to Detect} % not detect
231 | child {node [rectangle, draw] (k) [anchor=west] {false alarm}}
232 | child {node [rectangle, draw] (l) [anchor=west] {correct rejection}}};
233 | % add lines and labels
234 | \draw[->,>=stealth] (a) -- node[midway,fill=white] {$\mathbf{d_s}$} (b);
235 | \draw[->,>=stealth] (a) -- node[midway,fill=white] {$1 - \mathbf{d_s}$} (d);
236 | \draw[->,>=stealth] (d) -- node[midway,fill=white] {$g$} (e);
237 | \draw[->,>=stealth] (d) -- node[midway,fill=white] {$1 - g$} (f);
238 | \draw[->,>=stealth] (b) -- (c);
239 | \draw[->,>=stealth] (g) -- node[midway,fill=white] {$\mathbf{d_n}$} (h);
240 | \draw[->,>=stealth] (g) -- node[midway,fill=white] {$1 - \mathbf{d_n}$} (j);
241 | \draw[->,>=stealth] (j) -- node[midway,fill=white] {$g$} (k);
242 | \draw[->,>=stealth] (j) -- node[midway,fill=white] {$1 - g$} (l);
243 | \draw[->,>=stealth] (h) -- (i);
244 |
245 | \end{tikzpicture}
246 | ```
247 |
248 | ## General High-Threshold Model
249 |
250 | Let's go back to the change-detection example. How would we fit a general high-threshold version of the fixed-capacity model?
251 |
252 | >- Does it even make sense?
253 | >- Here, $d = k/n$
254 | >- Does it make sense that there are separate capacities for items in memory and items *not* in memory?
255 | >- Identifiability issues
256 |
257 | ```{r, echo = F, message=F, warning=F}
258 | group_data = apply(cd, 2, sum)
259 | # starting values
260 | par = runif(n = 5, min = 0, max = c(rep(max(N),3), 1, 1))
261 | vary_k_res = optim(par, ll.vary_k, y = group_data)
262 |
263 | parameter.estimates <- vary_k_res$par
264 | names(parameter.estimates) <- c("k2", "k5", "k8", "a", "g")
265 | ```
266 |
267 | ## Unequal Variance Signal Detection Model (UVSD)
268 |
269 | Equal variance:
270 |
271 | ```{r echo = F}
272 | x <- seq(-3, 5, .01)
273 | y.noise <- dnorm(x)
274 | y.signal <- dnorm(x, 1.5)
275 |
276 | plot(x, y.noise
277 | , type = "l", lwd = 2
278 | , xlim = range(x)
279 | , frame.plot = F
280 | , ylab = "Density"
281 | , xlab = "Sensory Strength"
282 | )
283 | lines(x, y.signal, col = "firebrick4", lwd = 2)
284 | # make.line(0)
285 | # make.line(1.5, 1.5)
286 | abline(v = 1, lwd = 2, col = "darkgreen")
287 | axis(3, at = c(0, 1.5), labels = c("", ""))
288 | mtext("d'", 3, line = .5, at = .75, cex = 1.3)
289 | text(1.2, .03, "c", cex = 1.3)
290 | text(-2, .25, "Stimulus absent")
291 | text(3.5, .25, "Stimulus present")
292 | ```
293 |
294 | ## Unequal Variance Signal Detection Model (UVSD)
295 |
296 | Let mean *and* variance vary for signal distribution!
297 |
298 | ```{r echo = F}
299 | x <- seq(-3, 5, .01)
300 | y.noise <- dnorm(x)
301 | y.signal <- dnorm(x, 1.5, 1.5)
302 |
303 | plot(x, y.noise
304 | , type = "l", lwd = 2
305 | , xlim = range(x)
306 | , frame.plot = F
307 | , ylab = "Density"
308 | , xlab = "Sensory Strength"
309 | )
310 | lines(x, y.signal, col = "firebrick4", lwd = 2)
311 | # make.line(0)
312 | # make.line(1.5, 1.5)
313 | abline(v = 1, lwd = 2, col = "darkgreen")
314 | axis(3, at = c(0, 1.5), labels = c("", ""))
315 | mtext("d'", 3, line = .5, at = .75, cex = 1.3)
316 | text(1.2, .03, "c", cex = 1.3)
317 | text(-2, .25, "Stimulus absent")
318 | text(3.5, .25, "Stimulus present")
319 | ```
320 | ## UVSD for change detection
321 |
322 | ```{r, echo = F}
323 |
324 | par(mar=c(4,3,1,1))
325 | curve(expr = dnorm(x, 0, 1), from = -3, to = 6, xlab="Strength of evidence for 'change'", ylab="", lwd=2)
326 |
327 | curve(expr = dnorm(x, 1, 1.2), col="tomato", from = -3, to = 6, lwd=2, add = T)
328 | curve(expr = dnorm(x, 2, 1.2), col="forestgreen", from = -3, to = 6, lwd=2, add = T)
329 | curve(expr = dnorm(x, 3, 1.2), col="dodgerblue", from = -3, to = 6, lwd=2, add = T)
330 |
331 | legend("topleft", legend = c(2,5,8), lty = 1, col = c("dodgerblue", "forestgreen","tomato"), title = "N", lwd=2, bty='n')
332 |
333 | ```
334 |
335 | ## Even more UVSD for change detection
336 |
337 | ```{r echo = F}
338 |
339 | par(mar=c(4,3,1,1))
340 | curve(expr = dnorm(x, 0, 1), from = -3, to = 6, xlab="Strength of evidence for 'change'", ylab="", lwd=2)
341 |
342 | curve(expr = dnorm(x, 1, 1.5), col="tomato", from = -3, to = 6, lwd=2, add = T)
343 | curve(expr = dnorm(x, 2, 1.2), col="forestgreen", from = -3, to = 6, lwd=2, add = T)
344 | curve(expr = dnorm(x, 3, 2), col="dodgerblue", from = -3, to = 6, lwd=2, add = T)
345 |
346 | legend("topleft", legend = c(2,5,8), lty = 1, col = c("dodgerblue", "forestgreen","tomato"), title = "N", lwd=2, bty='n')
347 |
348 | ```
349 |
350 | ## Unequal Variance Signal Detection Model (UVSD)
351 |
352 | Downside:
353 |
354 | >- This is an extremely flexible mode
355 | >- Can fit nearly all data patterns
356 | >- Not that many parameters
357 | >- Often preferred in frequentist model comparison
358 | >- Interpretation difficult
359 |
360 | ## Unequal Variance Signal Detection Model (UVSD)
361 |
362 | ```{r}
363 | ## Unequal-Variance Signal Detection Model
364 | ll.sdt.uv <- function(par, y){
365 | # length(par) == 7 (d1, d2, d3, c, s1, s2, s3)
366 | ll=0
367 | for(i in 1:length(N)){ # for each set size
368 | p = sdt(d = par[i], c = par[length(N) + 1], s = par[length(N) + 1 + i])
369 | ll = ll + negLL(y[N_i==i], p)
370 | }
371 | if(any(par[5:7] < rep(0,3))){
372 | ll = ll + 10000} # penalty for going out of range
373 | return(ll)
374 | }
375 | ```
376 |
377 | ## Unequal Variance Signal Detection Model (UVSD) {.smaller}
378 |
379 | ```{r}
380 | ## fit uvsd model
381 | par = runif(n = 7, min = .1, max = 3)
382 | sdt_res_uv = optim(par, ll.sdt.uv, y = group_data)
383 | sdt_res_uv$par
384 |
385 | ## fit evsd model
386 | par = runif(n = 4, min = .1, max = 3)
387 | sdt_res = optim(par, ll.sdt.ev, y = group_data)
388 | sdt_res$par
389 |
390 | c(sdt_res_uv$value, sdt_res$value)
391 | ```
392 |
393 | # Model comparison
394 |
395 | ## Model comparison with "unrelated" models
396 |
397 | >- $\chi^2$-test with $G^2 = 2(LL_g - LL_r)$ only works with nested models
398 | >- We can compare UVSD to EVSD, or Varying Capacity to Fixed Capacity
399 | >- We cannot compare EVSD to Fixed Capacity with the $G^2$-test
400 | >- Needed: Test statistic that rewards low likelihood values and punishes complexity
401 | >- AIC and BIC
402 |
403 | ##Akaike information criterion (AIC)
404 |
405 | \[AIC = - 2 \log(L) + 2 p,\]
406 |
407 | where $m$ is the number of parameters and $- 2 \log(L)$ is two times the negative log likelihood.
408 |
409 | ##Bayesian information criterion (BIC)
410 |
411 | \[AIC = - 2 \log(L) + 2 p,\]
412 |
413 | where $p$ is the number of parameters and $- 2 \log(L)$ is two times the negative log likelihood.
414 |
415 | \[BIC = - 2 \log(L) + p \log(n),\]
416 |
417 | where $n$ is the number of observations.
418 |
419 | *Q:* Do you want higher or lower values of AIC/BIC?
420 |
421 | ## AIC and BIC in R
422 |
423 | ```{r}
424 | # function to calculate fit statistics from -LL
425 | fit_stats <- function(nLL, n, p){
426 | # nLL = negative log liklihood
427 | # n = number of observations
428 | # p = number of parameters
429 |
430 | deviance = 2*nLL
431 | aic = deviance + 2*p
432 | bic = deviance + p*log(n)
433 |
434 | return(list("D" = deviance, "AIC" = aic, "BIC" = bic))
435 | }
436 | ```
437 |
438 | ## AIC and BIC in R
439 |
440 | ```{r, echo = F, warning = F}
441 | ## fit k model
442 | # starting values
443 | par = runif(n = 3, min = 0, max = c(max(N), 1, 1))
444 | k_res = optim(par, ll.fixed_k, y = group_data)
445 |
446 | # starting values
447 | par = runif(n = 5, min = 0, max = c(rep(max(N),3), 1, 1))
448 | vary_k_res = optim(par, ll.vary_k, y = group_data)
449 |
450 | ## fit sdt model
451 | par = runif(n = 4, min = 0, max = c(5, 5, 5, 5))
452 | sdt_res = optim(par, ll.sdt.ev, y = group_data)
453 | ```
454 |
455 |
456 | ```{r}
457 | sdt_fit = fit_stats(nLL = sdt_res$value, n = sum(group_data), p = 4)
458 | k_fit = fit_stats(nLL = k_res$value, n = sum(group_data), p = 3)
459 | vary_k_fit = fit_stats(nLL = vary_k_res$value, n = sum(group_data), p = 5)
460 |
461 | c(sdt_fit$AIC, k_fit$AIC, vary_k_fit$AIC)
462 |
463 | c(sdt_fit$BIC, k_fit$BIC, vary_k_fit$BIC)
464 | ```
465 |
466 | ## AIC and BIC in R
467 |
468 | ```{r}
469 | sdt_fit = fit_stats(nLL = sdt_res$value, n = sum(group_data), p = 4)
470 | k_fit = fit_stats(nLL = k_res$value, n = sum(group_data), p = 3)
471 | vary_k_fit = fit_stats(nLL = vary_k_res$value, n = sum(group_data), p = 5)
472 |
473 | c(sdt_fit$AIC, k_fit$AIC, vary_k_fit$AIC)
474 |
475 | c(sdt_fit$BIC, k_fit$BIC, vary_k_fit$BIC)
476 | ```
477 |
478 | Remember: The lower the better
479 |
480 | ## AIC and BIC
481 |
482 | >- Can also be used to compare model fit for all individuals independently
483 | >- A landscape of information criterial
484 | >- s (participants) x m (models) AIC or BIC
485 | >- Who is fit best by model m?
486 | >- Which model fits participant s' data best?
487 | >- Go to `mle-rouder08-indiv.R`
488 |
489 | ## AIC and BIC for individuals
490 |
491 | 1. Fit models to all individuals using a `for()`-loop
492 | 2. Extract negative log likelihood value and calculate AIC/BIC
493 | 3. Summarize in a table
494 | 4. Which mode is preferred for which participant?
495 |
496 |
497 |
498 | # Problems & Fixes: Null counts
499 |
500 | ## Null counts
501 |
502 | >- Occasional absence of either miss or false-alarm event
503 | >- Especially problematic for SDT
504 | >- Especially problematic when fitting models to individuals' data
505 |
506 | ## Null counts {.build}
507 |
508 | There is an easy fix:
509 |
510 | \[
511 | \hat{p}_h = \frac{y_h + .5}{N_s + 1}, \\
512 | \hat{p}_f = \frac{y_f + .5}{N_f + 1}.
513 | \]
514 |
515 | This is done by adding $+.5$ to each observed cell count
516 |
517 | ## Null counts
518 |
519 | This is done by adding $+.5$ to each observed cell count
520 |
521 | ```{r, eval = F}
522 | # this loop takes the data from each row (participant) and fits the three models
523 | for (s in 1:S){
524 | # get the data for this subject
525 | tmp.dat = as.integer(cd[s,]) + .5
526 |
527 | # model that freely estimates response frequencies
528 | fit_statistics[s,1] <- ll.vacuous(y = tmp.dat)
529 |
530 | ...
531 | ```
532 |
533 | You can find the code at the end of `mle-rouder08-indiv.R`
534 |
--------------------------------------------------------------------------------
/day1/change-detection/change-detection.Rmd:
--------------------------------------------------------------------------------
1 | ---
2 | title: "Models for Change Detection"
3 | author: "Stephen Rhodes and Julia Haaf"
4 | output:
5 | ioslides_presentation:
6 | logo: ../../day1/intro-to-R/pictures/MUlogoRGB.png
7 | widescreen: true
8 | subtitle: Analyzing Rouder et al. (2008)
9 | ---
10 |
11 | ```{r setup, include=FALSE}
12 | knitr::opts_chunk$set(echo = FALSE)
13 | ```
14 |
15 | ## Change Detection
16 |
17 |
18 | [Rouder et al. (2008)](http://www.pnas.org/content/105/16/5975)
19 |
20 |
21 |
22 | 
23 |
24 |
25 |
26 |
27 |
28 | - Is there a fixed capacity limit to visual working memory?
29 | - Manipulated:
30 | - set size (number of items to remember): 2, 5, or 8
31 | - probability of a change occuring: 30%, 50%, or 70% of trials
32 |
33 |
34 |
35 | ## Change Detection
36 |
37 | - Cowan (2001) suggested a way of estimating the number of items in working memory, $k$, using the change detection task
38 | - $d = \min(k/N, 1)$ = probability that the probed item is in memory
39 | - If the probed item is in memory the participant responds correctly. If it isn't, they must guess:
40 | - $p(\mbox{resp} = \mbox{change} \mid \mbox{change}) = p_h = d + (1 - d)g$
41 | - $p(\mbox{resp} = \mbox{change} \mid \mbox{no-change}) = p_f = (1 - d)g$
42 | - This gives a formula for $k$:
43 | - $p_h = k/N + p_f \rightarrow k = N(p_h - p_f)$
44 |
45 | ## Change Detection
46 |
47 | - But this formula only works one set size at a time and doesn't work for $k > N$
48 | - Rouder et al. (2008) used MLE to fit a single $k$ across multiple set sizes
49 | - This model didn't fit very well...
50 | - At set size 2 the model predicted perfect performance, but none of the participants performed absolutely perfectly
51 | - To account for errors at low set sizes they added an attention parameter, $a$, which was the probability that the participant attended a given trial. $1 - a$ is their lapse rate.
52 |
53 | ## The extension for 'lapsing'
54 |
55 | If people lapse, they guess
56 |
57 | $$
58 | p(\mbox{resp} = \mbox{change} \mid \mbox{change}) = p_h = a(d + (1 - d)g) + (1 - a)g
59 | $$
60 |
61 | $$
62 | p(\mbox{resp} = \mbox{change} \mid \mbox{no-change}) = p_f = a(1 - d)g + (1 - a)g
63 | $$
64 |
65 | ## Result
66 |
67 | ```{r, out.width = "400px", echo=F}
68 | knitr::include_graphics("pictures/rouder08.png")
69 | ```
70 |
71 | ## Other models
72 |
73 | - Rouder et al. (2008) also considered a version of the model where $k$ was free to vary by set size. The fixed capacity version faired better.
74 |
75 | - They also fit a signal detection theory model, where the probe is always assumed to be in memory. Set size is assumed to reduce sensitivity as a resource is spread more thinly across the items.
76 |
77 | ## SDT model
78 |
79 | ```{r}
80 |
81 | par(mar=c(4,3,1,1))
82 | curve(expr = dnorm(x, 0, 1), from = -3, to = 6, xlab="Strength of evidence for 'change'", ylab="", lwd=2)
83 |
84 | curve(expr = dnorm(x, 1, 1.2), col="tomato", from = -3, to = 6, lwd=2, add = T)
85 | curve(expr = dnorm(x, 2, 1.2), col="forestgreen", from = -3, to = 6, lwd=2, add = T)
86 | curve(expr = dnorm(x, 3, 1.2), col="dodgerblue", from = -3, to = 6, lwd=2, add = T)
87 |
88 | legend("topleft", legend = c(2,5,8), lty = 1, col = c("dodgerblue", "forestgreen","tomato"), title = "N", lwd=2, bty='n')
89 |
90 | ```
91 |
92 | # Implementing these models in R
93 |
94 | ## Implementing these models in R
95 |
96 | We need three elements
97 |
98 | - A `function()` to generate the predictions from the models given some parameter settings
99 | - A `function()` to calculate the likelihood of the parameters given the data
100 | - A `function()` that combines the above two into a specific version of the model (e.g. one that restricts certain parameters)
101 |
102 | ## Implementing these models in R
103 |
104 | We need to write this function with an understanding of what form the data are in.
105 |
106 | The data are given with one participant per row with numbers of *hits*, *misses*, *false alarms*, and *correct rejections* (order is important) for each set size.
107 |
108 | *Note* we only look at the data from the 50% change condition to simplify things.
109 |
110 | ```{r, echo=T}
111 | cd = read.table(file = "data/rouder08-data-0.5.dat")
112 | head(cd, n = 1)
113 | ```
114 |
115 | ## Prediction functions | Fixed capacity model
116 |
117 | With that in mind we make our prediction functions return in the same order
118 |
119 | ```{r, echo=T}
120 | cowan_k <- function(k, a, g, N){
121 | d = min(1,k/N) # p(probe in memory)
122 |
123 | p = 1:4
124 | p[1] = a*(d+(1-d)*g)+(1-a)*g # p(hit)
125 | p[2] = 1-p[1] # p(miss)
126 | p[3] = a*(1-d)*g+(1-a)*g # p(false-alarm)
127 | p[4] = 1-p[3] # p(correct rejection)
128 | return(p)
129 | }
130 | ```
131 |
132 | ## Prediction functions | Signal detection model
133 |
134 | With that in mind we make our prediction functions return in the same order
135 |
136 | ```{r, echo=T}
137 | sdt <- function(d, c, s){
138 | # this is a simplified version of the sdt
139 | # model used by rouder et al.
140 | p = 1:4
141 | p[1] = pnorm((d - c)/s) # p(hit)
142 | p[2] = 1 - p[1] # p(miss)
143 | p[3] = pnorm(- c) # p(false-alarm)
144 | p[4] = 1 - p[3] # p(correct rejection)
145 | return(p)
146 | }
147 | ```
148 |
149 | ## Likelihood function
150 |
151 | ```{r, echo=T, eval=F}
152 | # Multinomial Negative Log-Likelihood
153 | negLL <- function(y,p){
154 | a=ifelse(y==0 & p==0,0, y*log(p))
155 | -sum(a)
156 | }
157 | # this seems to work better than dmultinom
158 | ```
159 |
160 | ## Model functions | Fixed capacity model
161 |
162 | ```{r, echo = T}
163 | N = c(2,5,8)
164 | N_i = rep(1:length(N), each=4) # index
165 |
166 | # fixed capacity model
167 | ll.fixed_k <- function(par, y){
168 | # length(par) == 3 (k, a, g)
169 | ll=0
170 | for(i in 1:length(N)){ # for each set size
171 | p = cowan_k(k = par[1], a = par[2], g = par[3], N = N[i])
172 | ll = ll + negLL(y[N_i==i], p)
173 | }
174 | if(any(c(par < rep(0,3), par > c(max(N),1,1)))){
175 | ll = ll + 10000 # penalty for going out of range
176 | }
177 | return(ll)
178 | }
179 | ```
180 |
181 | ## Model functions | Variable capacity model
182 |
183 | ```{r, echo = T}
184 | N = c(2,5,8)
185 | N_i = rep(1:length(N), each=4) # index
186 |
187 | # variable capacity model
188 | ll.vary_k <- function(par, y){
189 | # length(par) == 5 (k*3, a, g)
190 | ll=0
191 | for(i in 1:length(N)){ # for each set size
192 | p = cowan_k(k = par[i], a = par[4], g = par[5], N = N[i])
193 | ll = ll + negLL(y[N_i==i], p)
194 | }
195 | if(any(c(par < rep(0,5), par > c(rep(max(N), 3),1,1)))){
196 | ll = ll + 10000 # penalty for going out of range
197 | }
198 | return(ll)
199 | }
200 | ```
201 |
202 | ## Model functions | Equal-variance signal detection model
203 |
204 | ```{r, echo = T}
205 | N = c(2,5,8)
206 | N_i = rep(1:length(N), each=4) # index
207 |
208 | # signal detection model with equal variance for change and no-change items
209 | ll.sdt.ev <- function(par, y){
210 | # length(par) == 4 (d1, d2, d3, c)
211 | ll=0
212 | for(i in 1:length(N)){ # for each set size
213 | p = sdt(d = par[i], c = par[length(N)+1], s = 1)
214 | ll = ll + negLL(y[N_i==i], p)
215 | }
216 | return(ll)
217 | }
218 | ```
219 |
220 | ## Scripts
221 |
222 | `mle-rouder08-group.R` fits these models to aggregate data
223 |
224 | `mle-rouder08-indiv.R` fits these models to aggregate data
225 |
226 |
227 |
228 |
--------------------------------------------------------------------------------
/day1/change-detection/data/reshape-rouder-data.R:
--------------------------------------------------------------------------------
1 |
2 | library(plyr)
3 | library(RCurl)
4 |
5 | intext=getURL("https://raw.githubusercontent.com/PerceptionCognitionLab/data0/master/wmPNAS2008/lk2data.csv")
6 | data=read.csv(text=intext)
7 |
8 | head(data)
9 |
10 | ## Wide format for MLE
11 |
12 | counts = ddply(data, c('sub', 'prch', 'N'), summarize,
13 | H = sum(ischange == 1 & resp == 1),
14 | M = sum(ischange == 1 & resp == 0),
15 | Fa = sum(ischange == 0 & resp == 1),
16 | Cr = sum(ischange == 0 & resp == 0))
17 |
18 | counts$N = paste0("N", counts$N)
19 |
20 | counts_wide =
21 | counts %>%
22 | gather(variable, value, -(sub:N)) %>%
23 | unite(temp, N, prch, variable) %>%
24 | spread(temp, value)
25 |
26 | colorder = c()
27 | for (i in c(0.3, 0.5, 0.7)){
28 | for (j in c("N2", "N5", "N8")){
29 | colorder <- c(colorder, paste(j, i, c("H", "M", "Fa", "Cr"), sep="_"))
30 | }
31 | }
32 |
33 | # re-order columns
34 | counts_wide = counts_wide[, colorder]
35 | apply(counts_wide, 1, sum)
36 |
37 | write.table(x = counts_wide, file = "rouder08-data-full.dat")
38 |
39 | # only the 50:50 trials
40 | counts_wide_0.5 = counts_wide[,grep(colorder, pattern = "0.5")]
41 |
42 | write.table(x = counts_wide_0.5, file = "rouder08-data-0.5.dat")
43 |
44 | # -~ -~ -~ -~ -~ -~ -~ -~ -~ -~ -~ -~ -~ -~ -~ -~ -~ -~ -~ -~ -~ -~ -~ -~ -~ -~ -~ -~
45 | ## Long format for JAGS
46 |
47 | data_long = ddply(data, c("sub", "prch", "N", "ischange"), summarize,
48 | respchange = sum(resp), ntrials = length(resp))
49 |
50 | colnames(data_long)[1] = "ppt"
51 |
52 | data_long$ppt = as.numeric(as.factor(data_long$ppt)) # renumber participants 1:23
53 |
54 | setwd("../../../day2/bayesian-models/jags-change-det/")
55 |
56 | write.table(x = data_long, file = "rouder08-longdata-full.dat")
57 |
58 | data_long_0.5 = subset(data_long, prch==0.5)
59 |
60 | write.table(x = data_long_0.5, file = "rouder08-longdata-0.5.dat")
61 |
--------------------------------------------------------------------------------
/day1/change-detection/data/rouder08-data-0.5.dat:
--------------------------------------------------------------------------------
1 | "N2_0.5_H" "N2_0.5_M" "N2_0.5_Fa" "N2_0.5_Cr" "N5_0.5_H" "N5_0.5_M" "N5_0.5_Fa" "N5_0.5_Cr" "N8_0.5_H" "N8_0.5_M" "N8_0.5_Fa" "N8_0.5_Cr"
2 | "1" 29 1 1 29 25 5 7 23 24 6 11 19
3 | "2" 28 2 0 30 25 5 6 24 25 5 9 21
4 | "3" 27 3 7 23 23 7 10 20 19 11 19 11
5 | "4" 30 0 0 30 27 3 7 23 26 4 15 15
6 | "5" 30 0 0 30 27 3 4 26 24 6 6 24
7 | "6" 29 1 0 30 23 7 7 23 19 11 5 25
8 | "7" 29 1 3 27 23 7 9 21 15 15 6 24
9 | "8" 28 2 5 25 29 1 12 18 19 11 18 12
10 | "9" 30 0 2 28 27 3 11 19 25 5 14 15
11 | "10" 29 1 0 30 29 1 11 19 26 4 19 11
12 | "11" 30 0 5 25 25 5 7 23 23 7 11 19
13 | "12" 28 2 2 28 25 5 19 11 20 10 13 17
14 | "13" 30 0 1 29 27 3 6 24 23 7 7 23
15 | "14" 30 0 0 30 27 3 4 26 26 4 13 17
16 | "15" 28 2 3 27 24 6 4 26 27 3 10 20
17 | "16" 30 0 0 30 25 5 7 23 18 12 10 20
18 | "17" 30 0 2 28 29 1 6 24 28 2 10 20
19 | "18" 29 1 2 28 23 7 12 18 21 9 14 16
20 | "19" 26 4 9 21 27 3 12 18 25 5 17 13
21 | "20" 30 0 0 30 29 1 3 27 29 1 5 25
22 | "21" 29 1 1 29 27 3 7 23 24 6 12 18
23 | "22" 30 0 2 28 20 10 14 16 21 9 15 15
24 | "23" 27 3 2 28 27 3 8 22 22 8 9 21
25 |
--------------------------------------------------------------------------------
/day1/change-detection/data/rouder08-data-full.dat:
--------------------------------------------------------------------------------
1 | "N2_0.3_H" "N2_0.3_M" "N2_0.3_Fa" "N2_0.3_Cr" "N5_0.3_H" "N5_0.3_M" "N5_0.3_Fa" "N5_0.3_Cr" "N8_0.3_H" "N8_0.3_M" "N8_0.3_Fa" "N8_0.3_Cr" "N2_0.5_H" "N2_0.5_M" "N2_0.5_Fa" "N2_0.5_Cr" "N5_0.5_H" "N5_0.5_M" "N5_0.5_Fa" "N5_0.5_Cr" "N8_0.5_H" "N8_0.5_M" "N8_0.5_Fa" "N8_0.5_Cr" "N2_0.7_H" "N2_0.7_M" "N2_0.7_Fa" "N2_0.7_Cr" "N5_0.7_H" "N5_0.7_M" "N5_0.7_Fa" "N5_0.7_Cr" "N8_0.7_H" "N8_0.7_M" "N8_0.7_Fa" "N8_0.7_Cr"
2 | "1" 17 1 1 41 16 2 11 31 12 6 6 36 29 1 1 29 25 5 7 23 24 6 11 19 41 1 0 18 40 2 3 15 35 7 8 10
3 | "2" 17 1 2 40 14 4 6 36 12 6 10 32 28 2 0 30 25 5 6 24 25 5 9 21 40 2 0 18 38 4 3 15 37 5 6 12
4 | "3" 13 5 1 41 11 7 9 32 12 6 13 29 27 3 7 23 23 7 10 20 19 11 19 11 42 0 6 12 41 1 15 3 41 1 12 6
5 | "4" 18 0 1 41 18 0 4 38 12 6 8 34 30 0 0 30 27 3 7 23 26 4 15 15 42 0 0 18 39 3 6 12 41 1 9 9
6 | "5" 17 1 0 42 16 2 3 39 16 2 8 34 30 0 0 30 27 3 4 26 24 6 6 24 40 2 0 18 40 2 7 11 34 8 6 12
7 | "6" 18 0 0 42 14 4 3 39 10 8 8 34 29 1 0 30 23 7 7 23 19 11 5 25 42 0 1 17 38 4 3 15 33 9 10 8
8 | "7" 17 1 3 39 10 8 9 33 9 9 13 29 29 1 3 27 23 7 9 21 15 15 6 24 40 2 5 13 39 3 6 12 36 6 12 6
9 | "8" 16 2 11 31 10 8 13 29 10 8 22 20 28 2 5 25 29 1 12 18 19 11 18 12 36 6 6 12 36 6 9 9 34 8 15 3
10 | "9" 15 3 5 37 13 5 8 34 6 12 8 34 30 0 2 28 27 3 11 19 25 5 14 15 41 1 1 17 40 2 6 12 39 3 12 6
11 | "10" 17 1 0 42 17 1 10 32 15 3 21 21 29 1 0 30 29 1 11 19 26 4 19 11 40 2 1 17 40 2 4 14 39 3 13 5
12 | "11" 17 1 2 40 16 2 13 29 12 6 14 28 30 0 5 25 25 5 7 23 23 7 11 19 42 0 0 18 38 4 7 11 37 5 9 9
13 | "12" 16 2 2 40 14 4 8 34 13 5 12 30 28 2 2 28 25 5 19 11 20 10 13 17 39 3 6 12 37 5 11 7 38 4 13 5
14 | "13" 18 0 0 42 15 3 7 35 13 5 11 31 30 0 1 29 27 3 6 24 23 7 7 23 42 0 0 18 40 2 1 17 39 3 3 15
15 | "14" 17 1 0 42 16 2 6 36 12 6 18 24 30 0 0 30 27 3 4 26 26 4 13 17 41 1 1 17 40 2 5 13 40 2 8 10
16 | "15" 16 2 2 40 16 2 3 39 12 6 8 34 28 2 3 27 24 6 4 26 27 3 10 20 41 1 2 16 40 2 2 16 39 3 7 11
17 | "16" 17 1 0 42 16 2 6 36 9 9 8 34 30 0 0 30 25 5 7 23 18 12 10 20 41 1 1 17 37 5 4 14 34 8 11 7
18 | "17" 18 0 0 42 16 2 1 41 16 2 12 30 30 0 2 28 29 1 6 24 28 2 10 20 42 0 1 17 41 1 0 18 37 5 3 15
19 | "18" 17 1 2 40 11 7 18 24 6 12 18 24 29 1 2 28 23 7 12 18 21 9 14 16 41 1 0 18 32 10 12 6 32 10 9 9
20 | "19" 12 6 14 28 12 6 17 25 10 8 24 18 26 4 9 21 27 3 12 18 25 5 17 13 41 1 5 13 36 6 12 6 37 5 14 4
21 | "20" 17 1 0 42 18 0 5 37 18 0 10 32 30 0 0 30 29 1 3 27 29 1 5 25 42 0 3 15 41 1 3 15 35 7 5 13
22 | "21" 17 1 2 40 17 1 7 35 13 5 16 26 29 1 1 29 27 3 7 23 24 6 12 18 40 2 1 16 39 3 7 11 34 8 6 12
23 | "22" 17 1 0 42 13 5 16 26 3 15 12 30 30 0 2 28 20 10 14 16 21 9 15 15 41 1 3 15 36 6 8 10 34 8 11 7
24 | "23" 18 0 2 40 15 3 4 38 16 2 12 30 27 3 2 28 27 3 8 22 22 8 9 21 39 3 1 17 40 2 3 15 34 8 11 7
25 |
--------------------------------------------------------------------------------
/day1/change-detection/mle-rouder08-group.R:
--------------------------------------------------------------------------------
1 |
2 | # MLE Rouder et al (2008) PNAS
3 |
4 | cd = read.table(file = "day1/change-detection/data/rouder08-data-0.5.dat")
5 |
6 | group_data = apply(cd, 2, sum)
7 |
8 | # the data frame gives numbers of hits, misses, false-alarms, and correct rejections
9 | # for three set sizes: N = 2,5,8
10 |
11 | N = c(2,5,8)
12 | N_i = rep(1:length(N), each=4) # index
13 |
14 | #Multinomial Negative Log-Likelihood
15 | negLL <- function(y,p){
16 | a = suppressWarnings(ifelse(y==0 & p==0 | p < 0, 0, y*log(p)))
17 | -sum(a)
18 | }
19 |
20 | cowan_k <- function(k, a, g, N){
21 | d = min(1,k/N) # p(probe in memory)
22 |
23 | p = 1:4
24 | p[1] = a*(d+(1-d)*g)+(1-a)*g # p(hit)
25 | p[2] = 1-p[1] # p(miss)
26 | p[3] = a*(1-d)*g+(1-a)*g # p(false-alarm)
27 | p[4] = 1-p[3] # p(correct rejection)
28 | return(p)
29 | }
30 |
31 | sdt <- function(d, c, s){
32 | # this is a simplified version of the sdt
33 | # model used by rouder et al.
34 | p = 1:4
35 | p[1] = pnorm((d - c)/s) # p(hit)
36 | p[2] = 1 - p[1] # p(miss)
37 | p[3] = pnorm(- c) # p(false-alarm)
38 | p[4] = 1 - p[3] # p(correct rejection)
39 | return(p)
40 | }
41 |
42 | # test this function out... plot an ROC curve
43 | # m = sapply(seq(0,5, .1), FUN = function(x) sdt(d=0, c = x, s = 1))
44 | # plot(m[3,], m[1,], type='l')
45 |
46 | # Likelihood functions
47 |
48 | ## Binomial Model
49 | ll.vacuous <- function(y){
50 | ll = 0
51 | lenY = length(y)
52 | y1 = y[rep(c(T, F), lenY/2)]
53 | y2 = y[rep(c(F, T), lenY/2)]
54 | n = (rep((y1+y2), each=2))
55 | p = y/n
56 | ll = negLL(y, p)
57 | return(ll)
58 | }
59 |
60 | ## Fixed Capacity Model
61 | ll.fixed_k <- function(par, y){
62 | # length(par) == 3 (k, a, g)
63 | ll = 0
64 | for (i in 1:length(N)){ # for each set size
65 | p = cowan_k(k = par[1], a = par[2], g = par[3], N = N[i])
66 | ll = ll + negLL(y[N_i==i], p)
67 | }
68 | if(any(c(par < rep(0,3), par > c(max(N),1,1)))){
69 | ll = ll + 10000 # penalty for going out of range
70 | }
71 | return(ll)
72 | }
73 |
74 | ## Varying Capacity Model
75 | ll.vary_k <- function(par, y){
76 | # length(par) == 5 (k*3, a, g)
77 | ll=0
78 | for(i in 1:length(N)){ # for each set size
79 | p = cowan_k(k = par[i], a = par[4], g = par[5], N = N[i])
80 | ll = ll + negLL(y[N_i==i], p)
81 | }
82 | if(any(c(par < rep(0,5), par > c(rep(max(N), 3),1,1)))){
83 | ll = ll + 10000 # penalty for going out of range
84 | }
85 | return(ll)
86 | }
87 |
88 | ## Equal-Variance Signal Detection Model
89 | ll.sdt.ev <- function(par, y){
90 | # length(par) == 4 (d1, d2, d3, c)
91 | ll=0
92 | for(i in 1:length(N)){ # for each set size
93 | p = sdt(d = par[i], c = par[length(N)+1], s = 1)
94 | ll = ll + negLL(y[N_i==i], p)
95 | }
96 | return(ll)
97 | }
98 |
99 | # get LL from vacuous model
100 | ll.vac = ll.vacuous(y = group_data)
101 |
102 | ## fit k model
103 | # starting values
104 | par = runif(n = 3, min = 0, max = c(max(N), 1, 1))
105 | k_res = optim(par, ll.fixed_k, y = group_data)
106 | k_res$value
107 |
108 | k_res$par
109 |
110 | # starting values
111 | par = runif(n = 5, min = 0, max = c(rep(max(N),3), 1, 1))
112 | vary_k_res = optim(par, ll.vary_k, y = group_data)
113 | vary_k_res$value
114 |
115 | vary_k_res$par
116 |
117 | ## fit sdt model
118 | par = runif(n = 4, min = 0, max = c(5, 5, 5, 5))
119 | sdt_res = optim(par, ll.sdt.ev, y = group_data)
120 | sdt_res$value
121 |
122 | sdt_res$par
123 |
124 | #### TASKS -----
125 |
126 | # try making and fitting the following models:
127 | # - unequal variance signal detection
128 | # - a fixed capacity model with no attention parameter (i.e. a = 1)
129 | # - compare the fixed and variable capacity (k) models via G^2
130 |
131 |
132 |
133 | ### SCROLL DOWN TO SEE SOLUTIONS ----
134 |
135 |
136 |
137 |
138 |
139 |
140 |
141 | # unequal variance signal detection
142 | ll.sdt.uev <- function(par, y){
143 | # length(par) == 5 (d1, d2, d3, c, s)
144 | ll=0
145 | for(i in 1:length(N)){ # for each set size
146 | p = sdt(d = par[i], c = par[4], s = par[5])
147 | ll = ll + negLL(y[N_i==i], p)
148 | }
149 | return(ll)
150 | }
151 |
152 | par = runif(n = 5, min = 0, max = c(5, 5, 5, 5, 2))
153 | sdtuv_res = optim(par, ll.sdt.uev, y = group_data)
154 | sdtuv_res$value
155 |
156 | sdtuv_res$par
157 |
158 | # a fixed capacity model with no attention parameter (i.e. a = 1)
159 | ll.fixed_k_noA <- function(par, y){
160 | # length(par) == 2 (k, g)
161 | ll = 0
162 | for (i in 1:length(N)){ # for each set size
163 | p = cowan_k(k = par[1], a = 1, g = par[2], N = N[i])
164 | ll = ll + negLL(y[N_i==i], p)
165 | }
166 | if(any(c(par < rep(0,2), par > c(max(N),1)))){
167 | ll = ll + 10000 # penalty for going out of range
168 | }
169 | return(ll)
170 | }
171 |
172 | par = runif(n = 2, min = 0, max = c(max(N), 1))
173 | par = c(1, .5)
174 | k_noA_res = optim(par, ll.fixed_k_noA, y = group_data)
175 | k_noA_res$value
176 |
177 | k_noA_res$par
178 |
179 | # compare the fixed and variable capacity (k) models via G^2
180 | G = 2*(k_res$value - vary_k_res$value)
181 |
182 | 1 - pchisq(G, df = 2)
183 |
184 |
--------------------------------------------------------------------------------
/day1/change-detection/mle-rouder08-indiv.R:
--------------------------------------------------------------------------------
1 |
2 | # MLE Rouder et al (2008) PNAS
3 |
4 | # get the MLE functions from the group script
5 | source("day1/change-detection/mle-rouder08-group.R")
6 |
7 | # the data is also read in under cd
8 | head(cd)
9 |
10 | # function to calculate fit statistics from -LL
11 | fit_stats <- function(nLL, n, p){
12 | # nLL = negative log liklihood
13 | # n = number of observations
14 | # p = number of parameters
15 |
16 | deviance = 2*nLL
17 | aic = deviance + 2*p
18 | bic = deviance + p*log(n)
19 |
20 | return(list("D" = deviance, "AIC" = aic, "BIC" = bic))
21 | }
22 |
23 | sdt_fit = fit_stats(nLL = sdt_res$value, n = sum(group_data), p = 4)
24 |
25 | k_fit = fit_stats(nLL = k_res$value, n = sum(group_data), p = 3)
26 |
27 | vary_k_fit = fit_stats(nLL = vary_k_res$value, n = sum(group_data), p = 5)
28 |
29 | sdt_fit$AIC
30 | k_fit$AIC
31 | vary_k_fit$AIC
32 |
33 | sdt_fit$BIC
34 | k_fit$BIC
35 | vary_k_fit$BIC
36 |
37 | #### FIT TO INDIVIDUALS ----
38 |
39 | S = nrow(cd) # number of participants
40 |
41 | # create matrices to hold the resulting parameter estimates
42 | # 1 row per participant, 1 column per parameter
43 | estimates_fix_k <- matrix(NA, nrow = S, ncol = 3)
44 | colnames(estimates_fix_k) <- c("k", "a", "g")
45 |
46 | estimates_vary_k <- matrix(NA, nrow = S, ncol = 5)
47 | colnames(estimates_vary_k) <- c("k1", "k2", "k3", "a", "g")
48 |
49 | estimates_sdt <- matrix(NA, nrow = S, ncol = 4)
50 | colnames(estimates_sdt) <- c("d1", "d2", "d3", "c")
51 |
52 | # create a matrix to hold the -log likelihood for each individual (row)
53 | # and each model (col)
54 | fit_statistics <- matrix(NA, nrow = S, ncol = 5)
55 | colnames(fit_statistics) <- c("LL_vac", "LL_fix_k", "LL_vary_k", "LL_sdt", "N_obs")
56 |
57 | # this loop takes the data from each row (participant) and fits the three models
58 | for (s in 1:S){
59 | # get the data for this subject
60 | tmp.dat = as.integer(cd[s,])
61 |
62 | # model that freely estimates response frequencies
63 | fit_statistics[s,1] <- ll.vacuous(y = tmp.dat)
64 |
65 | # fixed k
66 | par = runif(n = 3, min = 0, max = c(max(N), 1, 1))
67 | k_res_s = optim(par, ll.fixed_k, y = tmp.dat)
68 |
69 | fit_statistics[s,2] <- k_res_s$value # add estimates and LL to matrices
70 | estimates_fix_k[s,] <- k_res_s$par
71 |
72 | # variable k
73 | par = runif(n = 5, min = 0, max = c(rep(max(N),3), 1, 1))
74 | vary_k_res_s = optim(par, ll.vary_k, y = tmp.dat)
75 |
76 | fit_statistics[s,3] <- vary_k_res_s$value
77 | estimates_vary_k[s,] <- vary_k_res_s$par
78 |
79 | ## sdt model
80 | par = runif(n = 4, min = 0, max = c(5, 5, 5, 5))
81 | sdt_res_s = optim(par, ll.sdt.ev, y = tmp.dat)
82 |
83 | fit_statistics[s,4] <- sdt_res_s$value
84 | estimates_sdt[s,] <- sdt_res_s$par
85 |
86 | fit_statistics[s,5] = sum(tmp.dat)
87 | }
88 | # remove stuff we no longer need...
89 | rm(list = c("tmp.dat", "k_res_s", "vary_k_res_s", "sdt_res_s"))
90 |
91 | # look at resulting parameter estimates
92 | hist(estimates_fix_k[,'k'], main="Fixed k", xlab="k estimate")
93 |
94 |
95 | #################### Model Comparison #######################
96 |
97 | ##Let's do AIC first
98 | AIC.ind <- fit_statistics
99 | for(s in 1:S){
100 | for(m in 1:M){
101 | AIC.ind[s, m] <- fit_stats(nLL = fit_statistics[s, m], n = fit_statistics[s, 5], p = npar[m])$AIC
102 | }
103 | AIC.ind[s, 5] <- order(AIC.ind[s, 1:4])[1]
104 | }
105 |
106 | colnames(AIC.ind) <- c("vac", "fix_k", "vary_k", "sdt", "winner")
107 | AIC.ind <- as.data.frame(AIC.ind)
108 | AIC.ind$winner <- factor(AIC.ind$winner
109 | , labels = c("fix_k", "vary_k", "sdt"))
110 | table(AIC.ind$winner)
111 |
112 | ##BIC
113 | BIC.ind <- fit_statistics
114 | M <- ncol(BIC.ind)
115 | npar <- c(12, 3, 5, 4)
116 |
117 | for(s in 1:S){
118 | for(m in 1:M){
119 | BIC.ind[s, m] <- fit_stats(nLL = fit_statistics[s, m], n = fit_statistics[s, 5], p = npar[m])$BIC
120 | }
121 | BIC.ind[s, 5] <- order(BIC.ind[s, 1:4])[1]
122 | }
123 |
124 | colnames(BIC.ind) <- c("vac", "fix_k", "vary_k", "sdt", "winner")
125 | BIC.ind <- as.data.frame(BIC.ind)
126 | BIC.ind$winner <- factor(BIC.ind$winner
127 | , labels = c("fix_k"))
128 | table(BIC.ind$winner)
129 |
130 |
131 | ##################### More Stuff #####################################
132 |
133 | #### Unequal Variance Signal Detection Model
134 |
135 | ll.sdt.uv <- function(par, y){
136 | # length(par) == 7 (d1, d2, d3, c, s1, s2, s3)
137 | ll=0
138 | for(i in 1:length(N)){ # for each set size
139 | p = sdt(d = par[i], c = par[length(N) + 1], s = par[length(N) + 1 + i])
140 | ll = ll + negLL(y[N_i==i], p)
141 | }
142 | if(any(par[5:7] < rep(0,3))){
143 | ll = ll + 10000} # penalty for going out of range
144 | return(ll)
145 | }
146 |
147 | ## fit sdt model
148 | par = runif(n = 7, min = 0, max = 3)
149 | sdt_res_uv = optim(par, ll.sdt.uv, y = group_data)
150 | sdt_res_uv$par
151 |
152 | ## fit sdt model
153 | par = runif(n = 4, min = 0, max = 3)
154 | sdt_res = optim(par, ll.sdt.ev, y = group_data)
155 | sdt_res$par
156 |
157 | c(sdt_res_uv$value, sdt_res$value)
158 |
159 | ## Try with differen random seeds set.seed(123)
160 |
161 |
162 |
163 | ##### Dealing with zero counts
164 |
165 |
166 | # create a matrix to hold the -log likelihood for each individual (row)
167 | # and each model (col)
168 | fit_statistics <- matrix(NA, nrow = S, ncol = 5)
169 | colnames(fit_statistics) <- c("LL_vac", "LL_fix_k", "LL_vary_k", "LL_sdt", "N_obs")
170 |
171 | # this loop takes the data from each row (participant) and fits the three models
172 | for (s in 1:S){
173 | # get the data for this subject
174 | tmp.dat = as.integer(cd[s,]) + .5
175 |
176 | # model that freely estimates response frequencies
177 | fit_statistics[s,1] <- ll.vacuous(y = tmp.dat)
178 |
179 | # fixed k
180 | par = runif(n = 3, min = 0, max = c(max(N), 1, 1))
181 | k_res_s = optim(par, ll.fixed_k, y = tmp.dat)
182 |
183 | fit_statistics[s,2] <- k_res_s$value # add estimates and LL to matrices
184 | estimates_fix_k[s,] <- k_res_s$par
185 |
186 | # variable k
187 | par = runif(n = 5, min = 0, max = c(rep(max(N),3), 1, 1))
188 | vary_k_res_s = optim(par, ll.vary_k, y = tmp.dat)
189 |
190 | fit_statistics[s,3] <- vary_k_res_s$value
191 | estimates_vary_k[s,] <- vary_k_res_s$par
192 |
193 | ## sdt model
194 | par = runif(n = 4, min = 0, max = c(5, 5, 5, 5))
195 | sdt_res_s = optim(par, ll.sdt.ev, y = tmp.dat)
196 |
197 | fit_statistics[s,4] <- sdt_res_s$value
198 | estimates_sdt[s,] <- sdt_res_s$par
199 |
200 | fit_statistics[s,5] = sum(tmp.dat)
201 | }
202 | # remove stuff we no longer need...
203 | rm(list = c("tmp.dat", "k_res_s", "vary_k_res_s", "sdt_res_s"))
204 |
205 | # look at resulting parameter estimates
206 | hist(estimates_fix_k[,'k'], main="Fixed k", xlab="k estimate")
207 |
208 |
--------------------------------------------------------------------------------
/day1/change-detection/pictures/MUlogoRGB.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/jstbcs/CognitiveModelingWorkshop/080db90e6745f28247a7829222982912e6f9b6dd/day1/change-detection/pictures/MUlogoRGB.png
--------------------------------------------------------------------------------
/day1/change-detection/pictures/SP.pdf:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/jstbcs/CognitiveModelingWorkshop/080db90e6745f28247a7829222982912e6f9b6dd/day1/change-detection/pictures/SP.pdf
--------------------------------------------------------------------------------
/day1/change-detection/pictures/SP.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/jstbcs/CognitiveModelingWorkshop/080db90e6745f28247a7829222982912e6f9b6dd/day1/change-detection/pictures/SP.png
--------------------------------------------------------------------------------
/day1/change-detection/pictures/rouder08.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/jstbcs/CognitiveModelingWorkshop/080db90e6745f28247a7829222982912e6f9b6dd/day1/change-detection/pictures/rouder08.png
--------------------------------------------------------------------------------
/day1/intro-to-R/data/example_fun.csv:
--------------------------------------------------------------------------------
1 | "sub","x","y"
2 | 1,11.5066220924356,12.7901051267848
3 | 2,14.0287093313973,16.7268391226932
4 | 3,9.28973107925622,9.1973814414416
5 | 4,14.0563356852844,9.57326001000924
6 | 5,5.56625109771513,9.97723258234497
7 | 6,11.5167923560021,8.71670594905057
8 | 7,7.38762948197659,11.055515455285
9 | 8,8.39496086259241,8.9211855867574
10 | 9,6.41551833107772,14.8799774455398
11 | 10,9.91593509195451,17.1198020670977
12 | 11,14.3000852356895,8.02528062717591
13 | 12,6.45953832359359,8.37564518979144
14 | 13,11.7293071891308,6.72707857866419
15 | 14,6.55968820367782,19.737977254314
16 | 15,10.2682513362824,14.7122503422527
17 | 16,9.84834687069526,10.3900966152082
18 | 17,11.7166010887518,12.7421755725254
19 | 18,10.6898006962045,13.5993783794304
20 | 19,8.83509461978445,18.5759817402542
21 | 20,11.5723407518508,11.7514040228854
22 | 21,8.61580142717341,10.7343489240926
23 | 22,7.63391292737451,11.4173400428463
24 | 23,12.5377014121262,14.814428704765
25 | 24,9.3748969079777,12.766740962195
26 | 25,10.0611425181958,7.08848080617864
27 | 26,7.03545017451852,11.7362308653812
28 | 27,7.74670311325541,8.85649332597398
29 | 28,6.47231342367185,0.227224420914377
30 | 29,7.87476184157826,9.48936291488598
31 | 30,7.31400152101135,9.78734946250088
32 | 31,11.5099923273713,17.9584476031472
33 | 32,8.71702220576143,15.5505527618889
34 | 33,12.8622646536057,10.6863986012785
35 | 34,8.75089856893397,6.86661545570612
36 | 35,10.4579896718278,11.9424613359004
37 | 36,10.526361047296,16.0213517664518
38 | 37,10.8584365972919,13.6124514039991
39 | 38,7.03155975512812,17.7300323117558
40 | 39,10.3600167477797,12.5493645569534
41 | 40,14.1221206777792,6.63397174153886
42 | 41,11.4512032410988,10.0520644219499
43 | 42,9.02253219363477,8.40015415525025
44 | 43,9.03175747954392,13.2819234038408
45 | 44,13.6911871723904,13.2589196895552
46 | 45,11.0308684189418,7.83682504854887
47 | 46,7.77042523432991,13.5417768224884
48 | 47,9.37970215718699,15.1902190905523
49 | 48,10.1828629422571,9.78519275981874
50 | 49,11.2886345533669,12.70925284974
51 | 50,10.7496689619463,12.1719401573517
52 |
--------------------------------------------------------------------------------
/day1/intro-to-R/data/teachers.RData:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/jstbcs/CognitiveModelingWorkshop/080db90e6745f28247a7829222982912e6f9b6dd/day1/intro-to-R/data/teachers.RData
--------------------------------------------------------------------------------
/day1/intro-to-R/intro-script.R:
--------------------------------------------------------------------------------
1 | ## Get help
2 |
3 | help.start()
4 | citation()
5 | sessionInfo()
6 |
7 | ?sum
8 | ?mean
9 | help("sd")
10 |
11 | ??correlation
12 |
13 | ## Basic calculator
14 |
15 | 1+1
16 | 12^4
17 | log(23)
18 |
19 | x <- 10
20 | y <- 6
21 | x + y
22 |
23 | z <- x + y
24 | y/z
25 |
26 | #Warning: R is case sensitive
27 | X <- 5 # Does not replace variable x
28 | x
29 |
30 | ## Variables
31 |
32 | name <- "Jed Bartlet" # Character
33 | age <- 65 # Integer / Double
34 | president <- TRUE # Boolean
35 |
36 | staff <- c("Josh", "CJ", "Sam")
37 | staff
38 |
39 | staff[2]
40 | staff[c(1, 3)]
41 | staff <- staff[c(1, 3)]
42 | staff[2:3]
43 |
44 | #Matrix
45 | m <- matrix(c(1:9), nrow = 3)
46 | m[1, ] # First row
47 | m[, 3] # Third column
48 | m[1, 3] # Element in the first row and third column
49 |
50 | #Dataframe
51 | name <- c("Ben", "Kathy", "Paul", "Julia", "Jeff")
52 | age <- c(24, 43, 32, 27, 60)
53 | job <- rep("teacher", 5)
54 | friends <- c(5, 2, 0, 3, 6)
55 | pets <- c(0, 2, 4, 1, 1)
56 | income <- c(":/", ":)", ":(", ":(", ":)")
57 |
58 | teachers <- data.frame(name, age, job, friends, pets, income)
59 | save(teachers, file = "day1/intro-to-R/data/teachers.RData")
60 |
61 | teachers$ratio <- teachers$pets / teachers$friends
62 | teachers
63 |
64 |
65 | ## Using functions
66 |
67 | mean(teachers$age[teachers$income == ":)"])
68 | tapply(teachers$age, teachers$income, mean)
69 |
70 | set.seed(666)
71 | x <- rnorm(50, 10, 2)
72 | y <- rnorm(50, 12, 4)
73 | dat.fun <- data.frame(sub = 1:50, x, y)
74 |
75 | write.csv(dat.fun, "day1/intro-to-R/data/example_fun.csv", row.names = F)
76 |
77 | example.dat <- read.csv(file = "day1/intro-to-R/data/example_fun.csv")
78 |
79 | head(dat.fun)
80 |
81 | t.test(example.dat$x, example.dat$y, var.equal = T)
82 |
83 | ## Get data from the internet
84 |
85 | daturl <- curl::curl("https://raw.githubusercontent.com/PerceptionCognitionLab/data0/master/wmPNAS2008/lk2clean.csv")
86 | dat <- read.csv(daturl, header = T)
87 |
88 | head(dat)
89 |
90 | #and clean it up
91 | dat.pretty <- dat[, c("sub", "blk", "trl", "prch", "N", "ischange", "resp")]
92 | dat.pretty$accuracy <- dat.pretty$ischange == dat.pretty$resp
93 |
94 | dat.pretty$ischange <- factor(dat.pretty$ischange, labels = c("unchanged", "changed"))
95 |
96 | head(dat.pretty)
97 |
98 | mean.acc <- with(dat.pretty, tapply(accuracy, list(prch, N, ischange), mean))
99 | mean.acc
100 |
101 | #plot it
102 | layout(matrix(1:2, ncol = 2))
103 | matplot(mean.acc[,,1], main = "Unchanged", ylab = "Accuracy"
104 | , type = "b", pch = colnames(mean.acc), xaxt = "n")
105 | axis(1, at = 1:3, labels = rownames(mean.acc))
106 | matplot(mean.acc[,,2], main = "Changed", ylab = "Accuracy"
107 | , type = "b", pch = colnames(mean.acc), xaxt = "n")
108 | axis(1, at = 1:3, labels = rownames(mean.acc))
109 |
110 | matplot(mean.acc[,,1] # data
111 | , main = "Unchanged", ylab = "Accuracy" #labels: title and y-axis
112 | , type = "b", pch = colnames(mean.acc)) #type = "both" line and point, point type = set size
113 |
114 | #count it
115 | (tab <- table(dat.pretty$resp, dat.pretty$ischange))
116 |
117 | (outcomes <- c("hits" = tab[2, 2], "misses" = tab[1, 2]
118 | , "fa" = tab[2, 1], "cr" = tab[1, 1]))
119 |
120 | barplot(outcomes, col = "mediumvioletred")
121 |
122 |
123 | ## Write your own function
124 |
125 | hello <- function(){
126 | return("Hello World!")
127 | }
128 |
129 | hello()
130 |
131 | gimme.sum <- function(x, y){
132 | sum.xy <- x + y
133 | return(sum.xy)
134 | }
135 |
136 | gimme.sum(99, 567)
137 |
138 | ## New function
139 | new.f <- function(x, y){
140 | sdy <- sd(y)
141 | val <- x/sdy
142 | return(val)
143 | }
144 |
145 | new.f(1:3, c(1, 1, 1))
146 |
--------------------------------------------------------------------------------
/day1/intro-to-R/intro.rmd:
--------------------------------------------------------------------------------
1 | ---
2 | title: "R"
3 | author: "Julia Haaf & Stephen Rhodes"
4 | output:
5 | ioslides_presentation:
6 | logo: pictures/MUlogoRGB.png
7 | widescreen: true
8 | subtitle: A pragmatic introduction
9 | ---
10 |
11 | # Overview
12 |
13 | ## What do you expect to learn?
14 | 
15 |
16 |
17 |
18 | ## Hint
19 |
20 | R is a programming *language* (Scripting language)
21 |
22 | - Vocabulary
23 | - Grammar
24 |
25 | ### Learning by doing!
26 |
27 | ```{r echo = FALSE, fig.height = 6, out.width = "350px"}
28 | par(mar = c(5, 6, 4, 2) + 0.1)
29 | y <- c((1:100 - 30)^3)
30 | plot(
31 | 1:100
32 | , y
33 | , type = "l"
34 | # , xlim = c(33, 100)
35 | , ylim = c(min(y) - 200, max(y))
36 | , xlab = "time invested"
37 | , ylab = "ability"
38 | , axes = FALSE
39 | , lwd = 5
40 | , col = "skyblue"
41 | , cex.lab = 2.5
42 | )
43 | box(lwd = 2)
44 | ```
45 |
46 |
47 |
48 | ## Overview
49 |
50 | 1. Get help
51 | 2. Basic `R` functionality
52 | 3. Use a `function()`
53 | 4. Read data files from the internet
54 | 5. Basic graphing
55 | 6. Write a `function()`
56 |
57 | # FRst Experiments & Help
58 |
59 | ## Trial & Error 1
60 | **Have a crack at the R console.**
61 |
62 | ```{r eval = FALSE}
63 | help.start()
64 | citation()
65 | sessionInfo()
66 | ```
67 |
68 | ## HELP! | "How do I do this?" or "Why is it not working?"
69 |
70 | Google
71 |
72 | - [StackOverflow](http://stackoverflow.com/)
73 | - [Cross-Validate](http://stats.stackexchange.com/)
74 | - R email lists
75 | - blogs
76 |
77 | In R
78 |
79 | ```{r eval = FALSE}
80 | ?sum
81 | ?mean
82 | help("sd")
83 |
84 | ??correlation
85 | ```
86 |
87 |
88 |
89 |
90 | Show help function and talk about it.
91 |
92 |
93 |
94 | # R basics
95 | ## R as a calculator
96 |
97 | ```{r}
98 | 1+1
99 | 12^4
100 | log(23)
101 | ```
102 |
103 | ## R as a fancy calculator | Variables
104 |
105 | ```{r}
106 | x <- 10
107 | y <- 6
108 | x + y
109 |
110 | z <- x + y
111 | y/z
112 | ```
113 |
114 | ## R as a fancy calculator | Variables
115 | *Warning: R is case sensitive.*
116 | ```{r}
117 | X <- 5 # Does not replace variable x
118 | x
119 | ```
120 |
121 |
122 | ## Variables
123 | You can save any kind of information as variables.
124 |
125 | ```{r}
126 | name <- "Jed Bartlet" # Character
127 | age <- 65 # Integer / Double
128 | president <- TRUE # Boolean
129 | ```
130 |
131 | Variables are called *objects*
132 |
133 | - vector (`c()`)
134 | - `matrix()`
135 | - `data.frame()`
136 | - `list()`
137 |
138 | ## Vectors
139 | ```{r}
140 | staff <- c("Josh", "CJ", "Sam")
141 | staff
142 | ```
143 |
144 | ### Indexing Objects
145 | ```{r}
146 | staff[2]
147 | staff[c(1, 3)]
148 | ```
149 |
150 | ## Matrices
151 | Matrices are "tables" with at least one row and one column.
152 |
153 | ```{r echo = FALSE}
154 | m <- matrix(1:9, nrow = 3)
155 | ```
156 |
157 | ```{r}
158 | m # A matrix
159 | ```
160 |
161 | ## Trial & Error 2
162 | **Make a matrix `m` with the help of the function `matrix`. How can matrices be indexed?**
163 |
164 | ```{r eval = FALSE}
165 | ?matrix
166 | ```
167 |
168 | ## Trial & Error 2
169 | **Make a matrix `m` with the help of the function `matrix`. How can matrices be indexed?**
170 |
171 | ```{r}
172 | m <- matrix(c(1:9), nrow = 3)
173 | m[1, ] # First row
174 | m[, 3] # Third column
175 | m[1, 3] # Element in the first row and third column
176 | ```
177 |
178 | ## data.frame
179 | Vectors and matrices can only contain one data type.
180 |
181 | ```{r}
182 | (x <- c(1:3))
183 | (x <- c(1:3, "four")) # all elements become characters
184 | ```
185 |
186 | The data we analyze are different types.
187 |
188 | ## data.frame {.build}
189 | A `data.frame` is
190 |
191 | - a table similar to a matrix
192 | - can contain different data types
193 | - usually has column names
194 |
195 | I usually use `data.frame`s for my data.
196 |
197 | The structure of the data should be
198 |
199 | - one observation per row
200 | - one variable per column
201 |
202 | ## Trial & Error 3
203 | New data:
204 |
205 | ```{r}
206 | name <- c("Ben", "Kathy", "Paul", "Julia", "Jeff")
207 | age <- c(24, 43, 32, 27, 60)
208 | job <- rep("teacher", 5)
209 | friends <- c(5, 2, 0, 3, 6)
210 | pets <- c(0, 2, 4, 1, 1)
211 | income <- c(":/", ":)", ":(", ":(", ":)")
212 |
213 | teachers <- data.frame(name, age, job, friends, pets, income)
214 | save(teachers, file = "data/teachers.RData")
215 | ```
216 |
217 | ```{r echo = FALSE}
218 | name <- c("Ben", "Kathy", "Paul", "Julia", "Jeff")
219 | age <- c(24, 43, 32, 27, 60)
220 | job <- rep("teacher", 5)
221 | friends <- c(5, 2, 0, 3, 6)
222 | pets <- c(0, 2, 4, 1, 1)
223 | income <- c(":/", ":)", ":(", ":(", ":)")
224 |
225 | teachers <- data.frame(name, age, job, friends, pets, income)
226 | save(teachers, file = "data/teachers.RData")
227 | ```
228 |
229 | ## Trial & Error 3
230 | **Load data `teachers.RData` or make the data frame yourself. Calculate the pets to friends ratio and add this variable to the `data.frame`.**
231 |
232 | **Calculate the average age for happy-face income and sad-face income.**
233 |
234 | ## Trial & Error 3
235 | **Calculate the pets to friends ratio and add this variable to the `data.frame`.**
236 |
237 | ```{r}
238 | teachers$ratio <- teachers$pets / teachers$friends
239 | teachers
240 | ```
241 |
242 | ## Trial & Error 3
243 |
244 | **Calculate the average age for happy-face income and sad-face income.**
245 |
246 | ```{r}
247 | mean(teachers$age[teachers$income == ":)"])
248 | tapply(teachers$age, teachers$income, mean)
249 | ```
250 |
251 | ## Swirl
252 | Try out the R-package `swirl`.
253 |
254 | ```{r eval = FALSE}
255 | install.packages("swirl")
256 | library("swirl")
257 |
258 | install_from_swirl("R Programming")
259 | swirl()
260 | #try 10: lapply and sapply
261 | #try 11: vapply and tapply
262 | ```
263 |
264 | # Deliberately use a function
265 |
266 | ## Example
267 |
268 | ```{r echo = F}
269 | set.seed(666)
270 | x <- rnorm(50, 10, 2)
271 | y <- rnorm(50, 12, 4)
272 | dat.fun <- data.frame(sub = 1:50, x, y)
273 |
274 | write.csv(dat.fun, "data/example_fun.csv", row.names = F)
275 | ```
276 |
277 | ```{r}
278 | head(dat.fun)
279 | ```
280 |
281 |
282 | ## Analysis of this boring data set
283 |
284 | >- We want to analyse this data set with a $t$-test
285 | >- We need two functions:
286 | > - One to read in the data (`read.csv`)
287 | > - One to conduct the $t$-test (`t.test`)
288 |
289 | ## read.csv {.build}
290 |
291 | ```{r eval = F}
292 | ?read.csv
293 | ```
294 |
295 | It shows several related functions. `read.csv` has several *arguments*, most of them have a *default setting*.
296 |
297 | Minimal usage: Submit the filename to `read.csv`.
298 |
299 | ```{r eval = F}
300 | example.dat <- read.csv(file = "day1/intro-to-R/data/example_fun.csv")
301 | head(example.dat)
302 | ```
303 |
304 | ```{r echo = F}
305 | example.dat <- read.csv(file = "data/example_fun.csv")
306 | head(example.dat)
307 | ```
308 |
309 | ## Trial & Error 4: t-test
310 |
311 | **Use `help()` to navigate the `t-test` function. What arguments to you need to submit to the function? What are the results?**
312 |
313 | ## Trial & Error 4: t-test {.build .smaller}
314 |
315 | **Use `help()` to navigate the `t-test` function. What arguments to you need to submit to the function? What are the results?**
316 |
317 | ```{r eval = F}
318 | ?t.test
319 | ```
320 |
321 | Easiest usage: submit x and y. You can choose one- or two-sided hypotheses, one-sample or paired *t*-test (default is between-participant) and whether variances are assumed to be equal or not...
322 |
323 | ```{r}
324 | t.test(example.dat$x, example.dat$y, var.equal = T)
325 | ```
326 |
327 | # Actual Data in R
328 |
329 | ## Getting data into R
330 |
331 | >- We used the `read.csv` function before.
332 | >- But what if you want data from another source?
333 | >- Like the internet?
334 | >- [wmPNAS2008](wmPNAS2008)
335 |
336 | ## curl
337 |
338 | ```{r}
339 | daturl <- curl::curl("https://raw.githubusercontent.com/PerceptionCognitionLab/data0/master/wmPNAS2008/lk2clean.csv")
340 | dat <- read.csv(daturl, header = T)
341 |
342 | head(dat)
343 | ```
344 |
345 | ## Let's make it prettier
346 |
347 | ```{r}
348 | dat.pretty <- dat[, c("sub", "blk", "trl", "prch", "N", "ischange", "resp")]
349 | dat.pretty$accuracy <- dat.pretty$ischange == dat.pretty$resp
350 |
351 | dat.pretty$ischange <- factor(dat.pretty$ischange, labels = c("unchanged", "changed"))
352 |
353 | head(dat.pretty)
354 | ```
355 |
356 | ## Analyze it
357 |
358 | ```{r}
359 | mean.acc <- with(dat.pretty, tapply(accuracy, list(prch, N, ischange), mean))
360 | mean.acc
361 | ```
362 |
363 | ## Plot it?
364 |
365 | ```{r, echo = F}
366 | layout(matrix(1:2, ncol = 2))
367 | matplot(mean.acc[,,1], main = "Unchanged", ylab = "Accuracy"
368 | , type = "b", pch = colnames(mean.acc), xaxt = "n")
369 | axis(1, at = 1:3, labels = rownames(mean.acc))
370 | matplot(mean.acc[,,2], main = "Changed", ylab = "Accuracy"
371 | , type = "b", pch = colnames(mean.acc), xaxt = "n")
372 | axis(1, at = 1:3, labels = rownames(mean.acc))
373 | ```
374 |
375 | ## Plot it {.smaller}
376 |
377 | ```{r}
378 | mean.acc[,,1]
379 | ```
380 |
381 | ```{r eval = F}
382 | matplot(mean.acc[,,1] # data
383 | , main = "Unchanged", ylab = "Accuracy" #labels: title and y-axis
384 | , type = "b", pch = colnames(mean.acc)) #type = "both" line and point, point type = set size
385 | ```
386 |
387 | ```{r, fig.width=4.5, fig.height=3.1, echo = F, fig.align='center'}
388 | par(mar = c(3.5, 4, 1.5, 2))
389 | matplot(mean.acc[,,1] # data
390 | , main = "Unchanged", ylab = "Accuracy" #labels: title and y-axis
391 | , type = "b", pch = colnames(mean.acc)) #type = "both" line and point, point type = set size
392 | ```
393 |
394 | ## Counting
395 |
396 | ```{r}
397 | (tab <- table(dat.pretty$resp, dat.pretty$ischange))
398 | ```
399 |
400 | ## Counting
401 |
402 | ```{r}
403 | tab
404 | ```
405 |
406 | - Hits, misses, false alarms, correct rejections
407 |
408 | ## Counting
409 |
410 | ```{r}
411 | tab
412 | ```
413 |
414 | - Hits, misses, false alarms, correct rejections
415 |
416 | ```{r}
417 | (outcomes <- c("hits" = tab[2, 2], "misses" = tab[1, 2]
418 | , "fa" = tab[2, 1], "cr" = tab[1, 1]))
419 | ```
420 |
421 | ## Plot counts
422 |
423 | ```{r}
424 | barplot(outcomes)
425 | ```
426 |
427 | ## Plot counts
428 |
429 | Go crazy on the [colors!](http://www.stat.columbia.edu/~tzheng/files/Rcolor.pdf)
430 |
431 | ```{r}
432 | barplot(outcomes, col = "mediumvioletred")
433 | ```
434 |
435 | #Programming in R
436 |
437 | ##Functions
438 |
439 | >- You use them in data analysis all the time
440 | >- i.e. `mean()`, `plot()`, `t.test()`,...
441 | >- But you can also write your own!
442 |
443 | ##Write your own function | Hello world!
444 |
445 | ```{r}
446 | hello <- function(){
447 | return("Hello World!")
448 | }
449 |
450 | hello()
451 | ```
452 |
453 | ##Write your own function | Calculator
454 |
455 | Goal: A function that takes two numbers as arguments and returns the sum of them.
456 |
457 | ##Write your own function | Calculator
458 |
459 | Goal: A function that takes two numbers as arguments and returns the sum of them.
460 |
461 | ```{r}
462 | gimme.sum <- function(x, y){
463 | sum.xy <- x + y
464 | return(sum.xy)
465 | }
466 |
467 | gimme.sum(99, 567)
468 | ```
469 |
470 | ##Write your own function | Calculator
471 |
472 | Goal: A function that takes two numbers as arguments and returns the sum of them.
473 |
474 | ```{r}
475 | gimme.sum <- function(x, y){
476 | sum.xy <- x + y
477 | return(sum.xy)
478 | }
479 |
480 | gimme.sum(c(1, 2, 5, 7), 567)
481 | ```
482 |
483 | ##Write your own function | Your turn!
484 |
485 | Goal: A function that takes two vectors of numbers, x and y, and returns a vector with length of x with $\frac{x}{sd_y}$.
486 |
487 | ##Write your own function | Your turn!
488 |
489 | Goal: A function that takes two vectors of numbers, x and y, and returns a vector with length of x with $\frac{x}{sd_y}$.
490 |
491 | ```{r}
492 | what <- function(x, y){
493 | sdy <- sd(y)
494 | return(x/sdy)
495 | }
496 | ```
497 |
498 | ##Write your own function | Your turn!
499 |
500 | Goal: A function that takes two vectors of numbers, x and y, and returns a vector with length of x with $\frac{x}{sd_y}$.
501 |
502 | ```{r}
503 | what <- function(x, y){
504 | sdy <- sd(y)
505 | return(x/sdy)
506 | }
507 |
508 | what(c(1, 2, 3), c(1, 4, 7))
509 |
510 | what(1:3, c(1, 1, 1))
511 | ```
512 |
513 |
--------------------------------------------------------------------------------
/day1/intro-to-R/pictures/Expectations-reality.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/jstbcs/CognitiveModelingWorkshop/080db90e6745f28247a7829222982912e6f9b6dd/day1/intro-to-R/pictures/Expectations-reality.png
--------------------------------------------------------------------------------
/day1/intro-to-R/pictures/MUlogoRGB.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/jstbcs/CognitiveModelingWorkshop/080db90e6745f28247a7829222982912e6f9b6dd/day1/intro-to-R/pictures/MUlogoRGB.png
--------------------------------------------------------------------------------
/day1/intro-to-R/pictures/Rlogo.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/jstbcs/CognitiveModelingWorkshop/080db90e6745f28247a7829222982912e6f9b6dd/day1/intro-to-R/pictures/Rlogo.png
--------------------------------------------------------------------------------
/day1/intro-to-process-models/high-threshold.rmd:
--------------------------------------------------------------------------------
1 | ---
2 | title: "High-Threshold Models"
3 | author: "Julia Haaf & Stephen Rhodes"
4 | output:
5 | ioslides_presentation:
6 | logo: pictures/MUlogoRGB.png
7 | widescreen: true
8 | subtitle: The Easy Way To Model
9 | ---
10 |
11 | # Signal Detection Experiment
12 |
13 | ## Signal Detection Experiment | Example
14 |
15 | >- Subliminal perception
16 | >- Very brief presentation of a word vs. no word
17 | >- Signal: + ... TRUMP ... *****
18 | >- Noise: + ... ... *****
19 |
20 | ## Signal Detection Experiment | Example
21 |
22 | **Results**
23 |
24 | | Stimulus | Present response | Absent Response | Total |
25 | |:------|:-----:|:---------:|:------:|
26 | | Signal | 75 | 25 | 100 |
27 | | Noise | 30 | 20 | 50 |
28 | | Total | 105 | 45 | |
29 |
30 | >- Hits, Misses, False Alarms, Correct Rejections
31 | >- vs. Accuracy
32 |
33 | ## Modeling a Signal Detection Experiment
34 |
35 | >- Let $Y_h$, $Y_m$, $Y_f$, and $Y_c$ be random variables denoting counts of events
36 | >- $N_s$ and $N_n$ denote numbers of signal and noise trials
37 | >- How many independent pieces of data?
38 |
39 | >- Simple binomial model:
40 | \[
41 | Y_h \sim \mbox{Binomial}(N_s, p_h),\\
42 | Y_f \sim \mbox{Binomial}(N_n, p_f).
43 | \]
44 |
45 | >- Maximum-Likelihood estimates here are $\hat{p}_h = \frac{y_h}{N_s} = 75/100 = .75$ and $\hat{p}_f = \frac{y_f}{N_n} = 30/50 = .6$
46 | >- Any concerns with this model?
47 |
48 | ## High-Threshold Model
49 |
50 | Perception as an all-or-none process
51 |
52 | ```{r htmodel,engine='tikz',fig.ext='svg',fig.width=8, echo = F, fig.align='center'}
53 | \begin{tikzpicture}[level 1/.style={sibling distance=4cm}, level 2/.style={sibling distance=3cm}, grow=right, yscale=-1, xscale=1.5]
54 |
55 | % target tree
56 | \node [rectangle, draw] (a) {Signal}
57 | child {node [rectangle, draw] (b) {Detect Signal} % detect
58 | child {node [rectangle, draw] (c) [anchor=west] {hit}}}
59 | child {node [rectangle, draw] (d) {Fail to Detect} % not detect
60 | child {node [rectangle, draw] (e) [anchor=west] {hit}}
61 | child {node [rectangle, draw] (f) [anchor=west] {miss}}};
62 | % non-target tree
63 | \node [rectangle, draw] (g) [right =7cm] {Noise}
64 | child {node [rectangle, draw] (h) {false alarm}}
65 | child {node [rectangle, draw] (i) {correct rejection}};
66 | % add lines and labels
67 | \draw[->,>=stealth] (a) -- node[midway,fill=white] {$d$} (b);
68 | \draw[->,>=stealth] (a) -- node[midway,fill=white] {$1 - d$} (d);
69 | \draw[->,>=stealth] (d) -- node[midway,fill=white] {$g$} (e);
70 | \draw[->,>=stealth] (d) -- node[midway,fill=white] {$1 - g$} (f);
71 | \draw[->,>=stealth] (b) -- (c);
72 | \draw[->,>=stealth] (g) -- node[midway,fill=white] {$g$} (h);
73 | \draw[->,>=stealth] (g) -- node[midway,fill=white] {$1 - g$} (i);
74 |
75 | \end{tikzpicture}
76 | ```
77 |
78 | ##HTM as Statistical Model
79 |
80 | >- Simple binomial model:
81 | \[
82 | Y_h \sim \mbox{Binomial}(N_s, p_h),\\
83 | Y_f \sim \mbox{Binomial}(N_n, p_f).
84 | \]
85 | >- High-Threshold model:
86 | \[
87 | Y_h \sim \mbox{Binomial}(N_s, d + (1 - d)g),\\
88 | Y_f \sim \mbox{Binomial}(N_n, g).
89 | \]
90 |
91 | ```{r,engine='tikz',fig.ext='svg',fig.width=4, echo = F, fig.align='right'}
92 | \begin{tikzpicture}[level 1/.style={sibling distance=4cm}, level 2/.style={sibling distance=3cm}, grow=right, yscale=-1, xscale=1.5]
93 |
94 | % target tree
95 | \node [rectangle, draw] (a) {Signal}
96 | child {node [rectangle, draw] (b) {Detect Signal} % detect
97 | child {node [rectangle, draw] (c) [anchor=west] {hit}}}
98 | child {node [rectangle, draw] (d) {Fail to Detect} % not detect
99 | child {node [rectangle, draw] (e) [anchor=west] {hit}}
100 | child {node [rectangle, draw] (f) [anchor=west] {miss}}};
101 | % non-target tree
102 | \node [rectangle, draw] (g) [right =7cm] {Noise}
103 | child {node [rectangle, draw] (h) {false alarm}}
104 | child {node [rectangle, draw] (i) {correct rejection}};
105 | % add lines and labels
106 | \draw[->,>=stealth] (a) -- node[midway,fill=white] {$d$} (b);
107 | \draw[->,>=stealth] (a) -- node[midway,fill=white] {$1 - d$} (d);
108 | \draw[->,>=stealth] (d) -- node[midway,fill=white] {$g$} (e);
109 | \draw[->,>=stealth] (d) -- node[midway,fill=white] {$1 - g$} (f);
110 | \draw[->,>=stealth] (b) -- (c);
111 | \draw[->,>=stealth] (g) -- node[midway,fill=white] {$g$} (h);
112 | \draw[->,>=stealth] (g) -- node[midway,fill=white] {$1 - g$} (i);
113 |
114 | \end{tikzpicture}
115 | ```
116 |
117 | ##HTM as Statistical Model | Estimates
118 |
119 | - High-Threshold model:
120 | \[
121 | Y_h \sim \mbox{Binomial}(N_s, d + (1 - d)g),\\
122 | Y_f \sim \mbox{Binomial}(N_n, g).
123 | \]
124 | - Maximum likelihood estimates for this model can be directly derived
125 | - $\hat{d} = \frac{\hat{p}_h - \hat{p}_f}{1 - \hat{p}_f} = .375$
126 | - $\hat{g} = \hat{p}_f = .6$
127 |
128 | ##HTM in R
129 |
130 | Now we need our function-writing skills!
131 |
132 | ```{r}
133 | #negative log likelihood of high-threshold model
134 | nll.ht <- function(par, y){ #1. argument: vector with parameters, 2. arg: vector with data (h, m, f, c)
135 | d <- par[1]
136 | g <- par[2]
137 | p <- 1:4 # reserve space
138 | p[1] <- d + (1 - d) * g #probability of a hit
139 | p[2] <- 1 - p[1] # probability of a miss
140 | p[3] <- g # probability of a false alarm
141 | p[4] <- 1 - p[3] #probability of a correct rejection
142 | return(-sum(y * log(p)))
143 | }
144 | ```
145 |
146 | ##HTM in R | Data analysis
147 |
148 | Maximize the function
149 |
150 | ```{r}
151 | y <- c(75, 25, 30, 20) #h, m, f, c
152 | par <- c(.5, .5) #starting values for probability parameters
153 | out <- optim(par, nll.ht, y = y)
154 | print(out$par)
155 | ```
156 |
157 | >- Compare to analytic solution: $\hat{d} = .375$ and $\hat{g} = .6$
158 |
159 | # Testing for Selective Influence
160 |
161 | ## Is Perception All-or-none?
162 |
163 | >- How can we test this experimentally for subliminal perception?
164 | >- Manipulations affecting the guessing parameter $g$, e.g. reward manipulation
165 | >- Manipulations affecting the strength parameter $d$, e.g. presentation time manipulation (12ms vs. 20ms)
166 | >- How would you test selective influence with a high-threshold model?
167 |
168 | ## Model Extension
169 |
170 | Let $i$ denote condition, $i = 1$ for 12ms presentation and $i = 2$ for 20ms presentation.
171 |
172 | ```{r,engine='tikz',fig.ext='svg',fig.width=8, echo = F, fig.align='center'}
173 | \begin{tikzpicture}[level 1/.style={sibling distance=4cm}, level 2/.style={sibling distance=3cm}, grow=right, yscale=-1, xscale=1.5]
174 |
175 | % target tree
176 | \node [rectangle, draw] (a) {Signal}
177 | child {node [rectangle, draw] (b) {Detect Signal} % detect
178 | child {node [rectangle, draw] (c) [anchor=west] {hit}}}
179 | child {node [rectangle, draw] (d) {Fail to Detect} % not detect
180 | child {node [rectangle, draw] (e) [anchor=west] {hit}}
181 | child {node [rectangle, draw] (f) [anchor=west] {miss}}};
182 | % non-target tree
183 | \node [rectangle, draw] (g) [right =7cm] {Noise}
184 | child {node [rectangle, draw] (h) {false alarm}}
185 | child {node [rectangle, draw] (i) {correct rejection}};
186 | % add lines and labels
187 | \draw[->,>=stealth] (a) -- node[midway,fill=white] {$d_i$} (b);
188 | \draw[->,>=stealth] (a) -- node[midway,fill=white] {$1 - d_i$} (d);
189 | \draw[->,>=stealth] (d) -- node[midway,fill=white] {$g_i$} (e);
190 | \draw[->,>=stealth] (d) -- node[midway,fill=white] {$1 - g_i$} (f);
191 | \draw[->,>=stealth] (b) -- (c);
192 | \draw[->,>=stealth] (g) -- node[midway,fill=white] {$g_i$} (h);
193 | \draw[->,>=stealth] (g) -- node[midway,fill=white] {$1 - g_i$} (i);
194 |
195 | \end{tikzpicture}
196 | ```
197 |
198 | ## Model Extension
199 |
200 | In model notation:
201 | \[
202 | Y_{ih} \sim \mbox{Binomial}(N_{is}, d_i + (1 - d_i)g_i),\\
203 | Y_{if} \sim \mbox{Binomial}(N_{in}, g_i).
204 | \]
205 |
206 | ## Model Comparison
207 |
208 | **General Model**
209 | \[
210 | Y_{ih} \sim \mbox{Binomial}(N_{is}, d_i + (1 - d_i)g_i),\\
211 | Y_{if} \sim \mbox{Binomial}(N_{in}, g_i).
212 | \]
213 |
214 | >- Selective influence can be tested by gradually restricting this model
215 | >- $M_1$: Restricting $d_1 = d_2$
216 | >- $M_2$: Restricting $g_1 = g_2$
217 | >- Model comparison by comparing the fit of the models to the data (same as regression)
218 |
219 | ## Model Comparison
220 |
221 | **General Model**
222 | \[
223 | Y_{ih} \sim \mbox{Binomial}(N_{is}, d_i + (1 - d_i)g_i),\\
224 | Y_{if} \sim \mbox{Binomial}(N_{in}, g_i).
225 | \]
226 |
227 | **Model 1**
228 | \[
229 | Y_{ih} \sim \mbox{Binomial}(N_{is}, d + (1 - d)g_i),\\
230 | Y_{if} \sim \mbox{Binomial}(N_{in}, g_i).
231 | \]
232 |
233 | **Model 2**
234 | \[
235 | Y_{ih} \sim \mbox{Binomial}(N_{is}, d_i + (1 - d_i)g),\\
236 | Y_{if} \sim \mbox{Binomial}(N_{in}, g).
237 | \]
238 |
239 | ## Models in R
240 |
241 | ```{r}
242 | #negative log likelihood for any one condition
243 | nll.condition <- function(par, y){ #assign par=c(d, g), y = c(h, m, f, c)
244 | p <- 1:4
245 | d <- par[1]
246 | g <- par[2]
247 | p[1] <- d + (1 - d) * g
248 | p[2] <- 1 - p[1]
249 | p[3] <- g
250 | p[4] <- 1 - p[3]
251 | return(-sum(y * log(p)))
252 | }
253 | ```
254 |
255 | ## Models in R {.smaller}
256 |
257 | ```{r}
258 | #negative log likelihood for General Model:
259 | #assign par4 = (d1, g1, d2, g2), y8 = (h1, m1, f1, c1, h2, m2, f2, c2)
260 | nll.g <- function(par4, y8){
261 | nll.condition(par4[1:2], y8[1:4]) + #condition 1
262 | nll.condition(par4[3:4], y8[5:8]) #condition 2
263 | }
264 |
265 | #negative log likelihood for Model 1:
266 | #assign par3 = (d, g1, g2), y8 = (h1, m1, f1, c1, h2, m2, f2, c2)
267 | nll.1 <- function(par3, y8){
268 | nll.condition(par3[1:2], y8[1:4]) + #condition 1
269 | nll.condition(par3[c(1, 3)], y8[5:8]) #condition 2
270 | }
271 |
272 | #negative log likelihood for Model 2:
273 | #assign par3 = (d1, d2, g), y8 = (h1, m1, f1, c1, h2, m2, f2, c2)
274 | nll.2 <- function(par3, y8){
275 | nll.condition(par3[c(1, 3)], y8[1:4]) + #condition 1
276 | nll.condition(par3[2:3], y8[5:8]) #condition 2
277 | }
278 | ```
279 |
280 | ## Data and Analysis
281 |
282 | ```{r}
283 | dat <- c(22, 28, 22, 28 #h, m, f, c for condition 1
284 | , 35, 15, 21, 29) #h, m, f, c for condition 2
285 |
286 | #General Model
287 | par.m <- c(.5, .5, .5, .5) #starting values
288 | mod.g <- optim(par.m, nll.g,y8 = dat, hessian = T)
289 |
290 | #Model 1
291 | par.m <- c(.5, .5, .5) #starting values
292 | mod.1 <- optim(par.m, nll.1, y8 = dat, hessian = T)
293 |
294 | #Model 2
295 | par.m <- c(.5, .5, .5) #starting values
296 | mod.2 <- optim(par.m, nll.2, y8 = dat, hessian = T)
297 | ```
298 |
299 | ## Estimation Results
300 |
301 | ```{r, echo = F}
302 | output.par <- matrix(c(round(mod.g$par, 3), "", ""
303 | , "", round(mod.1$par[2], 3), "", round(mod.1$par[c(3, 1)], 3), ""
304 | , round(mod.2$par[1], 3), "", round(mod.2$par[2], 3), "", "", round(mod.2$par[3], 3))
305 | , ncol = 6, byrow = T)
306 | rownames(output.par) <- c("General Model", "Model 1", "Model 2")
307 | colnames(output.par) <- c("d1", "g1", "d2", "g1", "d", "g")
308 |
309 | library("knitr")
310 | kable(output.par)
311 | ```
312 |
313 | ## Model Comparison
314 |
315 | Let's take a look at the maximum likelihood value
316 | ```{r}
317 | c(mod.g$value, mod.1$value, mod.2$value)
318 | ```
319 |
320 | ## Model Comparison
321 |
322 | And calculate the $G^2$-statistic.
323 | ```{r}
324 | G1 <- 2*(mod.1$value - mod.g$value)
325 | G2 <- 2*(mod.2$value - mod.g$value)
326 | ```
327 |
328 | Under the Null, $G^2$ follows a $\chi^2$-distribution with 1 degree of freedom (one parameter less).
329 | ```{r}
330 | qchisq(.95, df = 1) #Critical value for alpha = .05
331 |
332 | c(m1 = 1 - pchisq(G1, df = 1), m2 = 1 - pchisq(G2, df = 1)) #p-values
333 | ```
334 |
335 | ## Trial & Error
336 |
337 | You are testing the validity of the high-threshold model for the perception of faint audio tones with a selective influence test. In Condition 1, you pay 10c for each hit and 1c for each correct rejection. In Condition 2, you pay the reverse (1c for each hit and 10c for each correct rejection). Condition
338 | 1 favors tone-present responses; condition 2 favors a tone-absent responses. **The manipulation is hypothesized to affect $g$ and not $d$.** The obtained data are given below. Use `R` to test for selective influence.
339 |
340 | ```{r, echo = F}
341 | newdat <- matrix(c(40, 10, 30, 20
342 | , 15, 35, 2, 48)
343 | , ncol = 4, byrow = T)
344 | rownames(newdat) <- c("Condition 1", "Condition 2")
345 | colnames(newdat) <- c("Hit", "Miss", "False Alarm", "Correct Rejection")
346 |
347 | library("knitr")
348 | kable(newdat)
349 | ```
350 |
351 | ## Trial & Error: Solution | Fit Models to Data
352 |
353 | ```{r}
354 | dat2 <- c(40, 10, 30, 20
355 | , 15, 35, 2, 48)
356 |
357 | #General Model
358 | par.m <- c(.5, .5, .5, .5) #starting values
359 | mod.g <- optim(par.m, nll.g, y8 = dat2, hessian = T)
360 |
361 | #Model 1
362 | par.m <- c(.5, .5, .5) #starting values
363 | mod.1 <- optim(par.m, nll.1, y8 = dat2, hessian = T)
364 |
365 | #Model 2
366 | par.m <- c(.5, .5, .5) #starting values
367 | mod.2 <- optim(par.m, nll.2, y8 = dat2, hessian = T)
368 | ```
369 |
370 | ## Trial & Error: Solution | Check Parameter Estimates
371 |
372 | ```{r, echo = F}
373 | output.par <- matrix(c(round(mod.g$par, 3), "", ""
374 | , "", round(mod.1$par[2], 3), "", round(mod.1$par[c(3, 1)], 3), ""
375 | , round(mod.2$par[1], 3), "", round(mod.2$par[2], 3), "", "", round(mod.2$par[3], 3))
376 | , ncol = 6, byrow = T)
377 | rownames(output.par) <- c("General Model", "Model 1", "Model 2")
378 | colnames(output.par) <- c("d1", "g1", "d2", "g1", "d", "g")
379 |
380 | library("knitr")
381 | kable(output.par)
382 | ```
383 |
384 | ## Trial & Error: Solution | Fix Model 2
385 |
386 | ```{r}
387 | #negative log likelihood for Model 2:
388 | #assign par3 = (d1, d2, g), y8 = (h1, m1, f1, c1, h2, m2, f2, c2)
389 | nll.2 <- function(par2, y8){
390 | nll.condition(par2[c(1, 2)], y8[1:4]) + #condition 1
391 | nll.condition(c(0, par2[2]), y8[5:8]) #condition 2
392 | }
393 |
394 | #Model 2
395 | par.m <- c(.5, .5) #starting values
396 | mod.2 <- optim(par.m, nll.2, y8 = dat2, hessian = T)
397 | ```
398 |
399 | ## Trial & Error: Solution | Check Parameter Estimates Again
400 |
401 | ```{r, echo = F}
402 | output.par <- matrix(c(round(mod.g$par, 3), "", ""
403 | , "", round(mod.1$par[2], 3), "", round(mod.1$par[c(3, 1)], 3), ""
404 | , round(mod.2$par[1], 3), "", 0, "", "", round(mod.2$par[2], 3))
405 | , ncol = 6, byrow = T)
406 | rownames(output.par) <- c("General Model", "Model 1", "Model 2")
407 | colnames(output.par) <- c("d1", "g1", "d2", "g1", "d", "g")
408 |
409 | library("knitr")
410 | kable(output.par)
411 | ```
412 |
413 | ## Trial & Error: Solution | Model Comparison
414 |
415 | Calculate the $G^2$-statistic.
416 | ```{r}
417 | G1 <- 2*(mod.1$value - mod.g$value)
418 | G2 <- 2*(mod.2$value - mod.g$value)
419 |
420 | c(G1, G2)
421 |
422 | c(m1 = round(1 - pchisq(G1, df = 1), 3), m2 = 1 - pchisq(G2, df = 1)) #p-values
423 | ```
424 |
425 | # Can We Detect Noise?
426 |
427 | ## Double-High-Threshold Model
428 |
429 | Plausible for memory research
430 |
431 | ```{r twohtmodel,engine='tikz',fig.ext='svg',fig.width=9.5, echo = F, fig.align='center'}
432 | \begin{tikzpicture}[level 1/.style={sibling distance=4cm}, level 2/.style={sibling distance=3cm}, grow=right, yscale=-1, xscale=1.4]
433 |
434 | % target tree
435 | \node [rectangle, draw] (a) {Signal}
436 | child {node [rectangle, draw] (b) {Detect Signal} % detect
437 | child {node [rectangle, draw] (c) [anchor=west] {hit}}}
438 | child {node [rectangle, draw] (d) {Fail to Detect} % not detect
439 | child {node [rectangle, draw] (e) [anchor=west] {hit}}
440 | child {node [rectangle, draw] (f) [anchor=west] {miss}}};
441 | % non-target tree
442 | \node [rectangle, draw] (g) [right =6.5cm] {Noise}
443 | child {node [rectangle, draw] (h) {Detect Noise} % detect
444 | child {node [rectangle, draw] (i) [anchor=west] {correct rejection}}}
445 | child {node [rectangle, draw] (j) {Fail to Detect} % not detect
446 | child {node [rectangle, draw] (k) [anchor=west] {false alarm}}
447 | child {node [rectangle, draw] (l) [anchor=west] {correct rejection}}};
448 | % add lines and labels
449 | \draw[->,>=stealth] (a) -- node[midway,fill=white] {$d$} (b);
450 | \draw[->,>=stealth] (a) -- node[midway,fill=white] {$1 - d$} (d);
451 | \draw[->,>=stealth] (d) -- node[midway,fill=white] {$g$} (e);
452 | \draw[->,>=stealth] (d) -- node[midway,fill=white] {$1 - g$} (f);
453 | \draw[->,>=stealth] (b) -- (c);
454 | \draw[->,>=stealth] (g) -- node[midway,fill=white] {$d$} (h);
455 | \draw[->,>=stealth] (g) -- node[midway,fill=white] {$1 - d$} (j);
456 | \draw[->,>=stealth] (j) -- node[midway,fill=white] {$g$} (k);
457 | \draw[->,>=stealth] (j) -- node[midway,fill=white] {$1 - g$} (l);
458 | \draw[->,>=stealth] (h) -- (i);
459 |
460 | \end{tikzpicture}
461 | ```
462 |
463 | ## Express 2HT Model in model notation {.smaller}
464 |
465 | Single High-Threshold Model
466 |
467 | \[
468 | Y_{ih} \sim \mbox{Binomial}(N_{is}, d_i + (1 - d_i)g_i),\\
469 | Y_{if} \sim \mbox{Binomial}(N_{in}, g_i).
470 | \]
471 |
472 | **Trial & Error:** Change the notation above for the Double-High-Threshold model. Make a new `function()` like `nll.condition()` for the estimation of the Double-High-Threshold model.
473 |
474 |
475 |
476 |
477 |
478 |
479 | ```{r twohtmodelb,engine='tikz',fig.ext='svg',fig.width=7, echo = F, fig.align='right'}
480 | \begin{tikzpicture}[level 1/.style={sibling distance=4cm}, level 2/.style={sibling distance=3cm}, grow=right, yscale=-1, xscale=1.4]
481 |
482 | % target tree
483 | \node [rectangle, draw] (a) {Signal}
484 | child {node [rectangle, draw] (b) {Detect Signal} % detect
485 | child {node [rectangle, draw] (c) [anchor=west] {hit}}}
486 | child {node [rectangle, draw] (d) {Fail to Detect} % not detect
487 | child {node [rectangle, draw] (e) [anchor=west] {hit}}
488 | child {node [rectangle, draw] (f) [anchor=west] {miss}}};
489 | % non-target tree
490 | \node [rectangle, draw] (g) [right =6.5cm] {Noise}
491 | child {node [rectangle, draw] (h) {Detect Noise} % detect
492 | child {node [rectangle, draw] (i) [anchor=west] {correct rejection}}}
493 | child {node [rectangle, draw] (j) {Fail to Detect} % not detect
494 | child {node [rectangle, draw] (k) [anchor=west] {false alarm}}
495 | child {node [rectangle, draw] (l) [anchor=west] {correct rejection}}};
496 | % add lines and labels
497 | \draw[->,>=stealth] (a) -- node[midway,fill=white] {$d$} (b);
498 | \draw[->,>=stealth] (a) -- node[midway,fill=white] {$1 - d$} (d);
499 | \draw[->,>=stealth] (d) -- node[midway,fill=white] {$g$} (e);
500 | \draw[->,>=stealth] (d) -- node[midway,fill=white] {$1 - g$} (f);
501 | \draw[->,>=stealth] (b) -- (c);
502 | \draw[->,>=stealth] (g) -- node[midway,fill=white] {$d$} (h);
503 | \draw[->,>=stealth] (g) -- node[midway,fill=white] {$1 - d$} (j);
504 | \draw[->,>=stealth] (j) -- node[midway,fill=white] {$g$} (k);
505 | \draw[->,>=stealth] (j) -- node[midway,fill=white] {$1 - g$} (l);
506 | \draw[->,>=stealth] (h) -- (i);
507 |
508 | \end{tikzpicture}
509 | ```
510 |
511 | ## Express 2HT Model in model notation {.smaller}
512 |
513 | Single High-Threshold Model
514 |
515 | \[
516 | Y_{ih} \sim \mbox{Binomial}(N_{is}, d_i + (1 - d_i)g_i),\\
517 | Y_{if} \sim \mbox{Binomial}(N_{in}, g_i).
518 | \]
519 |
520 | Double-High-Threshold Model
521 |
522 | \[
523 | Y_{ih} \sim \mbox{Binomial}(N_{is}, d_i + (1 - d_i)g_i),\\
524 | Y_{if} \sim \mbox{Binomial}(N_{in}, (1 - d_i)g_i).
525 | \]
526 |
527 | ```{r twohtmodelc,engine='tikz',fig.ext='svg',fig.width=6, echo = F, fig.align='right'}
528 | \begin{tikzpicture}[level 1/.style={sibling distance=4cm}, level 2/.style={sibling distance=3cm}, grow=right, yscale=-1, xscale=1.4]
529 |
530 | % target tree
531 | \node [rectangle, draw] (a) {Signal}
532 | child {node [rectangle, draw] (b) {Detect Signal} % detect
533 | child {node [rectangle, draw] (c) [anchor=west] {hit}}}
534 | child {node [rectangle, draw] (d) {Fail to Detect} % not detect
535 | child {node [rectangle, draw] (e) [anchor=west] {hit}}
536 | child {node [rectangle, draw] (f) [anchor=west] {miss}}};
537 | % non-target tree
538 | \node [rectangle, draw] (g) [right =6.5cm] {Noise}
539 | child {node [rectangle, draw] (h) {Detect Noise} % detect
540 | child {node [rectangle, draw] (i) [anchor=west] {correct rejection}}}
541 | child {node [rectangle, draw] (j) {Fail to Detect} % not detect
542 | child {node [rectangle, draw] (k) [anchor=west] {false alarm}}
543 | child {node [rectangle, draw] (l) [anchor=west] {correct rejection}}};
544 | % add lines and labels
545 | \draw[->,>=stealth] (a) -- node[midway,fill=white] {$d$} (b);
546 | \draw[->,>=stealth] (a) -- node[midway,fill=white] {$1 - d$} (d);
547 | \draw[->,>=stealth] (d) -- node[midway,fill=white] {$g$} (e);
548 | \draw[->,>=stealth] (d) -- node[midway,fill=white] {$1 - g$} (f);
549 | \draw[->,>=stealth] (b) -- (c);
550 | \draw[->,>=stealth] (g) -- node[midway,fill=white] {$d$} (h);
551 | \draw[->,>=stealth] (g) -- node[midway,fill=white] {$1 - d$} (j);
552 | \draw[->,>=stealth] (j) -- node[midway,fill=white] {$g$} (k);
553 | \draw[->,>=stealth] (j) -- node[midway,fill=white] {$1 - g$} (l);
554 | \draw[->,>=stealth] (h) -- (i);
555 |
556 | \end{tikzpicture}
557 | ```
558 |
559 |
560 | ## Double-High-Threshold Model in R
561 |
562 | ```{r}
563 | #negative log likelihood for double high-threshold model
564 | nll.2ht <- function(par, y){
565 | d <- par[1]
566 | g <- par[2]
567 | p <- 1:4 # reserve space
568 | p[1] <- d + (1 - d) * g # probability of a hit
569 | p[2] <- 1 - p[1] # probability of a miss
570 | p[3] <- (1 - d) * g # probability of a false alarm
571 | p[4] <- 1 - p[3] # probability of a correct rejection
572 | return(-sum(y * log(p)))
573 | }
574 | ```
575 |
576 |
--------------------------------------------------------------------------------
/day1/intro-to-process-models/pictures/Expectations-reality.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/jstbcs/CognitiveModelingWorkshop/080db90e6745f28247a7829222982912e6f9b6dd/day1/intro-to-process-models/pictures/Expectations-reality.png
--------------------------------------------------------------------------------
/day1/intro-to-process-models/pictures/MUlogoRGB.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/jstbcs/CognitiveModelingWorkshop/080db90e6745f28247a7829222982912e6f9b6dd/day1/intro-to-process-models/pictures/MUlogoRGB.png
--------------------------------------------------------------------------------
/day1/intro-to-process-models/pictures/Rlogo.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/jstbcs/CognitiveModelingWorkshop/080db90e6745f28247a7829222982912e6f9b6dd/day1/intro-to-process-models/pictures/Rlogo.png
--------------------------------------------------------------------------------
/day1/intro-to-process-models/script-for-slides.R:
--------------------------------------------------------------------------------
1 | ############### First High-Thrshold Model #################################################
2 |
3 | #negative log likelihood of high-threshold model
4 | nll.ht <- function(par, y){ #1. argument: vector with parameters, 2. arg: vector with data (h, m, f, c)
5 | d <- par[1]
6 | g <- par[2]
7 | p <- 1:4 # reserve space
8 | p[1] <- d + (1 - d) * g #probability of a hit
9 | p[2] <- 1 - p[1] # probability of a miss
10 | p[3] <- g # probability of a false alarm
11 | p[4] <- 1 - p[3] #probability of a correct rejection
12 | return(-sum(y * log(p)))
13 | }
14 |
15 | y <- c(75, 25, 30, 20) #h, m, f, c
16 | par <- c(.5, .5) #starting values for probability parameters
17 | out <- optim(par, nll.ht, y = y)
18 | out$par
19 | out$value
20 |
21 | ################ Model Comparison High-Threshold Model ####################################
22 |
23 |
24 | #negative log likelihood for any one condition
25 | nll.condition <- function(par, y){ #assign par=c(d, g), y = c(h, m, f, c)
26 | p <- 1:4
27 | d <- par[1]
28 | g <- par[2]
29 | p[1] <- d + (1 - d) * g
30 | p[2] <- 1 - p[1]
31 | p[3] <- (1 - d) * g
32 | p[4] <- 1 - p[3]
33 | return(-sum(y * log(p)))
34 | }
35 |
36 | #negative log likelihood for General Model:
37 | #assign par4 = (d1, g1, d2, g2), y8 = (h1, m1, f1, c1, h2, m2, f2, c2)
38 | nll.g <- function(par4, y8){
39 | nll.condition(par4[1:2], y8[1:4]) + #condition 1
40 | nll.condition(par4[3:4], y8[5:8]) #condition 2
41 | }
42 |
43 | #negative log likelihood for Model 1:
44 | #assign par3 = (d, g1, g2), y8 = (h1, m1, f1, c1, h2, m2, f2, c2)
45 | nll.1 <- function(par3, y8){
46 | nll.condition(par3[1:2], y8[1:4]) + #condition 1
47 | nll.condition(par3[c(1, 3)], y8[5:8]) #condition 2
48 | }
49 |
50 | #negative log likelihood for Model 2:
51 | #assign par3 = (d1, d2, g), y8 = (h1, m1, f1, c1, h2, m2, f2, c2)
52 | nll.2 <- function(par3, y8){
53 | nll.condition(par3[c(1, 3)], y8[1:4]) + #condition 1
54 | nll.condition(par3[2:3], y8[5:8]) #condition 2
55 | }
56 |
57 |
58 |
59 | ### Data analysis
60 | dat <- c(22, 28, 22, 28 #h, m, f, c for condition 1
61 | , 35, 15, 21, 29) #h, m, f, c for condition 2
62 |
63 | #General Model
64 | par.m <- c(.5, .5, .5, .5) #starting values
65 | mod.g <- optim(par.m, nll.g, y8 = dat, hessian = T)
66 |
67 | #Model 1
68 | par.m <- c(.5, .5, .5) #starting values
69 | mod.1 <- optim(par.m, nll.1, y8 = dat, hessian = T)
70 |
71 | #Model 2
72 | par.m <- c(.5, .5, .5) #starting values
73 | mod.2 <- optim(par.m, nll.2, y8 = dat, hessian = T)
74 |
75 |
76 |
77 | ### Model comparison
78 |
79 | G1 <- 2*(mod.1$value - mod.g$value)
80 | G2 <- 2*(mod.2$value - mod.g$value)
81 |
82 | qchisq(.95, df = 1) #Critical value for alpha = .05
83 |
84 | c(m1 = 1 - pchisq(G1, df = 1), m2 = 1 - pchisq(G2, df = 1)) #p-values
85 |
86 |
87 |
88 | ############### First Signal Detection Model #################################################
89 |
90 | ##Graph
91 | x <- seq(-3, 5, .01)
92 | y.noise <- dnorm(x)
93 | y.signal <- dnorm(x, 1.5)
94 |
95 | plot(x, y.noise
96 | , type = "l", lwd = 2
97 | , xlim = range(x)
98 | , frame.plot = F
99 | , ylab = "Density"
100 | , xlab = "Sensory Strength"
101 | )
102 | lines(x, y.signal, col = "firebrick4", lwd = 2)
103 | # make.line(0)
104 | # make.line(1.5, 1.5)
105 | abline(v = 1, lwd = 2, col = "darkgreen")
106 | axis(3, at = c(0, 1.5), labels = c("", ""))
107 | mtext("d'", 3, line = .5, at = .75, cex = 1.3)
108 | text(1.2, .03, "c", cex = 1.3)
109 | text(-2, .25, "Stimulus absent")
110 | text(3.5, .25, "Stimulus present")
111 |
112 | ##Model
113 | #log likelihood for signal detection
114 | ll.sd <- function(par, y){ #par = c(d', c) y = c(hit, miss, fa, cr)
115 | p <- 1:4
116 | p[1] <- 1 - pnorm(par[2], par[1], 1)
117 | p[2] <- 1 - p[1]
118 | p[3] <- 1 - pnorm(par[2], 0, 1)
119 | p[4] <- 1 - p[3]
120 | -sum(y * log(p))
121 | }
122 |
123 | #Data analysis
124 | y <- c(40, 10, 30, 20)
125 | par <- c(1, 0) #starting values
126 | out <- optim(par, ll.sd, y = y)
127 | out$par
128 |
129 |
130 | #####SDT for 2 conditions
131 |
132 | #par = c(d'1, d'2, c) y = c(hit1, miss1, fa1, cr1, hit2, miss2, fa2, cr2)
133 | nll.sdt <- function(par3, y8){
134 | ll.sd(par3[c(1, 3)], y8[1:4]) + #condition 1
135 | ll.sd(par3[2:3], y8[5:8]) #condition 2
136 | }
137 |
138 | ### Data analysis
139 | dat <- c(22, 28, 22, 28 #h, m, f, c for condition 1
140 | , 35, 15, 21, 29) #h, m, f, c for condition 2
141 |
142 | par.m <- c(1, 2, 1) #starting values
143 | out2 <- optim(par.m, nll.sdt, y8 = dat, hessian = T)
144 |
145 |
146 |
147 |
148 |
149 |
--------------------------------------------------------------------------------
/day1/intro-to-process-models/stats101.R:
--------------------------------------------------------------------------------
1 | ####################### Probability Density ##################################
2 |
3 | x <- seq(-3, 3, .01)
4 | y <- dnorm(x = x, mean = 0, sd = 1)
5 |
6 | plot(x, y, type = "l")
7 |
8 |
9 |
10 | x <- seq(-40, 20, .01)
11 | y <- dnorm(x = x, mean = -10, sd = 10)
12 |
13 | plot(x, y, type = "l")
14 |
15 |
16 | samp <- rnorm(10000, -10, 10)
17 | hist(samp)
18 |
19 | qnorm(p = .5, 0, 1)
20 |
--------------------------------------------------------------------------------
/day1/maximum-likelihood/max-lik.Rmd:
--------------------------------------------------------------------------------
1 | ---
2 | title: "Maximum Likelihood in R"
3 | author: "Stephen Rhodes and Julia Haaf"
4 | output:
5 | ioslides_presentation:
6 | logo: ../intro-to-R/pictures/MUlogoRGB.png
7 | widescreen: true
8 | subtitle: Estimating parameters from data
9 |
10 | ---
11 |
12 | ```{r setup, include=FALSE}
13 | knitr::opts_chunk$set(echo = FALSE)
14 | ```
15 |
16 | ## Overview
17 |
18 | - Probability vs Likelihood
19 | - Examples with Binomial and Normal functions
20 | - Searching for Maximum Likelihood with R
21 | - Avoiding local maxima
22 |
23 | # Probability vs Likelihood
24 |
25 | ## Probability
26 |
27 | - Imagine that you give someone a memory test containing 20 items
28 | - They can either get the item correct or incorrect
29 | - You want to figure out what is the probability that the person will get 12 items correct *assuming that they have a 70% chance of producing a correct answer*.
30 | - We can use a binomial model where $n = 20$ and $p = .7$
31 |
32 | $$
33 | K \sim \mbox{Binomial}(n, p)
34 | %p(k; n, p) = {n \choose k} p^k(1-p)^{n-k}
35 | $$
36 |
37 | ## Binomial Probability {.columns-2}
38 |
39 | ```{r, fig.height=5, fig.width=5}
40 |
41 | plot(0:20, dbinom(0:20, size = 20, prob = .7), type='h', xlab="Number Correct", ylab="Probability")
42 |
43 | prob_12 = dbinom(12, size = 20, prob = .7)
44 |
45 | lines(c(0,12,12), c(prob_12, prob_12, 0), lty=2, col='red')
46 |
47 | mtext(text = paste("p(12 correct | 70% chance) =", round(prob_12, 3)), side = 3)
48 |
49 | ```
50 |
51 | $$
52 | p(12; 20, 0.7) = {20 \choose 12} 0.7^{12}0.3^{8}
53 | $$
54 |
55 | Or in `R`
56 |
57 | ```{r, echo=TRUE}
58 | dbinom(x = 12, size = 20, prob = 0.7)
59 | ```
60 |
61 | ## Likelihood
62 |
63 | But!
64 |
65 | - Usually (all the time) we don't know the 'true' probability of a correct response
66 | - Rather we try to *estimate* it from data
67 | - Back to the example:
68 | - we have given someone a 20 item memory test and they got 12 correct
69 | - what is the most probable value of their 'true' accuracy?
70 | - For that we need the *likelihood*
71 |
72 | ## Likelihood
73 |
74 | Switch the data and the parameters.
75 |
76 | ```{r, fig.height=5, fig.width=5}
77 |
78 | theta = seq(0,1, .001)
79 | plot(theta, dbinom(12, size = 20, prob = theta), type='l', xlab="p", ylab="Likelihood")
80 |
81 | max_l = 12/20
82 |
83 | lines(c(max_l,max_l), c(0, 1), lty=2, col='red')
84 |
85 | mtext(text = "L(p | 12/20 correct)", side = 3, line=.5)
86 |
87 | ```
88 |
89 | # Examples
90 |
91 | ## Normal Distribution
92 |
93 | Here is the Normal probability density function for $\mu = 0$ and $\sigma = 1$.
94 |
95 | ```{r, fig.height=5, fig.width=5}
96 |
97 | x = seq(-4,4, .001)
98 | plot(x, dnorm(x), type='l', xlab="x", ylab="Density")
99 |
100 | ```
101 |
102 | ## Example with a Normal likelihood function
103 |
104 | Here's some data
105 |
106 | ```{r, fig.width=5}
107 | set.seed(2468)
108 | Y = rnorm(20, 30, 10)
109 | hist(Y, xlab='')
110 | ```
111 |
112 | ## Example - known SD
113 |
114 | Let's assume that we know that $\sigma = 1$. What's the most likely value of $\mu$ for the first observation (Y[1] = `r Y[1]`)?
115 |
116 | ```{r, fig.height=5, fig.width=5}
117 |
118 | mu = seq(Y[1]-10, Y[1]+10, .001)
119 |
120 | plot(mu, dnorm(Y[1], mean = mu, sd = 1), type = 'l', xlab=bquote(mu), ylab=bquote(L(mu~"|"~Y[1])))
121 |
122 | points(x=Y[1], y = 0, col='red', pch=16, cex=2)
123 |
124 | ```
125 |
126 | ## Example - known SD
127 |
128 | - But we have a *vector* of observations!
129 | - Assuming the observations are independent we can multiply each of the likelihoods
130 | - In our case $\theta = \{\mu, \sigma\}$
131 |
132 | $$
133 | L(\mathbf{\theta \mid y}) = \prod^i L(\theta \mid y_i)
134 | $$
135 |
136 | ## Example - known SD
137 |
138 | - It's more common to work with the *log likelihood* ($LL$) so instead we can sum
139 | - We'll go into more detail on this later
140 |
141 | $$
142 | LL(\theta \mid \mathbf{y}) = \sum^i \ln L(\theta \mid y_i)
143 | $$
144 |
145 | ##Example - known SD
146 |
147 | ```{r}
148 |
149 | mu = seq(10, 40, .001)
150 |
151 | ll_norm = function(y, mu, sigma){
152 | ll = 0
153 | for (i in y){
154 | ll = ll + dnorm(i, mean = mu, sd = sigma, log = T)
155 | }
156 | return(ll)
157 | }
158 |
159 | plot(mu, ll_norm(y=Y, mu = mu, sigma = 1), type='l', xlab=bquote(mu), ylab="log likelihood")
160 |
161 | ```
162 |
163 | ## Example - unknown mean and SD
164 |
165 | What if we don't know either $\mu$ or $\sigma$? The we have to search for the *pair* of parameters that maximize the likelihood.
166 |
167 | ```{r}
168 |
169 | mu = seq(20, 35, length.out = 50)
170 | sigma = seq(5, 15, length.out = 50)
171 |
172 | ll_mat = matrix(NA, ncol = length(mu), nrow = length(sigma))
173 |
174 | for (i in 1:length(sigma)){
175 | for (j in 1:length(mu)){
176 | ll_mat[i,j] = ll_norm(y=Y, mu = mu[j], sigma = sigma[i])
177 | }
178 | }
179 |
180 | par(mfrow=c(1,2))
181 |
182 | persp(x = sigma, y = mu, z = exp(ll_mat), theta = 45, phi=15, zlab = "Likelihood")
183 |
184 | contour(x = sigma, y = mu, z = exp(ll_mat), xlab=bquote(sigma), ylab=bquote(mu), nlevels = 15, drawlabels = F)
185 | points(10, 30, col='red', pch=16, cex=2)
186 |
187 | ```
188 |
189 |
194 |
195 | # Searching for Maximum Likelihood with R
196 |
197 | ## Details
198 |
199 | - When using maximum likelihood estimation you typically actually try to *minimize* the negative log likelihood
200 | - `optim()` is a general-purpose function for finding parameter values that minimize $-LL$
201 |
202 | ## Example
203 |
204 | - Let's return to the previous example with our data.
205 | - To follow along you can type:
206 |
207 | ```{r, echo=T}
208 | # rnorm generates (pseudo) random numbers from a normal distribution
209 | set.seed(2468)
210 | Y = rnorm(n = 20, mean = 30, sd = 10)
211 | Y
212 | ```
213 |
214 | ## Example
215 |
216 | - First we need a function that returns the log likelihood of parameters given the data
217 |
218 | ```{r, echo=T}
219 | ll_norm = function(theta, y){
220 | mu = theta[1]
221 | sigma = theta[2]
222 | ll = 0
223 | for (i in y){
224 | # dnorm returns the density of a normal for a particular value (x) mean and
225 | # standard deviation. Setting log = T gives us the LL
226 | ll = ll + dnorm(x = i, mean = mu, sd = sigma, log = T)
227 | }
228 | return(-ll) # note the negative
229 | }
230 | ```
231 |
232 | ## Example
233 |
234 | ```{r, echo=T}
235 |
236 | # starting values
237 | theta = runif(n = 2, min = 1, max = 10)
238 |
239 | # run the optimization
240 | out = optim(par = theta, fn = ll_norm, y = Y)
241 |
242 | # assess the parameter estimates
243 | out$par
244 |
245 | ```
246 |
247 | # Avoiding local maxima
248 |
249 | ## Avoiding local maxima
250 |
251 | - With many parameters (dimensions) there may be troughs in the likelihood function that are not the global maximum likelihood
252 | - These are called local maxima and optimizers can get stuck there (therefore, not providing the *maximum* likelihood estimates)
253 |
254 | ## Try multiple starting values
255 |
256 | ```{r}
257 |
258 | x = seq(from = 0, to = 10, by = .01)
259 | y = sin(x)*x
260 | plot(x, y, type="l", ylab='', xlab=bquote(theta), lwd=1.5)
261 | points(x = c(2, 4), y = y[x %in% c(4, 2)], type="b", pch=16, cex=1.5, col='red')
262 |
263 | text(x = 4, y = y[x %in% 4], labels = "start", adj=-.5)
264 |
265 | ```
266 |
267 | ## Try multiple starting values
268 |
269 | ```{r}
270 |
271 | x = seq(from = 0, to = 10, by = .01)
272 | y = sin(x)*x
273 | plot(x, y, type="l", ylab='', xlab=bquote(theta), lwd=1.5)
274 | points(x = c(6, x[which(y==max(y))]), y = y[x %in% c(6, x[which(y==max(y))])], type="b", pch=16, cex=1.5, col='red')
275 |
276 | text(x = 6, y = y[x %in% 6], labels = "start", adj=-.5)
277 |
278 | ```
279 |
280 | ## Try different optimizers
281 |
282 | - There are lots of different optimization routines (see, e.g., `?optim`)
283 | - One approach is to pass the results of a first `optim` run to `nlm` then back to `optim`
284 |
285 | ```{r, echo=T}
286 | theta = runif(n = 2, min = 1, max = 10)
287 |
288 | out = optim(par = theta, fn = ll_norm, y = Y)
289 | out2 = nlm(f = ll_norm, p = out$par, y = Y)
290 | out3 = optim(par = out2$estimate, fn = ll_norm, y = Y)
291 |
292 | # compare estimates
293 | cbind(out$par, out2$estimate, out3$par)
294 |
295 | ```
296 |
297 | # Extra Slides
298 |
299 | ## Alternative likelihood function
300 |
301 | You can often avoid using `for` loops in `R`. Below we have rewritten the `ll_norm` function, replacing the loop with `mapply` (see `?mapply`).
302 |
303 | ```{r, echo=T}
304 | ll_norm = function(theta, y){
305 | mu = theta[1]
306 | sigma = theta[2]
307 | ll = sum(mapply(y, FUN = function(x) dnorm(x = x, mean = mu, sd = sigma, log = T)))
308 | return(-ll)
309 | }
310 | ```
311 |
312 | ## Alternative likelihood function
313 |
314 | Even easier! `rnorm` returns a vector
315 |
316 | ```{r, echo=T}
317 | ll_norm = function(theta, y){
318 | mu = theta[1]
319 | sigma = theta[2]
320 | ll = sum(dnorm(x = y, mean = mu, sd = sigma, log = T))
321 | return(-ll)
322 | }
323 | ```
324 |
--------------------------------------------------------------------------------
/day2/bayesian-models/bayes-cog-models.Rmd:
--------------------------------------------------------------------------------
1 | ---
2 | title: "Bayesian Estimation of Cognitive Models"
3 | author: "Stephen Rhodes and Julia Haaf"
4 | output:
5 | ioslides_presentation:
6 | logo: ../../day1/intro-to-R/pictures/MUlogoRGB.png
7 | widescreen: true
8 | subtitle: Modeling the individual and group
9 | ---
10 |
11 | ```{r setup, include=FALSE}
12 | knitr::opts_chunk$set(echo = FALSE)
13 | ```
14 |
15 | ## Overview
16 |
17 | We're going to work through some example models
18 |
19 | - **Change detection data (from yesterday)**
20 | - Delayed estimation recall error
21 | - SDT model of confidence rating data
22 |
23 | These examples use binomial (accuracy), continuous, and ordinal data, respectively.
24 |
25 | # Change Detection
26 |
27 | ## Rouder et al. (2008) data
28 |
29 | The data is structured differently from the MLE example
30 |
31 | ```{r, echo=T}
32 | cd = read.table(file = "jags-change-det/rouder08-longdata-0.5.dat")
33 | head(cd)
34 | # ischange = was the trial a change trial? 1 = yes, 0 = no
35 | # respchange = the number of trials that the participant said 'change' to
36 | # ntrials = number of trials of that type for that participant in that condition
37 | ```
38 |
39 | ## Rouder et al. (2008)
40 |
41 | - See `jags-rouder08.R`
42 | - Reminder of the model:
43 |
44 | $$
45 | p(\mbox{resp} = \mbox{change} \mid \mbox{change}) = h = a(d + (1 - d)g) + (1 - a)g
46 | $$
47 |
48 | $$
49 | p(\mbox{resp} = \mbox{change} \mid \mbox{no-change}) = f = a(1 - d)g + (1 - a)g
50 | $$
51 |
52 | ## In JAGS
53 |
54 | ```{r, eval=F, echo=T}
55 | # p(resp = change)
56 | P[i] <- ifelse(ischange[i] == 1,
57 | a[i]*(d[i]+(1-d[i])*g[i]) + (1-a[i])*g[i], # p(hit)
58 | a[i]*(1-d[i])*g[i] + (1-a[i])*g[i]) # p(false-alarm)
59 | ```
60 |
61 | ## Rouder et al. (2008) hierarchical model
62 |
63 | Parameters for participant $i$ are drawn from independent normals
64 |
65 | $\kappa_i \sim \mbox{Normal}(\mu_\kappa, \sigma_\kappa)$
66 |
67 | $k_i = \max(\kappa_i, 0)$ (see [Morey, 2011](http://isiarticles.com/bundles/Article/pre/pdf/71624.pdf))
68 |
69 | $\mbox{logit}(a_i) \sim \mbox{Normal}(\mu_a, \sigma_a)$
70 |
71 | $\mbox{logit}(g_i) \sim \mbox{Normal}(\mu_g, \sigma_g)$
72 |
73 | ## logit
74 |
75 | $\mbox{logit}(p) = \ln(p/(1-p))$
76 |
77 | Maps probabilities onto real numbers (so we can sample participant parameters from normal distributions)
78 |
79 | In R `qlogis(x)`. In JAGS `logit(x)`
80 |
81 | ```{r, fig.height=3}
82 | par(mar=c(4,4,1,1))
83 | curve(qlogis(x), from=0, to=1, main="", xlab="p", ylab="logit(p)")
84 | ```
85 |
86 | ## In JAGS
87 |
88 | ```{r, eval=F, echo=T}
89 | k[i] <- max(kappa[i], 0) # 'Mass-at-chance' transformation
90 | kappa[i] <- K_s[id[i]]
91 | logit(a[i]) <- A_s[id[i]] # logit transformation
92 | logit(g[i]) <- G_s[id[i]]
93 | ```
94 |
95 | ```{r, eval=F, echo=T}
96 | for (s in 1:S){
97 | K_s[s] ~ dnorm(K_mu, 1/K_sigma^2)
98 | A_s[s] ~ dnorm(A_mu, 1/A_sigma^2)
99 | G_s[s] ~ dnorm(G_mu, 1/G_sigma^2)
100 | }
101 | ```
102 |
103 | ## Priors
104 |
105 | $\mu_\kappa \sim \mbox{Normal}(3, 4)$
106 |
107 | $\mu_a \sim \mbox{Normal}(2.2, 4)$ (`plogis(2.2)` $\approx$ 0.9)
108 |
109 | $\mu_g \sim \mbox{Normal}(0, 4)$ (`plogis(0)` = 0.5)
110 |
111 | ```{r, eval=F, echo=T}
112 | K_mu ~ dnorm(3, 1/4^2)
113 | A_mu ~ dnorm(2.2, 1/4^2)
114 | G_mu ~ dnorm(0, 1/4^2)
115 | ```
116 |
117 | ## Priors
118 |
119 | $\sigma_\kappa \sim \mbox{Gamma}(s, r)$
120 |
121 | $\sigma_a \sim \mbox{Gamma}(s, r)$
122 |
123 | $\sigma_g \sim \mbox{Gamma}(s, r)$
124 |
125 | ```{r, eval=F, echo=TRUE}
126 | K_sigma ~ dgamma(shape, rate)
127 | A_sigma ~ dgamma(shape, rate)
128 | G_sigma ~ dgamma(shape, rate)
129 |
130 | shape <- 1.01005
131 | rate <- 0.1005012
132 | ```
133 |
134 | ## Priors
135 |
136 | ```{r}
137 | curve(dgamma(x, shape = 1.01005, rate = 0.1005012), from=0, to=20, n = 10000, ylab="", xlab=bquote(sigma), lwd=2)
138 | ```
139 |
140 | It is more intuitive to work with priors on SD, but it can lead to better estimation to use inverse gamma priors on variance or a gamma prior on precision
141 |
142 | # Delayed Estimation
143 |
144 | ## Delayed Estimation
145 |
146 | - Study items that vary on a continuous (usually circular dimension)
147 | - Reproduce a probed item
148 |
149 | ## Zhang and Luck (2008)
150 |
151 | - Another example using colored squares!
152 |
153 | ```{r, out.width = "200px", echo=F}
154 | knitr::include_graphics("pictures/zhang-luck.png")
155 | ```
156 |
157 | ## Zhang and Luck (2008) - data
158 |
159 | ```{r, echo=T}
160 | de = read.table("delayed-estimation/zhang-luck08.dat")
161 |
162 | head(de)
163 | ```
164 |
165 | ## Zhang and Luck (2008) - data
166 |
167 | ```{r, echo=F}
168 | colors = rainbow(4, alpha = .5)
169 | par(mfrow = c(2,2), mar=c(3,3,2,2))
170 | Ns = unique(de$setsize)
171 | Ns = Ns[order(Ns)]
172 |
173 | for (i in 1:4){
174 | N = Ns[i]
175 | with(subset(de, setsize==N), hist(error, main=paste0("N = ", N), xlab="error (rad)", ylab="", col=colors[i], breaks=30))
176 | }
177 |
178 | ```
179 |
180 | ## Zhang and Luck (2008) - models
181 |
182 | Responses are a *mixture* of memory responses and random guesses
183 |
184 | $p(y = x) = P_{m}\mbox{vonMises}(x; \sigma) + (1 - P_m)\frac{1}{2\pi}$
185 |
186 | ```{r, fig.height=4, echo=F, messages=F, warning=F}
187 | library(circular, quietly = T, warn.conflicts = F)
188 | de_mixture <- function(y, sd, pmem, mu=0, log=T){
189 | # delayed estimation mixture
190 | dvon = suppressWarnings(dvonmises(circular(y), mu = mu, kappa = 1/sd^2)) # suppresses messages about converting data to the circular class
191 | p <- pmem*dvon + (1-pmem)*(1/(2*pi))
192 | if (log){
193 | return(log(p))
194 | }else{
195 | return(p)
196 | }
197 | }
198 |
199 | curve(de_mixture(x, sd = .5, pmem = .8, log=F), from=-pi, to=pi, ylim=c(0,.8), ylab='', xlab="Error (radians)", lwd=2)
200 |
201 | curve(de_mixture(x, sd = .5, pmem = .5, log=F), from=-pi, to=pi, ylim=c(0,.8), lwd=2, add = T, col="dodgerblue")
202 |
203 | legend('topleft', legend = c(.8, .5), lwd=2, col=c("black", 'dodgerblue'), bty='n', title="Pm")
204 |
205 | ```
206 |
207 | ## Zhang and Luck (2008) - models
208 |
209 | They also fit a simpler version of the model where all responses are from memory and only the standard deviation of the von Mises (circular normal) distribution varies with set size.
210 |
211 | ```{r, fig.height=4, echo=F, messages=F, warning=F}
212 |
213 | curve(de_mixture(x, sd = .5, pmem = 1, log=F), from=-pi, to=pi, ylim=c(0,.8), ylab='', xlab="Error (radians)", lwd=2)
214 |
215 | curve(de_mixture(x, sd = 1, pmem = 1, log=F), from=-pi, to=pi, ylim=c(0,.8), lwd=2, add = T, col="dodgerblue")
216 |
217 | legend('topleft', legend = c(.5, 1), lwd=2, col=c("black", 'dodgerblue'), bty='n', title="SD")
218 |
219 | ```
220 |
221 | ## In JAGS
222 |
223 | See [Oberauer et al. (2016)](https://www.ncbi.nlm.nih.gov/pubmed/28538991)
224 |
225 | ```{r, eval=F, echo=T}
226 |
227 | for (i in 1:n){
228 | y[i] ~ dvonmises(mu, kappa[i])
229 |
230 | kappa[i] <- (1/sd[i]^2)*z[i] # kappa = 0 produces a uniform distribution
231 |
232 | z[i] ~ dbern(pm[i]) # 1 = response from memory, 0 = guess
233 |
234 | pm[i] <- min(k[i]/N[i], 1)
235 | k[i] <- max(kap[i], 0)
236 | kap[i] <- K_s[id[i]]
237 | sd[i] <- exp(SD_s[id[i], N_i[i]])
238 | }
239 | ```
240 |
241 | ## In JAGS
242 |
243 | ```{r, eval=F, echo=T}
244 | for (s in 1:S){
245 | K_s[s] ~ dnorm(K_mu, 1/K_sigma^2)
246 | for (ss in 1:N_n){
247 | SD_s[s, ss] ~ dnorm(SD_mu[ss], 1/SD_sigma^2)
248 | }
249 | }
250 |
251 | K_mu ~ dnorm(3, 1/4^2)
252 | for (ss in 1:N_n){
253 | SD_mu[ss] ~ dnorm(2, 1/10^2)
254 | }
255 |
256 | SD_sigma ~ dgamma(shape, rate)
257 | K_sigma ~ dgamma(shape, rate)
258 |
259 | shape <- 1.01005
260 | rate <- 0.1005012
261 | ```
262 |
263 | ## In JAGS
264 |
265 | `jags-zhang-luck08.R` runs hierarchical models on this data set. However, you need to install an extension for JAGS to get the von Mises distribution. Those interested can follow the links in the script to get the module.
266 |
267 | `mle-zhang-luck08.R` contains functions for MLE. Those interested can also use these to model this data set
268 |
269 | ##
270 |
271 | For both change detection and (especially) delayed estimation many more complicated models have been proposed.
272 |
273 | See, for example, [van den Berg et al. (2014)](http://www.cns.nyu.edu/malab/static/files/publications/2014%20Van%20den%20Berg%20Ma%20Psych%20Review.pdf)
274 |
275 | These models provide the foundations for the more complex versions.
276 |
277 | # SDT confidence ratings
278 |
279 | ```{r}
280 | ratingModel <- function(d, s, a, b, C, lastPoint = T){
281 | # the parsimonius model from Selker et al
282 | # https://osf.io/v3b76/
283 | unb = -log((1 - 1:C/C)/(1:C/C))
284 |
285 | thresh = 1/2 + a*unb + b
286 |
287 | f = cumsum(rev(diff(pnorm(c(-Inf, thresh),0,1))))
288 | h = cumsum(rev(diff(pnorm(c(-Inf, thresh),d,s))))
289 |
290 | if(!lastPoint){
291 | f = f[1:(C-1)]
292 | h = h[1:(C-1)]
293 | }
294 | return(cbind(f, h))
295 | }
296 |
297 | plotSDT <- function(d = 2, s = 1, a = 1, b = 0, C = 6, title = F){
298 | par(pty='m', mar=c(4,2,3,2))
299 |
300 | xrange <- c(-3, d+3*s)
301 | newcol = col2rgb("dodgerblue4")[,1]
302 | newcol = rgb(red = newcol[1], green = newcol[2], blue = newcol[3], alpha = 50, maxColorValue = 255)
303 | oldcol=rgb(1,1,1,.5)
304 | xseq = seq(from=xrange[1], to=xrange[2], length.out = 1000)
305 |
306 | unb = -log((1 - 1:C/C)/(1:C/C))
307 | thresh = 1/2 + a*unb + b
308 | thresh = thresh[1:(C-1)]
309 |
310 | yrange = c(0, max(dnorm(0), dnorm(d, d, s)))
311 | plot(NA, ylim = yrange*c(0,1.5), xlim = xrange, ylab="", xlab="", axes=F)
312 |
313 | polygon(c(xrange[1], xseq, xrange[2]), c(0, dnorm(xseq), 0), col = newcol , border = NA)
314 | curve(expr = dnorm(x, 0, 1), from=xrange[1], to=xrange[2], n = 10000, add = T)
315 | polygon(c(xrange[1], xseq, xrange[2]), c(0, dnorm(xseq, d, s), 0), col = oldcol , border = NA)
316 | curve(expr = dnorm(x, d, s), from=xrange[1], to=xrange[2], n = 10000, add = T)
317 |
318 | for (k in 1:(C-1)){
319 | lines(x = c(thresh[k], thresh[k]), y = yrange*c(0, 1.35), lty=2, col='darkgrey')
320 | text(x = thresh[k], y = yrange[2]*1.4, labels = bquote(lambda[.(k)]))
321 | }
322 |
323 | label_x = c(xrange[1], thresh, xrange[2])[1:C] + diff(c(xrange[1], thresh, xrange[2]))/2
324 |
325 | text(x = label_x, y = yrange[2]*1.2, labels = 1:C, col='red')
326 |
327 | axis(1); box()
328 |
329 | if (title){
330 | mtext(text = paste0("d = ", d, ", s = ", s, ", a = ", a, ", b = ", b))
331 | }
332 | mtext(text = "Strength of Evidence for 'old'", 1, line = 2.5)
333 | }
334 |
335 | # par(pty='s')
336 | # plot(ratingModel(d = 2, s = 1.2, a = 1, b = 0, C = 1000), ylim=c(0,1), xlim=c(0,1), type='l', xlab='false-alarm rate', ylab='hit rate')
337 | # a = ratingModel(d = 2, s = 1.2, a = 1, b = 0, C = 6, lastPoint=F)
338 | # points(a, ylim=c(0,1), xlim=c(0,1), pch=21, bg='grey')
339 | #
340 | # text(t(t(a)+c(.05,-.05)), labels = 5:1)
341 | #
342 | # par(mfrow=c(1,2))
343 | #
344 | # plotSDT(d = 2, s = 1.2, a = 1, b = -2/3, C = 6)
345 | # mtext("Shift to the left (more liberal)")
346 | #
347 | # plotSDT(d = 2, s = 1.2, a = 1, b = 1, C = 6)
348 | # mtext("Shift to the right (more conservative)")
349 | #
350 | # par(pty='s', mfrow=c(1,2))
351 | #
352 | # plot(ratingModel(d = 2, s = 1.2, a = 1, b = 0, C = 1000), ylim=c(0,1), xlim=c(0,1), type='l', xlab='false-alarm rate', ylab='hit rate')
353 | # a = ratingModel(d = 2, s = 1.2, a = 1, b = -2/3, C = 6, lastPoint=F)
354 | # points(a, ylim=c(0,1), xlim=c(0,1), pch=21, bg='grey')
355 | #
356 | # mtext("Shift to the left (more liberal)")
357 | #
358 | # plot(ratingModel(d = 2, s = 1.2, a = 1, b = 0, C = 1000), ylim=c(0,1), xlim=c(0,1), type='l', xlab='false-alarm rate', ylab='hit rate')
359 | # a = ratingModel(d = 2, s = 1.2, a = 1, b = 1, C = 6, lastPoint=F)
360 | # points(a, ylim=c(0,1), xlim=c(0,1), pch=21, bg='grey')
361 | # mtext("Shift to the right (more conservative)")
362 |
363 | ```
364 |
365 | ## Example paradigm (Pratte et al., 2010, JEPLMC)
366 |
367 | - Participants study 240 sequentially presented words
368 | - At test they see 480 words (1/2 old/studied, 1/2 new)
369 | - Instead of an old/new judgement, participants give an ordinal response:
370 | - 1 = *sure new*, 2 = *believe new*, 3 = *guess new*, 4 = *guess old*, 5 = *believe old*, 6 = *sure old*.
371 |
372 | ## Why?
373 |
374 | - To separate sensitivity from bias we need to know the ROC curve
375 | - With an old/new decision we only get one point (left)
376 | - Multiple ratings allow us to approximate ROC curves (right)
377 |
378 | ```{r, fig.height=4}
379 | par(pty='s', mfrow=c(1,2), mar=c(3,4,1,1))
380 | plot(NA, ylim=c(0,1), xlim=c(0,1), type='l', xlab='false-alarm rate', ylab='hit rate', main="Old/New")
381 | a = ratingModel(d = 2, s = 1.2, a = 1, b = 0, C = 6, lastPoint=F)
382 | points(a[3,1], a[3,2], ylim=c(0,1), xlim=c(0,1), pch=21, bg='grey', cex=1.5)
383 |
384 | plot(NA, ylim=c(0,1), xlim=c(0,1), type='l', xlab='false-alarm rate', ylab='hit rate', main="Rating 1-6")
385 | points(a, ylim=c(0,1), xlim=c(0,1), pch=21, bg='grey', cex=1.5)
386 | ```
387 |
388 | ## Signal detection model
389 |
390 | For the old/new task the signal detection theory model is:
391 |
392 | ```{r}
393 | plotSDT(d = 2, s = 1.2, a = 1, b = 1, C = 2)
394 | ```
395 |
396 | ## Signal detection model
397 |
398 | For the rating task the signal detection theory model is:
399 |
400 | ```{r}
401 | plotSDT(d = 2, s = 1.2, a = 1, b = .3, C = 6)
402 | ```
403 |
404 | ## Signal detection model
405 |
406 |
407 | - The participant is assumed to set up $K - 1$ thresholds (where $K$ is the number of rating categories).
408 | - $p(\mbox{rating} = k \mid \mbox{new}) = \Phi(-\lambda_k) - \Phi(-\lambda_{k - 1})$ ($\Phi$ = `pnorm`)
409 | - $p(\mbox{rating} = k \mid \mbox{old}) = \Phi\left(\frac{d - \lambda_k}{s}\right) - \Phi\left(\frac{d - \lambda_{k - 1}}{s}\right)$
410 | - $\lambda_0 = -\infty$, $\lambda_K = -\infty$
411 | - $d$ = sensitivity, $s$ = SD of the old distribution
412 |
413 |
414 |
415 |
416 |
417 |
418 | ```{r, fig.width=4, fig.height=5, fig.align='right'}
419 | plotSDT(d = 2, s = 1.2, a = 1, b = .3, C = 6)
420 | ```
421 |
422 |
423 |
424 | ## Signal detection model
425 |
426 | - If the thresholds are freely estimated the number of parameters to be estimated increases as the number of rating options increases.
427 | - [Selker et al. (pre-print)](https://osf.io/b6z8e/) present a way of modeling thresholds with two parameters
428 | - Start with unbiased thresholds ($\gamma_k$)
429 | - Scale and shift them with two parameters: $\lambda_k = 1/2 + a\gamma_k + b$
430 | - Scale = $a$, Shift = $b$
431 |
432 | ## Selker et al. signal detection model
433 |
434 | Scale
435 |
436 | ```{r}
437 | par(mfrow=c(1,2))
438 | plotSDT(d = 2, s = 1.2, a = 1, b = .3, C = 6, title = T)
439 |
440 | plotSDT(d = 2, s = 1.2, a = 1.5, b = .3, C = 6, title = T)
441 | ```
442 |
443 | ## Selker et al. signal detection model
444 |
445 | Shift
446 |
447 | ```{r}
448 | par(mfrow=c(1,2))
449 | plotSDT(d = 2, s = 1.2, a = 1, b = 0, C = 6, title = T)
450 |
451 | plotSDT(d = 2, s = 1.2, a = 1, b = 1.5, C = 6, title = T)
452 | ```
453 |
454 | ## Model
455 |
456 | $d_i \sim \mbox{Normal}(d_\mu, 1)$
457 |
458 | $s_i \sim \mbox{Normal}(s_\mu, 1)$
459 |
460 | $a_i \sim \mbox{Normal}(a_\mu, 1)$
461 |
462 | $b_i \sim \mbox{Normal}(b_\mu, 1)$
463 |
464 | In JAGS (see `HierSDT_model.txt`)
465 |
466 | ```{r, eval=F, echo=T}
467 | mu[k] ~ dnorm(muMu,1) #
468 | sigma[k] ~ dnorm(sigmaMu, 1) # unequal-variance (s)
469 | lambda[k] <- 1/(sigma[k]^2) # 1/s^2
470 | ```
471 |
472 | ## Model
473 |
474 | Hyperparameters
475 |
476 | $d_\mu \sim \mbox{Normal}^+(1, 1)$
477 |
478 | $s_\mu \sim \mbox{Normal}(1.1, 1)\mbox{I}(1,5)$
479 |
480 | $a_\mu \sim \mbox{Normal}^+(1, 1)$
481 |
482 | $a_\mu \sim \mbox{Normal}(0, 1)$
483 |
484 | In JAGS (see `HierSDT_model.txt`)
485 |
486 | ```{r, eval=F, echo=T}
487 | muMu ~ dnorm(1,1) I(0,)
488 | sigmaMu ~ dnorm(1.1,1) I(1,5)
489 | aMu ~ dnorm(1,1) I(0,)
490 | bMu ~ dnorm(0,1)
491 | ```
492 |
493 | ## Model
494 |
495 | This code sets the thresholds ($\lambda_k$)
496 |
497 | ```{r, eval=F, echo=T}
498 | # Set unbiased thresholds on the [0,1] line and the real line [-∞,∞]
499 | for (c in 1:(nCat-1)) {
500 | gam[c] <- c/nCat
501 | gamReal[c] <- -log((1-gam[c])/gam[c])
502 | }
503 |
504 |
505 | # Use regression function to estimate thresholds on real line
506 | for (c in 1:(nCat-1)) {
507 | dReal[k, c] <- a[k] * gamReal[c] + b[k] + .5
508 | }
509 |
510 | # in the code k refers to participants and c to ratings...
511 | ```
512 |
513 | ## Data
514 |
515 | Before talking more about the data it's useful to introduce the structure of the data, which comes from [Pratte et al. (2010)](http://pcn.psychology.msstate.edu/Publications/Pratte_etal_JEPLMC_2010.pdf)
516 |
517 | ```{r, echo=T}
518 |
519 | load("confidence-rating/pratte10.RData")
520 |
521 | str(pratte10_list)
522 |
523 | ```
524 |
525 | ## Model
526 |
527 | New trials
528 |
529 | ```{r, eval=F, echo=T}
530 | for (i in 1:nNoise[k]) { # for noise items
531 | pNoise[k,i,1] <- pnorm(dReal[k,1], 0, 1) # gets area under first threshold
532 | for (c in 2:(nCat-1)) { # gets area between thresholds 2:(nCat-1)
533 | pNoise[k,i,c] <- pnorm(dReal[k,c], 0, 1) - sum(pNoise[k,i,1:(c-1)])
534 | }
535 | pNoise[k,i,nCat] <- 1 - sum(pNoise[k,i,1:(nCat-1)]) # gets area for the last threshold
536 | xNoise[k,i] ~ dcat(pNoise[k,i,1:nCat]) # likelihood
537 | }
538 | ```
539 |
540 | ## Model
541 |
542 | Old trials
543 |
544 | ```{r, eval=F, echo=T}
545 | for (j in 1:nSignal[k]) { # for signal items
546 | pSignal[k,j,1] <- pnorm(dReal[k,1], mu[k], lambda[k]) # gets area under first threshold
547 | for (c in 2:(nCat-1)) { # gets area between thresholds 2:(nCat-1)
548 | pSignal[k,j,c] <- pnorm(dReal[k,c], mu[k], lambda[k]) - sum(pSignal[k,j,1:(c-1)])
549 | }
550 | pSignal[k,j,nCat] <- 1 - sum(pSignal[k,j,1:(nCat-1)]) # gets area for the last
551 | xSignal[k,j] ~ dcat(pSignal[k,j,1:nCat]) # likelihood
552 | }
553 | ```
554 |
555 | ##
556 |
557 | To work with this example go to the `fit-selker-model.R` script
558 |
559 | ## End
560 |
561 | This has been a whirlwind tour of fitting models in `R`
562 |
563 | For more detail, here are some great resources (there are many more):
564 |
565 | - [Farrell & Lewandowsky (2018) Computational Modeling of Cognition and Behavior](https://www.amazon.com/Computational-Modeling-Cognition-Behavior-Farrell/dp/1107525616/ref=pd_lpo_sbs_14_t_0?_encoding=UTF8&psc=1&refRID=NFD23G008H81Q439Q2QE)
566 | - [Lee & Wagenmakers (2014) Bayesian Cognitive Modeling: A Practical Course](https://www.amazon.com/Bayesian-Cognitive-Modeling-Practical-Course/dp/1107603579/ref=pd_bxgy_14_img_3?_encoding=UTF8&pd_rd_i=1107603579&pd_rd_r=Z05RWKB1HN2NMKPGVRHP&pd_rd_w=eKzQg&pd_rd_wg=XyvbI&psc=1&refRID=Z05RWKB1HN2NMKPGVRHP&dpID=51QoaqipF1L&preST=_SX218_BO1,204,203,200_QL40_&dpSrc=detail)
567 | - [Kruschke (2015) Doing Bayesian Data Analysis: A Tutorial with R, JAGS, and Stan](https://www.amazon.com/Doing-Bayesian-Data-Analysis-Tutorial/dp/0124058884/ref=pd_sim_14_1?_encoding=UTF8&pd_rd_i=0124058884&pd_rd_r=D124M2XTXH7G3SF300RD&pd_rd_w=vLV8u&pd_rd_wg=jNgS3&psc=1&refRID=D124M2XTXH7G3SF300RD&dpID=51LLy0AWDpL&preST=_SX218_BO1,204,203,200_QL40_&dpSrc=detail)
568 | - [Gelman et al. (2014) Bayesian Data Analysis](https://www.amazon.com/Bayesian-Analysis-Chapman-Statistical-Science/dp/1439840954/ref=pd_bxgy_14_img_2?_encoding=UTF8&pd_rd_i=1439840954&pd_rd_r=RBYBCWN0A0E90KM82XAD&pd_rd_w=xo7nR&pd_rd_wg=i2M4F&psc=1&refRID=RBYBCWN0A0E90KM82XAD&dpID=51gfDsQ7vxL&preST=_SY291_BO1,204,203,200_QL40_&dpSrc=detail)
569 |
570 |
571 |
--------------------------------------------------------------------------------
/day2/bayesian-models/confidence-rating/HierSDT_model.txt:
--------------------------------------------------------------------------------
1 | # downloaded from https://osf.io/4pxyf/
2 |
3 | # Model from Selker et al. Parsimonious Estimation of SDT Models from Confidence Ratings (see https://osf.io/v3b76/)
4 |
5 | # Hierarchical SDT with confidence ratings that does not assume unequal variances
6 |
7 | model
8 | {
9 | ## Parameter of interest
10 | muMu ~ dnorm(1,1) I(0,)
11 | sigmaMu ~ dnorm(1.1,1) I(1,5)
12 | aMu ~ dnorm(1,1) I(0,)
13 | bMu ~ dnorm(0,1)
14 |
15 | # Set unbiased thresholds on the [0,1] line and the real line [-∞,∞]
16 | for (c in 1:(nCat-1)) {
17 | gam[c] <- c/nCat
18 | gamReal[c] <- -log((1-gam[c])/gam[c])
19 | }
20 |
21 | for (k in 1:nSubjs) {
22 |
23 | mu[k] ~ dnorm(muMu,1)
24 | sigma[k] ~ dnorm(sigmaMu, 1) # unequal-variance
25 | lambda[k] <- 1/(sigma[k]^2)
26 |
27 | ## Thresholds
28 | # Parameters to create biased thresholds; a = scale, b = shift
29 | a[k] ~ dnorm(aMu,1)
30 | b[k] ~ dnorm(bMu,1)
31 | # Use regression function to estimate thresholds on real line
32 | for (c in 1:(nCat-1)) {
33 | dReal[k, c] <- a[k] * gamReal[c] + b[k] + .5
34 | }
35 |
36 | ## Data
37 | # Translate continuous draws from the old/new distribution into
38 | # ordinal data using the thresholds on the real line
39 | for (i in 1:nNoise[k]) { # for noise items
40 | pNoise[k,i,1] <- pnorm(dReal[k,1], 0, 1)
41 | for (c in 2:(nCat-1)) {
42 | pNoise[k,i,c] <- pnorm(dReal[k,c], 0, 1) - sum(pNoise[k,i,1:(c-1)])
43 | }
44 | pNoise[k,i,nCat] <- 1 - sum(pNoise[k,i,1:(nCat-1)])
45 | xNoise[k,i] ~ dcat(pNoise[k,i,1:nCat])
46 | }
47 | for (j in 1:nSignal[k]) { # for signal items
48 | pSignal[k,j,1] <- pnorm(dReal[k,1], mu[k], lambda[k])
49 | for (c in 2:(nCat-1)) {
50 | pSignal[k,j,c] <- pnorm(dReal[k,c], mu[k], lambda[k]) - sum(pSignal[k,j,1:(c-1)])
51 | }
52 | pSignal[k,j,nCat] <- 1 - sum(pSignal[k,j,1:(nCat-1)])
53 | xSignal[k,j] ~ dcat(pSignal[k,j,1:nCat])
54 | }
55 | }
56 | }
--------------------------------------------------------------------------------
/day2/bayesian-models/confidence-rating/fit-selker-model.R:
--------------------------------------------------------------------------------
1 |
2 | library(rjags)
3 | library(coda)
4 | # this loads the data from Pratte et al (2010) Separating Mnemonic Process From Participant and Item Effects in the Assessment of ROC Asymmetries. JEPLMC, 36(1), 224.
5 | # reshaped with code provided by Selker et al. https://osf.io/b8gcf/
6 |
7 | load("day2/bayesian-models/confidence-rating/pratte10.RData")
8 |
9 | str(pratte10_list)
10 |
11 | # xNoise = data from new trials
12 | # xSignal = data from old trials
13 | # xNoise and xSignal are 97x240 matricies. Rows = participants, columns = trials
14 | # observations are ratings 1:6.
15 | # 1 = sure new, 2 = believe new, 3 = guess new, 4 = guess old, 5 = believe old, 6 = sure old
16 | # nNoise, nSignal = number of noise and signal trials, respectively, per participant
17 | # nCat = number of confidence categories (6)
18 | # nSubjs = N participants (97)
19 |
20 | # the model ("HierSDT_model.txt") comes from:
21 | # Selker et al. Parsimonious Estimation of Signal Detection Models from Confidence Ratings. Pre-print available here: https://osf.io/b6z8e/
22 |
23 | ## It can take a long time to fit the model to all participants so instead we can
24 | ## select a subset of participants
25 |
26 | SUBSET = TRUE # set to false if you want to fit to all participants
27 |
28 | if (SUBSET){
29 | nselect = 20 # how many do we want
30 | ppts = sample(1:97, size = nselect)
31 |
32 | pratte10_list$xNoise = pratte10_list$xNoise[ppts,]
33 | pratte10_list$xSignal = pratte10_list$xSignal[ppts,]
34 |
35 | pratte10_list$nNoise = pratte10_list$nNoise[ppts]
36 | pratte10_list$nSignal = pratte10_list$nSignal[ppts]
37 |
38 | pratte10_list$nSubjs = nselect
39 | }
40 |
41 |
42 | # initialize the jags model
43 | rating_jags <- jags.model(file = "day2/bayesian-models/confidence-rating/HierSDT_model.txt", data = pratte10_list, n.chains = 4, n.adapt = 1000)
44 |
45 | # warm up the chains
46 | update(rating_jags, 1000)
47 |
48 | params <- c("muMu", "mu", "sigmaMu", "sigma", "aMu", "a", "bMu", "b")
49 | rating_samples = coda.samples(model = rating_jags, variable.names = params, n.iter = 1000)
50 |
51 | gelman.diag(rating_samples)
52 |
53 | plot(rating_samples)
54 |
--------------------------------------------------------------------------------
/day2/bayesian-models/confidence-rating/pratte10.RData:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/jstbcs/CognitiveModelingWorkshop/080db90e6745f28247a7829222982912e6f9b6dd/day2/bayesian-models/confidence-rating/pratte10.RData
--------------------------------------------------------------------------------
/day2/bayesian-models/delayed-estimation/jags-zhang-luck08.R:
--------------------------------------------------------------------------------
1 |
2 | library(rjags)
3 | library(coda)
4 |
5 | # we need the von mises distribution for this example
6 | # this doesn't come as standard but can be added to JAGS
7 | # for instruction on how to get this, see:
8 | # see https://github.com/yeagle/jags-vonmises and https://link.springer.com/article/10.3758%2Fs13428-013-0369-3
9 | load.module("vonmises")
10 | load.module("dic")
11 |
12 | # Hierarchical models for Zhang and Luck (2008)
13 |
14 | de = read.table("day2/bayesian-models/delayed-estimation/zhang-luck08.dat")
15 |
16 | head(de)
17 |
18 | # the model fit by zhang and luck estimated a separate P_m and sd for each set size
19 | # and each participant!
20 | # the code for the hierarchical version can be found here: "day2/bayesian-models/delayed-estimation/models/z-l-mixture.txt"
21 | # it runs very slowly (if at all) and probably needs to be reparameterized
22 |
23 | # below we fit a model where a capacity (k) is estimated for each participant
24 | # as well as a sd for each set size
25 |
26 | # first we fit the 'resource' model which estimates a different
27 | # sd for each set size
28 |
29 | de_list = list(
30 | mu = pi, # the vonmises distribution supports [0, 2*pi]
31 | y = de$error + pi, # so we have to add pi to the data to re-center
32 | N_i = as.numeric(as.factor(de$setsize)), # index of set size condition
33 | N_n = length(unique(de$setsize)), # number of set sizes
34 | # N = de$setsize,
35 | id = de$ppt,
36 | S = length(unique(de$ppt)),
37 | n = nrow(de)
38 | )
39 |
40 | # initialize the jags model
41 | resource_jags <- jags.model(file = "day2/bayesian-models/delayed-estimation/models/z-l-resource.txt", data = de_list, n.chains = 2, n.adapt = 1000)
42 |
43 | # warm up the chains
44 | update(resource_jags, 1000)
45 |
46 | params = c("SD_s", "SD_mu", "SD_sigma")
47 | resource_samples = coda.samples(model = resource_jags, variable.names = params, n.iter = 1000)
48 |
49 | gelman.diag(resource_samples)
50 |
51 | plot(resource_samples[,'SD_mu[1]'])
52 | plot(resource_samples[,'SD_mu[2]'])
53 | plot(resource_samples[,'SD_mu[3]'])
54 | plot(resource_samples[,'SD_mu[4]'])
55 |
56 | ### Task
57 | # the sd samples are exp transformed
58 | # could you transform them back to their natural scale and plot the histograms?
59 |
60 | ## Mixture model with k limit
61 |
62 | de_list$N = de$setsize # add set size to data list
63 |
64 | # initialize the jags model
65 | mixture_k_jags <- jags.model(file = "day2/bayesian-models/delayed-estimation/models/mixture_k.txt", data = de_list, n.chains = 2, n.adapt = 1000)
66 |
67 | # warm up the chains
68 | update(mixture_k_jags, 1000)
69 |
70 | params = c("K_s", "K_mu", "K_sigma", "SD_s", "SD_mu", "SD_sigma")
71 | mixture_k_samples = coda.samples(model = mixture_k_jags, variable.names = params, n.iter = 1000)
72 |
73 | plot(mixture_k_samples[,'K_mu'])
74 | plot(mixture_k_samples[,'SD_mu[1]'])
75 | plot(mixture_k_samples[,'SD_mu[2]'])
76 | plot(mixture_k_samples[,'SD_mu[3]'])
77 | plot(mixture_k_samples[,'SD_mu[4]'])
78 |
--------------------------------------------------------------------------------
/day2/bayesian-models/delayed-estimation/mle-zhang-luck08.R:
--------------------------------------------------------------------------------
1 |
2 | # maxmimum likelihood modeling of Zhang and Luck (2008, nature)
3 |
4 | de = read.table("day2/bayesian-models/delayed-estimation/zhang-luck08.dat")
5 | # this data was uploaded by van den berg (2014) psych rev (paper here: http://www.cns.nyu.edu/malab/static/files/publications/2014%20Van%20den%20Berg%20Ma%20Psych%20Review.pdf)
6 | # data here: http://www.cns.nyu.edu/malab/static/files/dataAndCode/Van_den_Berg_2014_DATA.zip
7 | # the Zhang & Luck experiment is under E2 (see paper for other data sets)
8 |
9 | str(de)
10 | # participants saw displays of 1,2,3,6 items (setsize)
11 | # error = distance from target in radians
12 | # we add an index to tell us which setsize was tested on a given trial (1:4)
13 | de$setsize_i = as.numeric(as.factor(de$setsize))
14 |
15 | # the package 'circular' gives us circular probability distributions (those with support [-pi, pi])
16 | # the von mises is the circular equivalent of the normal
17 |
18 | # the function below gives the density for a mixture of a vonmises and uniform
19 | # pmem is the probability the response comes from memory
20 | de_mixture <- function(y, sd, pmem, mu=0, log=T){
21 | # delayed estimation mixture
22 | dvon = suppressWarnings(dvonmises(circular(y), mu = mu, kappa = 1/sd^2)) # suppresses messages about converting data to the circular class
23 | p <- pmem*dvon + (1-pmem)*(1/(2*pi))
24 | if (log){
25 | return(log(p))
26 | }else{
27 | return(p)
28 | }
29 | }
30 |
31 | # the line below plots the expected distribution for values of sd and pmem
32 | # try testing out different values
33 | curve(de_mixture(x, sd = .5, pmem = .8, log=F), from=-pi, to=pi, ylim=c(0,.8), ylab='', xlab="Error (radians)")
34 |
35 |
36 | ### FUNCTIONS FOR MLE
37 | # the three functions below use de_mixture to implement 3 different models
38 |
39 | # zhang and luck estimated a different pmem and sd for each set size
40 | zhang_luck <- function(par, y, N_i){
41 | # length(par) = 8 (4*sd + 4*pmem)
42 | N_n = length(unique(N_i))
43 | ll = 0
44 | for (i in 1:length(y)){
45 | ll = ll + de_mixture(y = y[i], sd = par[N_i[i]], pmem = par[N_n + N_i[i]], mu=0, log=T)
46 | }
47 | return(ll)
48 | }
49 |
50 | ## test
51 | # par = runif(8, min = 0, max = rep(c(20, 1), each = 4))
52 | # zhang_luck(par = par, y = de$error[de$ppt==1], N_i = de$setsize_i[de$ppt==1])
53 |
54 | # this version estimates k (number of items in memory) directly to determine pmem for a given setsize
55 | zhang_luck_k <- function(par, y, N, N_i){
56 | # note this function takes the extra argument N
57 | # length(par) = 5 (4*sd + k)
58 | N_n = length(unique(N_i))
59 | ll = 0
60 | for (i in 1:length(y)){
61 | pm = min(par[N_n + 1]/N[i], 1)
62 | ll = ll + de_mixture(y = y[i], sd = par[N_i[i]], pmem = pm, mu=0, log=T)
63 | }
64 | return(ll)
65 | }
66 |
67 | ## test
68 | # par = runif(5, min = 0, max = c(rep(20, 4), 4))
69 | # zhang_luck_k(par = par, y = de$error[de$ppt==1], N = de$setsize[de$ppt==1], N_i = de$setsize_i[de$ppt==1])
70 |
71 | # a SDT "resource" model (no guessing)
72 | # zhang and luck considered a very basic SDT model
73 | # far more elaborate resource models have been proposed since (see, e.g., van den Berg et al., 2014, psych rev)
74 |
75 | resource <- function(par, y, N_i){
76 | # length(par) = 4 (4*sd)
77 | N_n = length(unique(N_i))
78 | ll = 0
79 | for (i in 1:length(y)){
80 | ll = ll + de_mixture(y = y[i], sd = par[N_i[i]], pmem = 1, mu=0, log=T)
81 | }
82 | return(ll)
83 | }
84 |
85 | ## test
86 | # par = runif(4, min = 0, max = rep(20, 4))
87 | # resource(par = par, y = de$error[de$ppt==1], N_i = de$setsize_i[de$ppt==1])
88 |
89 | ##### TASK ----
90 | ### Use the functions above to fit the three models to each participant's data (N = 8)
91 | ### Which provides the best fit for each individual?
92 |
93 |
--------------------------------------------------------------------------------
/day2/bayesian-models/delayed-estimation/models/mixture_k.txt:
--------------------------------------------------------------------------------
1 |
2 | model{
3 | for (i in 1:n){
4 | y[i] ~ dvonmises(mu, kappa[i])
5 |
6 | kappa[i] <- (1/sd[i]^2)*z[i]
7 |
8 | z[i] ~ dbern(pm[i]) # 1 = response from memory, 0 = guess
9 |
10 | pm[i] <- min(k[i]/N[i], 1)
11 | k[i] <- max(kap[i], 0)
12 | kap[i] <- K_s[id[i]]
13 |
14 | sd[i] <- exp(SD_s[id[i], N_i[i]])
15 | }
16 | for (s in 1:S){
17 | K_s[s] ~ dnorm(K_mu, 1/K_sigma^2)
18 | for (ss in 1:N_n){
19 | SD_s[s, ss] ~ dnorm(SD_mu[ss], 1/SD_sigma^2)
20 | }
21 | }
22 |
23 | K_mu ~ dnorm(3, 1/4^2)
24 | for (ss in 1:N_n){
25 | SD_mu[ss] ~ dnorm(2, 1/10^2)
26 | }
27 |
28 | SD_sigma ~ dgamma(shape, rate)
29 | K_sigma ~ dgamma(shape, rate)
30 |
31 | shape <- 1.01005
32 | rate <- 0.1005012
33 | }
34 |
--------------------------------------------------------------------------------
/day2/bayesian-models/delayed-estimation/models/z-l-mixture.txt:
--------------------------------------------------------------------------------
1 |
2 | model{
3 | for (i in 1:n){
4 | y[i] ~ dvonmises(mu, kappa[i])
5 |
6 | kappa[i] <- (1/sd[i]^2)*z[i]
7 |
8 | z[i] ~ dbern(pm[i]) # 1 = response from memory, 0 = guess
9 | # see Oberauer (2016, JoV) https://www.ncbi.nlm.nih.gov/pubmed/28538991
10 |
11 | logit(pm[i]) <- Pm_s[id[i], N_i[i]]
12 | sd[i] <- exp(SD_s[id[i], N_i[i]])
13 | }
14 | for (s in 1:S){
15 | for (ss in 1:N_n){
16 | Pm_s[s, ss] ~ dnorm(Pm_mu[ss], 1/Pm_sigma^2)
17 | SD_s[s, ss] ~ dnorm(SD_mu[ss], 1/SD_sigma^2)
18 | }
19 | }
20 | for (ss in 1:N_n){
21 | Pm_mu[ss] ~ dnorm(0, 1/4^2)
22 | SD_mu[ss] ~ dnorm(2, 1/10^2)
23 | }
24 |
25 | SD_sigma ~ dgamma(shape, rate)
26 | Pm_sigma ~ dgamma(shape, rate)
27 |
28 | shape <- 1.01005
29 | rate <- 0.1005012
30 | }
31 |
--------------------------------------------------------------------------------
/day2/bayesian-models/delayed-estimation/models/z-l-resource.txt:
--------------------------------------------------------------------------------
1 |
2 | model{
3 | for (i in 1:n){
4 | y[i] ~ dvonmises(mu, kappa[i])
5 |
6 | kappa[i] <- (1/sd[i]^2)
7 |
8 | sd[i] <- exp(SD_s[id[i], N_i[i]])
9 | }
10 | for (s in 1:S){
11 | for (ss in 1:N_n){
12 | SD_s[s, ss] ~ dnorm(SD_mu[ss], 1/SD_sigma^2)
13 | }
14 | }
15 | for (ss in 1:N_n){
16 | SD_mu[ss] ~ dnorm(2, 1/10^2)
17 | }
18 |
19 | SD_sigma ~ dgamma(shape, rate)
20 |
21 | shape <- 1.01005
22 | rate <- 0.1005012
23 | }
24 |
--------------------------------------------------------------------------------
/day2/bayesian-models/jags-change-det/jags-rouder08.R:
--------------------------------------------------------------------------------
1 |
2 | library(rjags)
3 | library(coda)
4 |
5 | cd = read.table(file = "day2/bayesian-models/jags-change-det/rouder08-longdata-0.5.dat")
6 |
7 | head(cd)
8 |
9 | # ischange = was the trial a change trial? 1 = yes, 0 = no
10 | # respchange = the number of trials that the participant said 'change' to
11 | # ntrials = number of trials of that type for that participant in that condition
12 |
13 | # so
14 | # for ischange = 1 all the respchange responses are hits (ntrials - respchange = misses)
15 | # for ischange = 0 all the respchange responses are false-alarms (ntrials - respchange = correct rejections)
16 |
17 | cd_list = list(
18 | "y" = cd$respchange,
19 | "ischange" = cd$ischange,
20 | "ntrials" = cd$ntrials,
21 | "N" = cd$N,
22 | "n" = nrow(cd),
23 | "S" = length(unique(cd$ppt)),
24 | "id" = cd$ppt
25 | )
26 |
27 | # fixed k model
28 |
29 | k_model = "
30 | model {
31 | for (i in 1:n){
32 | y[i] ~ dbin(y.hat[i], ntrials[i])
33 | y.hat[i] <- max(0, min(1, P[i]))
34 |
35 | # p(resp = change)
36 | P[i] <- ifelse(ischange[i] == 1,
37 | a[i]*(d[i]+(1-d[i])*g[i]) + (1-a[i])*g[i], # p(hit)
38 | a[i]*(1-d[i])*g[i] + (1-a[i])*g[i]) # p(false-alarm)
39 |
40 | d[i] <- min(k[i]/N[i], 1)
41 |
42 | # model transformations of k, u, and a
43 | k[i] <- max(kappa[i], 0) # 'Mass-at-chance' transformation
44 | kappa[i] <- K_s[id[i]]
45 | logit(a[i]) <- A_s[id[i]] # logit transformation
46 | logit(g[i]) <- G_s[id[i]]
47 | }
48 | # sample participant parameters from population distributions
49 | # in this model the distributions are independent but we could
50 | # model correlations between the model parameters if they were
51 | # sampled from, e.g., a multivariate normal
52 | for (s in 1:S){
53 | K_s[s] ~ dnorm(K_mu, 1/K_sigma^2)
54 | A_s[s] ~ dnorm(A_mu, 1/A_sigma^2)
55 | G_s[s] ~ dnorm(G_mu, 1/G_sigma^2)
56 | }
57 |
58 | K_mu ~ dnorm(3, 1/4^2) # k is typically around 3 but the sd is broad on this scale
59 | A_mu ~ dnorm(2.2, 1/4^2)
60 | # ^ this is on the log odd scale. 3 implies the expectation that
61 | # participants will pay attention on ~ 90% of the trials
62 | # again the prior is broad on this scale
63 | G_mu ~ dnorm(0, 1/4^2) # 0 = 0.5 on the probability scale
64 |
65 | K_sigma ~ dgamma(shape, rate)
66 | A_sigma ~ dgamma(shape, rate)
67 | G_sigma ~ dgamma(shape, rate)
68 |
69 | shape <- 1.01005 # mode = .1, SD = 10 (v. vauge)
70 | rate <- 0.1005012
71 | }
72 | "
73 |
74 |
75 | # initialize the jags model
76 | k_jags <- jags.model(file = textConnection(k_model), data = cd_list, n.chains = 4, n.adapt = 1000)
77 |
78 | # warm up the chains
79 | update(k_jags, 1000)
80 |
81 | params = c("K_mu", "A_mu", "G_mu", "K_sigma", "A_sigma", "G_sigma") # we're only monitoring the population level parameters (but you could add the individual parameters: K_s, A_s, G_s)
82 | k_samples = coda.samples(model = k_jags, variable.names = params, n.iter = 2000)
83 |
84 | summary(k_samples)
85 |
86 | # check for convergence
87 | gelman.diag(k_samples)
88 |
89 | autocorr.diag(k_samples) # with many parameters it can be easier to look at a table of autocorrelations rather than plots
90 |
91 | effectiveSize(k_samples)
92 |
93 | # Variable k model
94 | # a version of the model with a different k parameter for each set size
95 |
96 | # to fit this we need to add some extra stuff to the data list
97 | cd_list$N_i = as.numeric(as.factor(cd_list$N)) # an index (1:3) for which set size were are working with on trial i
98 | cd_list$N_n = length(unique(cd_list$N)) # the number of different set sizes (3)
99 |
100 | vary_k_model = "
101 | model {
102 | for (i in 1:n){
103 | y[i] ~ dbin(y.hat[i], ntrials[i])
104 | y.hat[i] <- max(0, min(1, P[i]))
105 |
106 | # p(resp = change)
107 | P[i] <- ifelse(ischange[i] == 1,
108 | a[i]*(d[i]+(1-d[i])*g[i]) + (1-a[i])*g[i], # p(hit)
109 | a[i]*(1-d[i])*g[i] + (1-a[i])*g[i]) # p(false-alarm)
110 |
111 | d[i] <- min(k[i]/N[i], 1)
112 |
113 | # model transformations of k, u, and a
114 | k[i] <- max(kappa[i], 0) # 'Mass-at-chance' transformation
115 |
116 | # in this model individual capacities are stored in a matrix
117 | # row = individual, column = set size
118 | kappa[i] <- K_s[id[i], N_i[i]]
119 | logit(a[i]) <- A_s[id[i]] # logit transformation
120 | logit(g[i]) <- G_s[id[i]]
121 | }
122 |
123 | for (s in 1:S){
124 | for (ss in 1:N_n){
125 | # sample individual Ks from a normal with shared variance
126 | # but different mean for each set size
127 | K_s[s, ss] ~ dnorm(K_mu[ss], 1/K_sigma^2)
128 | }
129 | A_s[s] ~ dnorm(A_mu, 1/A_sigma^2)
130 | G_s[s] ~ dnorm(G_mu, 1/G_sigma^2)
131 | }
132 |
133 | for (ss in 1:N_n){
134 | K_mu[ss] ~ dnorm(3, 1/4^2)
135 | }
136 |
137 | A_mu ~ dnorm(2.2, 1/4^2)
138 | G_mu ~ dnorm(0, 1/4^2)
139 |
140 | K_sigma ~ dgamma(shape, rate)
141 | A_sigma ~ dgamma(shape, rate)
142 | G_sigma ~ dgamma(shape, rate)
143 |
144 | shape <- 1.01005 # mode = .1, SD = 10 (v. vauge)
145 | rate <- 0.1005012
146 | }
147 | "
148 |
149 | # initialize the jags model
150 | vary_k_jags <- jags.model(file = textConnection(vary_k_model), data = cd_list, n.chains = 4, n.adapt = 1000)
151 |
152 | # warm up the chains
153 | update(vary_k_jags, 1000)
154 |
155 | params = c("K_mu", "A_mu", "G_mu", "K_sigma", "A_sigma", "G_sigma") # jags will monitor all K_mu (K_mu[1], K_mu[2], K_mu[3])
156 | vary_k_samples = coda.samples(model = vary_k_jags, variable.names = params, n.iter = 1000)
157 |
158 | summary(vary_k_samples) # the quantities for K_mu[1] look weird...
159 |
160 | gelman.diag(vary_k_samples)
161 |
162 | plot(vary_k_samples[,"K_mu[1]"])
163 | # the mean for set size = 2 has not converged - why do you think this is?
164 |
165 | # re-fitting with more samples helps...
166 | vary_k_samples = coda.samples(model = vary_k_jags, variable.names = params, n.iter = 10000)
167 | gelman.diag(vary_k_samples)
168 |
169 | plot(vary_k_samples[,"K_mu[1]"])
170 | # but this model probably should be reparameterized. If you're interested in how this could be done, please ask one of us
171 |
172 |
173 | #### TASK -----
174 |
175 | # write a version of the fixed k model that estimates a different
176 | # grand mean guessing parameter for each set size condition
177 | # (i.e. G_mu[1], G_mu[2], G_mu[3])
178 |
179 | # this model should only estimate one grand mean K (K_mu)
180 | # so you can use the k_model as a guide (the vary_k_model will be helpful tooo)
181 |
182 | vary_g_model = "
183 | model {
184 | for (i in 1:n){
185 | y[i] ~ dbin(y.hat[i], ntrials[i])
186 | y.hat[i] <- max(0, min(1, P[i]))
187 |
188 | # p(resp = change)
189 | P[i] <- ifelse(ischange[i] == 1,
190 | a[i]*(d[i]+(1-d[i])*g[i]) + (1-a[i])*g[i], # p(hit)
191 | a[i]*(1-d[i])*g[i] + (1-a[i])*g[i]) # p(false-alarm)
192 |
193 | d[i] <- min(k[i]/N[i], 1)
194 |
195 | # model transformations of k, u, and a
196 | k[i] <- max(kappa[i], 0) # 'Mass-at-chance' transformation
197 |
198 | # in this model individual capacities are stored in a matrix
199 | # row = individual, column = set size
200 | kappa[i] <- K_s[id[i]]
201 | logit(a[i]) <- A_s[id[i]] # logit transformation
202 | logit(g[i]) <- G_s[id[i], N_i[i]]
203 | }
204 |
205 | for (s in 1:S){
206 | for (ss in 1:N_n){
207 | G_s[s, ss] ~ dnorm(G_mu[ss], 1/G_sigma^2)
208 | }
209 | A_s[s] ~ dnorm(A_mu, 1/A_sigma^2)
210 | K_s[s] ~ dnorm(K_mu, 1/K_sigma^2)
211 | }
212 |
213 | for (ss in 1:N_n){
214 | G_mu[ss] ~ dnorm(0, 1/4^2)
215 | }
216 |
217 | A_mu ~ dnorm(2.2, 1/4^2)
218 | K_mu ~ dnorm(0, 1/4^2)
219 |
220 | K_sigma ~ dgamma(shape, rate)
221 | A_sigma ~ dgamma(shape, rate)
222 | G_sigma ~ dgamma(shape, rate)
223 |
224 | shape <- 1.01005 # mode = .1, SD = 10 (v. vauge)
225 | rate <- 0.1005012
226 | }
227 | "
228 |
229 | # initialize the jags model
230 | vary_g_jags <- jags.model(file = textConnection(vary_g_model), data = cd_list, n.chains = 4, n.adapt = 1000)
231 |
232 | # warm up the chains
233 | update(vary_g_jags, 1000)
234 |
235 | params = c("K_mu", "A_mu", "G_mu", "K_sigma", "A_sigma", "G_sigma")
236 | vary_g_samples = coda.samples(model = vary_g_jags, variable.names = params, n.iter = 1000)
237 |
238 | summary(vary_g_samples)
239 |
240 | gelman.diag(vary_g_samples)
241 |
242 | par(mfrow=c(3,2))
243 | plot(vary_g_samples[,"G_mu[1]"], auto.layout = F)
244 | plot(vary_g_samples[,"G_mu[2]"], auto.layout = F)
245 | plot(vary_g_samples[,"G_mu[3]"], auto.layout = F)
246 | par(mfrow=c(1,1))
247 |
248 | DIC_vary_g_jags = dic.samples(model = vary_g_jags, n.iter = 1000, type = "pD")
249 |
250 |
251 | ### Comparing the fixed and varying K models with DIC ----
252 | # DIC is like AIC and BIC but for hierarchical models https://en.wikipedia.org/wiki/Deviance_information_criterion
253 | # it essentially penalizes the model for the 'effective' number of parameters it has (how this is estimated is tricky. You can't just could the number of paramaters in a hierarchical model)
254 |
255 | # we can get it via the dic.samples function
256 | DIC_k_jags = dic.samples(model = k_jags, n.iter = 1000, type = "pD")
257 | DIC_vary_k_jags = dic.samples(model = vary_k_jags, n.iter = 1000, type = "pD")
258 |
259 | DIC_k_jags
260 | DIC_vary_k_jags # we're looking at penalized deviance (DIC)
261 |
262 | diffdic(DIC_k_jags, DIC_vary_k_jags)
263 |
264 | # DIC is smaller for the fixed k version
265 |
266 | # compare the vary g and one g models
267 | diffdic(DIC_k_jags, DIC_vary_g_jags)
268 |
269 | ### Looking at parameters on their natural scale
270 |
271 | # to extract the samples to a matrix
272 | k_samples_mat = as.matrix(k_samples)
273 |
274 | hist(k_samples_mat[,"K_mu"])
275 | hist(plogis(k_samples_mat[,"A_mu"]))
276 | hist(plogis(k_samples_mat[,"G_mu"]))
277 |
278 | ### Posterior predictive samples ----
279 | # we need a function to
280 | # turn the parameters into new data
281 |
282 | k_ppsamples = function(mat, N, trials = 30){
283 | # takes the posterior samples and produces posterior predictive samples for
284 | # a particular set size
285 |
286 | # sample new ks from the population distribution
287 | kappa = rnorm(nrow(mat), mean = mat[,'K_mu'], sd = mat[,'K_sigma'])
288 | k = ifelse(kappa > 0, kappa, 0) # this is the same as k = max(kappa, 0)
289 |
290 | d = k/N
291 | d = ifelse(d > 1, 1, d) # this is the same as d = min(k/N, 1)
292 |
293 | # sample new a and gs from their population distributions
294 | logita = rnorm(nrow(mat), mean = mat[,'A_mu'], sd = mat[,'A_sigma'])
295 | a = plogis(logita) # transform this parameter to its natural scale [0,1]
296 |
297 | logitg = rnorm(nrow(mat), mean = mat[,'G_mu'], sd = mat[,'G_sigma'])
298 | g = plogis(logita)
299 |
300 | h = a*(d + (1-d)*g) + (1 - a)*g
301 | f = a*(1 - d)*g + (1 - a)*g
302 |
303 | # simulate new data from a binomial
304 | h_rep = rbinom(n = length(h), size = trials, prob = h)/trials
305 | f_rep = rbinom(n = length(f), size = trials, prob = f)/trials
306 |
307 | return(cbind(f = f_rep, h = h_rep))
308 | }
309 |
310 | # these are the posterior predictive false-alarm and hit rates for different set sizes
311 | pp_samples_N2 = k_ppsamples(mat = k_samples_mat, N = 2)
312 | pp_samples_N5 = k_ppsamples(mat = k_samples_mat, N = 5)
313 | pp_samples_N8 = k_ppsamples(mat = k_samples_mat, N = 8)
314 |
315 | # let's look at quantiles
316 | apply(pp_samples_N2, 2, FUN = quantile, prob=c(.025, .975))
317 | apply(pp_samples_N5, 2, FUN = quantile, prob=c(.025, .975))
318 | apply(pp_samples_N8, 2, FUN = quantile, prob=c(.025, .975))
319 |
320 | ### HARD task ----
321 | ## try ploting the data and the posterior predictive samples (this could be a histogram of observed vs predicted hit/false-alarm rates for each set size - there are other plots you could consider, though)
322 | # observed hit and false alarm rates can be found by
323 | cd$rate = with(cd, respchange/ntrials)
324 |
325 |
326 |
--------------------------------------------------------------------------------
/day2/bayesian-models/jags-change-det/rouder08-longdata-0.5.dat:
--------------------------------------------------------------------------------
1 | "ppt" "prch" "N" "ischange" "respchange" "ntrials"
2 | "7" 1 0.5 2 0 1 30
3 | "8" 1 0.5 2 1 29 30
4 | "9" 1 0.5 5 0 7 30
5 | "10" 1 0.5 5 1 25 30
6 | "11" 1 0.5 8 0 11 30
7 | "12" 1 0.5 8 1 24 30
8 | "25" 2 0.5 2 0 0 30
9 | "26" 2 0.5 2 1 28 30
10 | "27" 2 0.5 5 0 6 30
11 | "28" 2 0.5 5 1 25 30
12 | "29" 2 0.5 8 0 9 30
13 | "30" 2 0.5 8 1 25 30
14 | "43" 3 0.5 2 0 7 30
15 | "44" 3 0.5 2 1 27 30
16 | "45" 3 0.5 5 0 10 30
17 | "46" 3 0.5 5 1 23 30
18 | "47" 3 0.5 8 0 19 30
19 | "48" 3 0.5 8 1 19 30
20 | "61" 4 0.5 2 0 0 30
21 | "62" 4 0.5 2 1 30 30
22 | "63" 4 0.5 5 0 7 30
23 | "64" 4 0.5 5 1 27 30
24 | "65" 4 0.5 8 0 15 30
25 | "66" 4 0.5 8 1 26 30
26 | "79" 5 0.5 2 0 0 30
27 | "80" 5 0.5 2 1 30 30
28 | "81" 5 0.5 5 0 4 30
29 | "82" 5 0.5 5 1 27 30
30 | "83" 5 0.5 8 0 6 30
31 | "84" 5 0.5 8 1 24 30
32 | "97" 6 0.5 2 0 0 30
33 | "98" 6 0.5 2 1 29 30
34 | "99" 6 0.5 5 0 7 30
35 | "100" 6 0.5 5 1 23 30
36 | "101" 6 0.5 8 0 5 30
37 | "102" 6 0.5 8 1 19 30
38 | "115" 7 0.5 2 0 3 30
39 | "116" 7 0.5 2 1 29 30
40 | "117" 7 0.5 5 0 9 30
41 | "118" 7 0.5 5 1 23 30
42 | "119" 7 0.5 8 0 6 30
43 | "120" 7 0.5 8 1 15 30
44 | "133" 8 0.5 2 0 5 30
45 | "134" 8 0.5 2 1 28 30
46 | "135" 8 0.5 5 0 12 30
47 | "136" 8 0.5 5 1 29 30
48 | "137" 8 0.5 8 0 18 30
49 | "138" 8 0.5 8 1 19 30
50 | "151" 9 0.5 2 0 2 30
51 | "152" 9 0.5 2 1 30 30
52 | "153" 9 0.5 5 0 11 30
53 | "154" 9 0.5 5 1 27 30
54 | "155" 9 0.5 8 0 13 30
55 | "156" 9 0.5 8 1 25 30
56 | "169" 10 0.5 2 0 0 30
57 | "170" 10 0.5 2 1 29 30
58 | "171" 10 0.5 5 0 11 30
59 | "172" 10 0.5 5 1 29 30
60 | "173" 10 0.5 8 0 19 30
61 | "174" 10 0.5 8 1 26 30
62 | "187" 11 0.5 2 0 5 30
63 | "188" 11 0.5 2 1 30 30
64 | "189" 11 0.5 5 0 7 30
65 | "190" 11 0.5 5 1 25 30
66 | "191" 11 0.5 8 0 11 30
67 | "192" 11 0.5 8 1 23 30
68 | "205" 12 0.5 2 0 2 30
69 | "206" 12 0.5 2 1 28 30
70 | "207" 12 0.5 5 0 19 30
71 | "208" 12 0.5 5 1 25 30
72 | "209" 12 0.5 8 0 13 30
73 | "210" 12 0.5 8 1 20 30
74 | "223" 13 0.5 2 0 1 30
75 | "224" 13 0.5 2 1 30 30
76 | "225" 13 0.5 5 0 6 30
77 | "226" 13 0.5 5 1 27 30
78 | "227" 13 0.5 8 0 7 30
79 | "228" 13 0.5 8 1 23 30
80 | "241" 14 0.5 2 0 0 30
81 | "242" 14 0.5 2 1 30 30
82 | "243" 14 0.5 5 0 4 30
83 | "244" 14 0.5 5 1 27 30
84 | "245" 14 0.5 8 0 13 30
85 | "246" 14 0.5 8 1 26 30
86 | "259" 15 0.5 2 0 3 30
87 | "260" 15 0.5 2 1 28 30
88 | "261" 15 0.5 5 0 4 30
89 | "262" 15 0.5 5 1 24 30
90 | "263" 15 0.5 8 0 10 30
91 | "264" 15 0.5 8 1 27 30
92 | "277" 16 0.5 2 0 0 30
93 | "278" 16 0.5 2 1 30 30
94 | "279" 16 0.5 5 0 7 30
95 | "280" 16 0.5 5 1 25 30
96 | "281" 16 0.5 8 0 10 30
97 | "282" 16 0.5 8 1 18 30
98 | "295" 17 0.5 2 0 2 30
99 | "296" 17 0.5 2 1 30 30
100 | "297" 17 0.5 5 0 6 30
101 | "298" 17 0.5 5 1 29 30
102 | "299" 17 0.5 8 0 10 30
103 | "300" 17 0.5 8 1 28 30
104 | "313" 18 0.5 2 0 2 30
105 | "314" 18 0.5 2 1 29 30
106 | "315" 18 0.5 5 0 12 30
107 | "316" 18 0.5 5 1 23 30
108 | "317" 18 0.5 8 0 14 30
109 | "318" 18 0.5 8 1 21 30
110 | "331" 19 0.5 2 0 9 30
111 | "332" 19 0.5 2 1 26 30
112 | "333" 19 0.5 5 0 12 30
113 | "334" 19 0.5 5 1 27 30
114 | "335" 19 0.5 8 0 17 30
115 | "336" 19 0.5 8 1 25 30
116 | "349" 20 0.5 2 0 0 30
117 | "350" 20 0.5 2 1 30 30
118 | "351" 20 0.5 5 0 3 30
119 | "352" 20 0.5 5 1 29 30
120 | "353" 20 0.5 8 0 5 30
121 | "354" 20 0.5 8 1 29 30
122 | "367" 21 0.5 2 0 1 30
123 | "368" 21 0.5 2 1 29 30
124 | "369" 21 0.5 5 0 7 30
125 | "370" 21 0.5 5 1 27 30
126 | "371" 21 0.5 8 0 12 30
127 | "372" 21 0.5 8 1 24 30
128 | "385" 22 0.5 2 0 2 30
129 | "386" 22 0.5 2 1 30 30
130 | "387" 22 0.5 5 0 14 30
131 | "388" 22 0.5 5 1 20 30
132 | "389" 22 0.5 8 0 15 30
133 | "390" 22 0.5 8 1 21 30
134 | "403" 23 0.5 2 0 2 30
135 | "404" 23 0.5 2 1 27 30
136 | "405" 23 0.5 5 0 8 30
137 | "406" 23 0.5 5 1 27 30
138 | "407" 23 0.5 8 0 9 30
139 | "408" 23 0.5 8 1 22 30
140 |
--------------------------------------------------------------------------------
/day2/bayesian-models/jags-change-det/rouder08-longdata-full.dat:
--------------------------------------------------------------------------------
1 | "ppt" "prch" "N" "ischange" "respchange" "ntrials"
2 | "1" 1 0.3 2 0 1 42
3 | "2" 1 0.3 2 1 17 18
4 | "3" 1 0.3 5 0 11 42
5 | "4" 1 0.3 5 1 16 18
6 | "5" 1 0.3 8 0 6 42
7 | "6" 1 0.3 8 1 12 18
8 | "7" 1 0.5 2 0 1 30
9 | "8" 1 0.5 2 1 29 30
10 | "9" 1 0.5 5 0 7 30
11 | "10" 1 0.5 5 1 25 30
12 | "11" 1 0.5 8 0 11 30
13 | "12" 1 0.5 8 1 24 30
14 | "13" 1 0.7 2 0 0 18
15 | "14" 1 0.7 2 1 41 42
16 | "15" 1 0.7 5 0 3 18
17 | "16" 1 0.7 5 1 40 42
18 | "17" 1 0.7 8 0 8 18
19 | "18" 1 0.7 8 1 35 42
20 | "19" 2 0.3 2 0 2 42
21 | "20" 2 0.3 2 1 17 18
22 | "21" 2 0.3 5 0 6 42
23 | "22" 2 0.3 5 1 14 18
24 | "23" 2 0.3 8 0 10 42
25 | "24" 2 0.3 8 1 12 18
26 | "25" 2 0.5 2 0 0 30
27 | "26" 2 0.5 2 1 28 30
28 | "27" 2 0.5 5 0 6 30
29 | "28" 2 0.5 5 1 25 30
30 | "29" 2 0.5 8 0 9 30
31 | "30" 2 0.5 8 1 25 30
32 | "31" 2 0.7 2 0 0 18
33 | "32" 2 0.7 2 1 40 42
34 | "33" 2 0.7 5 0 3 18
35 | "34" 2 0.7 5 1 38 42
36 | "35" 2 0.7 8 0 6 18
37 | "36" 2 0.7 8 1 37 42
38 | "37" 3 0.3 2 0 1 42
39 | "38" 3 0.3 2 1 13 18
40 | "39" 3 0.3 5 0 8 42
41 | "40" 3 0.3 5 1 11 18
42 | "41" 3 0.3 8 0 13 42
43 | "42" 3 0.3 8 1 12 18
44 | "43" 3 0.5 2 0 7 30
45 | "44" 3 0.5 2 1 27 30
46 | "45" 3 0.5 5 0 10 30
47 | "46" 3 0.5 5 1 23 30
48 | "47" 3 0.5 8 0 19 30
49 | "48" 3 0.5 8 1 19 30
50 | "49" 3 0.7 2 0 6 18
51 | "50" 3 0.7 2 1 42 42
52 | "51" 3 0.7 5 0 15 18
53 | "52" 3 0.7 5 1 41 42
54 | "53" 3 0.7 8 0 12 18
55 | "54" 3 0.7 8 1 41 42
56 | "55" 4 0.3 2 0 1 42
57 | "56" 4 0.3 2 1 18 18
58 | "57" 4 0.3 5 0 4 42
59 | "58" 4 0.3 5 1 18 18
60 | "59" 4 0.3 8 0 8 42
61 | "60" 4 0.3 8 1 12 18
62 | "61" 4 0.5 2 0 0 30
63 | "62" 4 0.5 2 1 30 30
64 | "63" 4 0.5 5 0 7 30
65 | "64" 4 0.5 5 1 27 30
66 | "65" 4 0.5 8 0 15 30
67 | "66" 4 0.5 8 1 26 30
68 | "67" 4 0.7 2 0 0 18
69 | "68" 4 0.7 2 1 42 42
70 | "69" 4 0.7 5 0 6 18
71 | "70" 4 0.7 5 1 39 42
72 | "71" 4 0.7 8 0 9 18
73 | "72" 4 0.7 8 1 41 42
74 | "73" 5 0.3 2 0 0 42
75 | "74" 5 0.3 2 1 17 18
76 | "75" 5 0.3 5 0 3 42
77 | "76" 5 0.3 5 1 16 18
78 | "77" 5 0.3 8 0 8 42
79 | "78" 5 0.3 8 1 16 18
80 | "79" 5 0.5 2 0 0 30
81 | "80" 5 0.5 2 1 30 30
82 | "81" 5 0.5 5 0 4 30
83 | "82" 5 0.5 5 1 27 30
84 | "83" 5 0.5 8 0 6 30
85 | "84" 5 0.5 8 1 24 30
86 | "85" 5 0.7 2 0 0 18
87 | "86" 5 0.7 2 1 40 42
88 | "87" 5 0.7 5 0 7 18
89 | "88" 5 0.7 5 1 40 42
90 | "89" 5 0.7 8 0 6 18
91 | "90" 5 0.7 8 1 34 42
92 | "91" 6 0.3 2 0 0 42
93 | "92" 6 0.3 2 1 18 18
94 | "93" 6 0.3 5 0 3 42
95 | "94" 6 0.3 5 1 14 18
96 | "95" 6 0.3 8 0 8 42
97 | "96" 6 0.3 8 1 10 18
98 | "97" 6 0.5 2 0 0 30
99 | "98" 6 0.5 2 1 29 30
100 | "99" 6 0.5 5 0 7 30
101 | "100" 6 0.5 5 1 23 30
102 | "101" 6 0.5 8 0 5 30
103 | "102" 6 0.5 8 1 19 30
104 | "103" 6 0.7 2 0 1 18
105 | "104" 6 0.7 2 1 42 42
106 | "105" 6 0.7 5 0 3 18
107 | "106" 6 0.7 5 1 38 42
108 | "107" 6 0.7 8 0 10 18
109 | "108" 6 0.7 8 1 33 42
110 | "109" 7 0.3 2 0 3 42
111 | "110" 7 0.3 2 1 17 18
112 | "111" 7 0.3 5 0 9 42
113 | "112" 7 0.3 5 1 10 18
114 | "113" 7 0.3 8 0 13 42
115 | "114" 7 0.3 8 1 9 18
116 | "115" 7 0.5 2 0 3 30
117 | "116" 7 0.5 2 1 29 30
118 | "117" 7 0.5 5 0 9 30
119 | "118" 7 0.5 5 1 23 30
120 | "119" 7 0.5 8 0 6 30
121 | "120" 7 0.5 8 1 15 30
122 | "121" 7 0.7 2 0 5 18
123 | "122" 7 0.7 2 1 40 42
124 | "123" 7 0.7 5 0 6 18
125 | "124" 7 0.7 5 1 39 42
126 | "125" 7 0.7 8 0 12 18
127 | "126" 7 0.7 8 1 36 42
128 | "127" 8 0.3 2 0 11 42
129 | "128" 8 0.3 2 1 16 18
130 | "129" 8 0.3 5 0 13 42
131 | "130" 8 0.3 5 1 10 18
132 | "131" 8 0.3 8 0 22 42
133 | "132" 8 0.3 8 1 10 18
134 | "133" 8 0.5 2 0 5 30
135 | "134" 8 0.5 2 1 28 30
136 | "135" 8 0.5 5 0 12 30
137 | "136" 8 0.5 5 1 29 30
138 | "137" 8 0.5 8 0 18 30
139 | "138" 8 0.5 8 1 19 30
140 | "139" 8 0.7 2 0 6 18
141 | "140" 8 0.7 2 1 36 42
142 | "141" 8 0.7 5 0 9 18
143 | "142" 8 0.7 5 1 36 42
144 | "143" 8 0.7 8 0 15 18
145 | "144" 8 0.7 8 1 34 42
146 | "145" 9 0.3 2 0 5 42
147 | "146" 9 0.3 2 1 15 18
148 | "147" 9 0.3 5 0 8 42
149 | "148" 9 0.3 5 1 13 18
150 | "149" 9 0.3 8 0 8 42
151 | "150" 9 0.3 8 1 6 18
152 | "151" 9 0.5 2 0 2 30
153 | "152" 9 0.5 2 1 30 30
154 | "153" 9 0.5 5 0 11 30
155 | "154" 9 0.5 5 1 27 30
156 | "155" 9 0.5 8 0 13 30
157 | "156" 9 0.5 8 1 25 30
158 | "157" 9 0.7 2 0 1 18
159 | "158" 9 0.7 2 1 41 42
160 | "159" 9 0.7 5 0 6 18
161 | "160" 9 0.7 5 1 40 42
162 | "161" 9 0.7 8 0 12 18
163 | "162" 9 0.7 8 1 39 42
164 | "163" 10 0.3 2 0 0 42
165 | "164" 10 0.3 2 1 17 18
166 | "165" 10 0.3 5 0 10 42
167 | "166" 10 0.3 5 1 17 18
168 | "167" 10 0.3 8 0 21 42
169 | "168" 10 0.3 8 1 15 18
170 | "169" 10 0.5 2 0 0 30
171 | "170" 10 0.5 2 1 29 30
172 | "171" 10 0.5 5 0 11 30
173 | "172" 10 0.5 5 1 29 30
174 | "173" 10 0.5 8 0 19 30
175 | "174" 10 0.5 8 1 26 30
176 | "175" 10 0.7 2 0 1 18
177 | "176" 10 0.7 2 1 40 42
178 | "177" 10 0.7 5 0 4 18
179 | "178" 10 0.7 5 1 40 42
180 | "179" 10 0.7 8 0 13 18
181 | "180" 10 0.7 8 1 39 42
182 | "181" 11 0.3 2 0 2 42
183 | "182" 11 0.3 2 1 17 18
184 | "183" 11 0.3 5 0 13 42
185 | "184" 11 0.3 5 1 16 18
186 | "185" 11 0.3 8 0 14 42
187 | "186" 11 0.3 8 1 12 18
188 | "187" 11 0.5 2 0 5 30
189 | "188" 11 0.5 2 1 30 30
190 | "189" 11 0.5 5 0 7 30
191 | "190" 11 0.5 5 1 25 30
192 | "191" 11 0.5 8 0 11 30
193 | "192" 11 0.5 8 1 23 30
194 | "193" 11 0.7 2 0 0 18
195 | "194" 11 0.7 2 1 42 42
196 | "195" 11 0.7 5 0 7 18
197 | "196" 11 0.7 5 1 38 42
198 | "197" 11 0.7 8 0 9 18
199 | "198" 11 0.7 8 1 37 42
200 | "199" 12 0.3 2 0 2 42
201 | "200" 12 0.3 2 1 16 18
202 | "201" 12 0.3 5 0 8 42
203 | "202" 12 0.3 5 1 14 18
204 | "203" 12 0.3 8 0 12 42
205 | "204" 12 0.3 8 1 13 18
206 | "205" 12 0.5 2 0 2 30
207 | "206" 12 0.5 2 1 28 30
208 | "207" 12 0.5 5 0 19 30
209 | "208" 12 0.5 5 1 25 30
210 | "209" 12 0.5 8 0 13 30
211 | "210" 12 0.5 8 1 20 30
212 | "211" 12 0.7 2 0 6 18
213 | "212" 12 0.7 2 1 39 42
214 | "213" 12 0.7 5 0 11 18
215 | "214" 12 0.7 5 1 37 42
216 | "215" 12 0.7 8 0 13 18
217 | "216" 12 0.7 8 1 38 42
218 | "217" 13 0.3 2 0 0 42
219 | "218" 13 0.3 2 1 18 18
220 | "219" 13 0.3 5 0 7 42
221 | "220" 13 0.3 5 1 15 18
222 | "221" 13 0.3 8 0 11 42
223 | "222" 13 0.3 8 1 13 18
224 | "223" 13 0.5 2 0 1 30
225 | "224" 13 0.5 2 1 30 30
226 | "225" 13 0.5 5 0 6 30
227 | "226" 13 0.5 5 1 27 30
228 | "227" 13 0.5 8 0 7 30
229 | "228" 13 0.5 8 1 23 30
230 | "229" 13 0.7 2 0 0 18
231 | "230" 13 0.7 2 1 42 42
232 | "231" 13 0.7 5 0 1 18
233 | "232" 13 0.7 5 1 40 42
234 | "233" 13 0.7 8 0 3 18
235 | "234" 13 0.7 8 1 39 42
236 | "235" 14 0.3 2 0 0 42
237 | "236" 14 0.3 2 1 17 18
238 | "237" 14 0.3 5 0 6 42
239 | "238" 14 0.3 5 1 16 18
240 | "239" 14 0.3 8 0 18 42
241 | "240" 14 0.3 8 1 12 18
242 | "241" 14 0.5 2 0 0 30
243 | "242" 14 0.5 2 1 30 30
244 | "243" 14 0.5 5 0 4 30
245 | "244" 14 0.5 5 1 27 30
246 | "245" 14 0.5 8 0 13 30
247 | "246" 14 0.5 8 1 26 30
248 | "247" 14 0.7 2 0 1 18
249 | "248" 14 0.7 2 1 41 42
250 | "249" 14 0.7 5 0 5 18
251 | "250" 14 0.7 5 1 40 42
252 | "251" 14 0.7 8 0 8 18
253 | "252" 14 0.7 8 1 40 42
254 | "253" 15 0.3 2 0 2 42
255 | "254" 15 0.3 2 1 16 18
256 | "255" 15 0.3 5 0 3 42
257 | "256" 15 0.3 5 1 16 18
258 | "257" 15 0.3 8 0 8 42
259 | "258" 15 0.3 8 1 12 18
260 | "259" 15 0.5 2 0 3 30
261 | "260" 15 0.5 2 1 28 30
262 | "261" 15 0.5 5 0 4 30
263 | "262" 15 0.5 5 1 24 30
264 | "263" 15 0.5 8 0 10 30
265 | "264" 15 0.5 8 1 27 30
266 | "265" 15 0.7 2 0 2 18
267 | "266" 15 0.7 2 1 41 42
268 | "267" 15 0.7 5 0 2 18
269 | "268" 15 0.7 5 1 40 42
270 | "269" 15 0.7 8 0 7 18
271 | "270" 15 0.7 8 1 39 42
272 | "271" 16 0.3 2 0 0 42
273 | "272" 16 0.3 2 1 17 18
274 | "273" 16 0.3 5 0 6 42
275 | "274" 16 0.3 5 1 16 18
276 | "275" 16 0.3 8 0 8 42
277 | "276" 16 0.3 8 1 9 18
278 | "277" 16 0.5 2 0 0 30
279 | "278" 16 0.5 2 1 30 30
280 | "279" 16 0.5 5 0 7 30
281 | "280" 16 0.5 5 1 25 30
282 | "281" 16 0.5 8 0 10 30
283 | "282" 16 0.5 8 1 18 30
284 | "283" 16 0.7 2 0 1 18
285 | "284" 16 0.7 2 1 41 42
286 | "285" 16 0.7 5 0 4 18
287 | "286" 16 0.7 5 1 37 42
288 | "287" 16 0.7 8 0 11 18
289 | "288" 16 0.7 8 1 34 42
290 | "289" 17 0.3 2 0 0 42
291 | "290" 17 0.3 2 1 18 18
292 | "291" 17 0.3 5 0 1 42
293 | "292" 17 0.3 5 1 16 18
294 | "293" 17 0.3 8 0 12 42
295 | "294" 17 0.3 8 1 16 18
296 | "295" 17 0.5 2 0 2 30
297 | "296" 17 0.5 2 1 30 30
298 | "297" 17 0.5 5 0 6 30
299 | "298" 17 0.5 5 1 29 30
300 | "299" 17 0.5 8 0 10 30
301 | "300" 17 0.5 8 1 28 30
302 | "301" 17 0.7 2 0 1 18
303 | "302" 17 0.7 2 1 42 42
304 | "303" 17 0.7 5 0 0 18
305 | "304" 17 0.7 5 1 41 42
306 | "305" 17 0.7 8 0 3 18
307 | "306" 17 0.7 8 1 37 42
308 | "307" 18 0.3 2 0 2 42
309 | "308" 18 0.3 2 1 17 18
310 | "309" 18 0.3 5 0 18 42
311 | "310" 18 0.3 5 1 11 18
312 | "311" 18 0.3 8 0 18 42
313 | "312" 18 0.3 8 1 6 18
314 | "313" 18 0.5 2 0 2 30
315 | "314" 18 0.5 2 1 29 30
316 | "315" 18 0.5 5 0 12 30
317 | "316" 18 0.5 5 1 23 30
318 | "317" 18 0.5 8 0 14 30
319 | "318" 18 0.5 8 1 21 30
320 | "319" 18 0.7 2 0 0 18
321 | "320" 18 0.7 2 1 41 42
322 | "321" 18 0.7 5 0 12 18
323 | "322" 18 0.7 5 1 32 42
324 | "323" 18 0.7 8 0 9 18
325 | "324" 18 0.7 8 1 32 42
326 | "325" 19 0.3 2 0 14 42
327 | "326" 19 0.3 2 1 12 18
328 | "327" 19 0.3 5 0 17 42
329 | "328" 19 0.3 5 1 12 18
330 | "329" 19 0.3 8 0 24 42
331 | "330" 19 0.3 8 1 10 18
332 | "331" 19 0.5 2 0 9 30
333 | "332" 19 0.5 2 1 26 30
334 | "333" 19 0.5 5 0 12 30
335 | "334" 19 0.5 5 1 27 30
336 | "335" 19 0.5 8 0 17 30
337 | "336" 19 0.5 8 1 25 30
338 | "337" 19 0.7 2 0 5 18
339 | "338" 19 0.7 2 1 41 42
340 | "339" 19 0.7 5 0 12 18
341 | "340" 19 0.7 5 1 36 42
342 | "341" 19 0.7 8 0 14 18
343 | "342" 19 0.7 8 1 37 42
344 | "343" 20 0.3 2 0 0 42
345 | "344" 20 0.3 2 1 17 18
346 | "345" 20 0.3 5 0 5 42
347 | "346" 20 0.3 5 1 18 18
348 | "347" 20 0.3 8 0 10 42
349 | "348" 20 0.3 8 1 18 18
350 | "349" 20 0.5 2 0 0 30
351 | "350" 20 0.5 2 1 30 30
352 | "351" 20 0.5 5 0 3 30
353 | "352" 20 0.5 5 1 29 30
354 | "353" 20 0.5 8 0 5 30
355 | "354" 20 0.5 8 1 29 30
356 | "355" 20 0.7 2 0 3 18
357 | "356" 20 0.7 2 1 42 42
358 | "357" 20 0.7 5 0 3 18
359 | "358" 20 0.7 5 1 41 42
360 | "359" 20 0.7 8 0 5 18
361 | "360" 20 0.7 8 1 35 42
362 | "361" 21 0.3 2 0 2 42
363 | "362" 21 0.3 2 1 17 18
364 | "363" 21 0.3 5 0 7 42
365 | "364" 21 0.3 5 1 17 18
366 | "365" 21 0.3 8 0 16 42
367 | "366" 21 0.3 8 1 13 18
368 | "367" 21 0.5 2 0 1 30
369 | "368" 21 0.5 2 1 29 30
370 | "369" 21 0.5 5 0 7 30
371 | "370" 21 0.5 5 1 27 30
372 | "371" 21 0.5 8 0 12 30
373 | "372" 21 0.5 8 1 24 30
374 | "373" 21 0.7 2 0 0 18
375 | "374" 21 0.7 2 1 40 42
376 | "375" 21 0.7 5 0 7 18
377 | "376" 21 0.7 5 1 39 42
378 | "377" 21 0.7 8 0 6 18
379 | "378" 21 0.7 8 1 34 42
380 | "379" 22 0.3 2 0 0 42
381 | "380" 22 0.3 2 1 17 18
382 | "381" 22 0.3 5 0 16 42
383 | "382" 22 0.3 5 1 13 18
384 | "383" 22 0.3 8 0 12 42
385 | "384" 22 0.3 8 1 3 18
386 | "385" 22 0.5 2 0 2 30
387 | "386" 22 0.5 2 1 30 30
388 | "387" 22 0.5 5 0 14 30
389 | "388" 22 0.5 5 1 20 30
390 | "389" 22 0.5 8 0 15 30
391 | "390" 22 0.5 8 1 21 30
392 | "391" 22 0.7 2 0 3 18
393 | "392" 22 0.7 2 1 41 42
394 | "393" 22 0.7 5 0 8 18
395 | "394" 22 0.7 5 1 36 42
396 | "395" 22 0.7 8 0 11 18
397 | "396" 22 0.7 8 1 34 42
398 | "397" 23 0.3 2 0 2 42
399 | "398" 23 0.3 2 1 18 18
400 | "399" 23 0.3 5 0 4 42
401 | "400" 23 0.3 5 1 15 18
402 | "401" 23 0.3 8 0 12 42
403 | "402" 23 0.3 8 1 16 18
404 | "403" 23 0.5 2 0 2 30
405 | "404" 23 0.5 2 1 27 30
406 | "405" 23 0.5 5 0 8 30
407 | "406" 23 0.5 5 1 27 30
408 | "407" 23 0.5 8 0 9 30
409 | "408" 23 0.5 8 1 22 30
410 | "409" 23 0.7 2 0 1 18
411 | "410" 23 0.7 2 1 39 42
412 | "411" 23 0.7 5 0 3 18
413 | "412" 23 0.7 5 1 40 42
414 | "413" 23 0.7 8 0 11 18
415 | "414" 23 0.7 8 1 34 42
416 |
--------------------------------------------------------------------------------
/day2/bayesian-models/pictures/zhang-luck.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/jstbcs/CognitiveModelingWorkshop/080db90e6745f28247a7829222982912e6f9b6dd/day2/bayesian-models/pictures/zhang-luck.png
--------------------------------------------------------------------------------
/day2/change-detection/advanced-process-models.rmd:
--------------------------------------------------------------------------------
1 | ---
2 | title: "Advanced Modeling Options"
3 | author: "Julia Haaf & Stephen Rhodes"
4 | output:
5 | ioslides_presentation:
6 | logo: pictures/MUlogoRGB.png
7 | widescreen: true
8 | ---
9 |
10 | ```{r setup, echo = F, warning=FALSE}
11 | # MLE Rouder et al (2008) PNAS
12 | cd = read.table(file = "data/rouder08-data-0.5.dat")
13 |
14 | # the data frame gives numbers of hits, misses, false-alarms, and correct rejections
15 | # for three set sizes: N = 2,5,8
16 | N = c(2,5,8)
17 | N_i = rep(1:length(N), each=4) # index
18 |
19 | #Multinomial Negative Log-Likelihood
20 | negLL <- function(y,p){
21 | a=ifelse(y==0 & p==0,0, y*log(p))
22 | -sum(a)
23 | }
24 |
25 | cowan_k <- function(k, a, g, N){
26 | d = min(1,k/N) # p(probe in memory)
27 | p = 1:4
28 | p[1] = a*(d+(1-d)*g)+(1-a)*g # p(hit)
29 | p[2] = 1-p[1] # p(miss)
30 | p[3] = a*(1-d)*g+(1-a)*g # p(false-alarm)
31 | p[4] = 1-p[3] # p(correct rejection)
32 | return(p)
33 | }
34 |
35 | sdt <- function(d, c, s){
36 | # this is a simplified version of the sdt
37 | # model used by rouder et al.
38 | p = 1:4
39 | p[1] = pnorm((d - c)/s) # p(hit)
40 | p[2] = 1 - p[1] # p(miss)
41 | p[3] = pnorm(- c) # p(false-alarm)
42 | p[4] = 1 - p[3] # p(correct rejection)
43 | return(p)
44 | }
45 |
46 | # Likelihood functions
47 |
48 | ## Binomial Model
49 | ll.vacuous <- function(y){
50 | ll = 0
51 | lenY = length(y)
52 | y1 = y[rep(c(T, F), lenY/2)]
53 | y2 = y[rep(c(F, T), lenY/2)]
54 | n = (rep((y1+y2), each=2))
55 | p = y/n
56 | ll = negLL(y, p)
57 | return(ll)
58 | }
59 |
60 | ## Fixed Capacity Model
61 | ll.fixed_k <- function(par, y){
62 | # length(par) == 3 (k, a, g)
63 | ll = 0
64 | for(i in 1:length(N)){ # for each set size
65 | p = cowan_k(k = par[1], a = par[2], g = par[3], N = N[i])
66 | ll = ll + negLL(y[N_i==i], p)
67 | }
68 | if(any(c(par < rep(0,3), par > c(max(N),1,1)))){
69 | ll = ll + 10000 # penalty for going out of range
70 | }
71 | return(ll)
72 | }
73 |
74 | ## Varying Capacity Model
75 | ll.vary_k <- function(par, y){
76 | # length(par) == 5 (k*3, a, g)
77 | ll=0
78 | for(i in 1:length(N)){ # for each set size
79 | p = cowan_k(k = par[i], a = par[4], g = par[5], N = N[i])
80 | ll = ll + negLL(y[N_i==i], p)
81 | }
82 | if(any(c(par < rep(0,5), par > c(rep(max(N), 3),1,1)))){
83 | ll = ll + 10000 # penalty for going out of range
84 | }
85 | return(ll)
86 | }
87 |
88 | ## Equal-Variance Signal Detection Model
89 | ll.sdt.ev <- function(par, y){
90 | # length(par) == 4 (d1, d2, d3, c)
91 | ll=0
92 | for(i in 1:length(N)){ # for each set size
93 | p = sdt(d = par[i], c = par[length(N)+1], s = 1)
94 | ll = ll + negLL(y[N_i==i], p)
95 | }
96 | return(ll)
97 | }
98 |
99 | # function to calculate fit statistics from -LL
100 | fit_stats <- function(nLL, n, p){
101 | # nLL = negative log liklihood
102 | # n = number of observations
103 | # p = number of parameters
104 |
105 | deviance = 2*nLL
106 | aic = deviance + 2*p
107 | bic = deviance + p*log(n)
108 |
109 | return(list("D" = deviance, "AIC" = aic, "BIC" = bic))
110 | }
111 | #### FIT TO INDIVIDUALS ----
112 |
113 | S = nrow(cd) # number of participants
114 |
115 | # create matrices to hold the resulting parameter estimates
116 | # 1 row per participant, 1 column per parameter
117 | estimates_fix_k <- matrix(NA, nrow = S, ncol = 3)
118 | colnames(estimates_fix_k) <- c("k", "a", "g")
119 |
120 | estimates_vary_k <- matrix(NA, nrow = S, ncol = 5)
121 | colnames(estimates_vary_k) <- c("k1", "k2", "k3", "a", "g")
122 |
123 | estimates_sdt <- matrix(NA, nrow = S, ncol = 4)
124 | colnames(estimates_sdt) <- c("d1", "d2", "d3", "c")
125 |
126 | # create a matrix to hold the -log likelihood for each individual (row)
127 | # and each model (col)
128 | fit_statistics <- matrix(NA, nrow = S, ncol = 5)
129 | colnames(fit_statistics) <- c("LL_vac", "LL_fix_k", "LL_vary_k", "LL_sdt", "N_obs")
130 |
131 | # this loop takes the data from each row (participant) and fits the three models
132 | for (s in 1:S){
133 | # get the data for this subject
134 | tmp.dat = as.integer(cd[s,])
135 |
136 | # model that freely estimates response frequencies
137 | fit_statistics[s,1] <- ll.vacuous(y = tmp.dat)
138 |
139 | # fixed k
140 | par = runif(n = 3, min = 0, max = c(max(N), 1, 1))
141 | k_res_s = optim(par, ll.fixed_k, y = tmp.dat)
142 |
143 | fit_statistics[s,2] <- k_res_s$value # add estimates and LL to matrices
144 | estimates_fix_k[s,] <- k_res_s$par
145 |
146 | # variable k
147 | par = runif(n = 5, min = 0, max = c(rep(max(N),3), 1, 1))
148 | vary_k_res_s = optim(par, ll.vary_k, y = tmp.dat)
149 |
150 | fit_statistics[s,3] <- vary_k_res_s$value
151 | estimates_vary_k[s,] <- vary_k_res_s$par
152 |
153 | ## sdt model
154 | par = runif(n = 4, min = 0, max = c(5, 5, 5, 5))
155 | sdt_res_s = optim(par, ll.sdt.ev, y = tmp.dat)
156 |
157 | fit_statistics[s,4] <- sdt_res_s$value
158 | estimates_sdt[s,] <- sdt_res_s$par
159 |
160 | fit_statistics[s,5] = sum(tmp.dat)
161 | }
162 | # remove stuff we no longer need...
163 | rm(list = c("tmp.dat", "k_res_s", "vary_k_res_s", "sdt_res_s"))
164 | ```
165 |
166 | ## Good To Know
167 |
168 | - Advanced models
169 | - General high-threshold model
170 | - Unequal-variance signal detection model
171 | - Model comparison with "unrelated" models
172 | - AIC
173 | - BIC
174 | - Problems & Fixes: Null counts
175 |
176 | # Advanced Models
177 |
178 | ## General High-Threshold Model (GHT)
179 |
180 | Extension of the double-high-threshold model
181 |
182 | ```{r twohtmodelb,engine='tikz',fig.ext='svg',fig.width=7, echo = F, fig.align='center'}
183 | \begin{tikzpicture}[level 1/.style={sibling distance=4cm}, level 2/.style={sibling distance=3cm}, grow=right, yscale=-1, xscale=1.4]
184 |
185 | % target tree
186 | \node [rectangle, draw] (a) {Signal}
187 | child {node [rectangle, draw] (b) {Detect Signal} % detect
188 | child {node [rectangle, draw] (c) [anchor=west] {hit}}}
189 | child {node [rectangle, draw] (d) {Fail to Detect} % not detect
190 | child {node [rectangle, draw] (e) [anchor=west] {hit}}
191 | child {node [rectangle, draw] (f) [anchor=west] {miss}}};
192 | % non-target tree
193 | \node [rectangle, draw] (g) [right =6.5cm] {Noise}
194 | child {node [rectangle, draw] (h) {Detect Noise} % detect
195 | child {node [rectangle, draw] (i) [anchor=west] {correct rejection}}}
196 | child {node [rectangle, draw] (j) {Fail to Detect} % not detect
197 | child {node [rectangle, draw] (k) [anchor=west] {false alarm}}
198 | child {node [rectangle, draw] (l) [anchor=west] {correct rejection}}};
199 | % add lines and labels
200 | \draw[->,>=stealth] (a) -- node[midway,fill=white] {$d$} (b);
201 | \draw[->,>=stealth] (a) -- node[midway,fill=white] {$1 - d$} (d);
202 | \draw[->,>=stealth] (d) -- node[midway,fill=white] {$g$} (e);
203 | \draw[->,>=stealth] (d) -- node[midway,fill=white] {$1 - g$} (f);
204 | \draw[->,>=stealth] (b) -- (c);
205 | \draw[->,>=stealth] (g) -- node[midway,fill=white] {$d$} (h);
206 | \draw[->,>=stealth] (g) -- node[midway,fill=white] {$1 - d$} (j);
207 | \draw[->,>=stealth] (j) -- node[midway,fill=white] {$g$} (k);
208 | \draw[->,>=stealth] (j) -- node[midway,fill=white] {$1 - g$} (l);
209 | \draw[->,>=stealth] (h) -- (i);
210 |
211 | \end{tikzpicture}
212 | ```
213 |
214 | ## General High-Threshold Model
215 |
216 | ```{r ghtmodelb,engine='tikz',fig.ext='svg',fig.width=7, echo = F, fig.align='center'}
217 | \begin{tikzpicture}[level 1/.style={sibling distance=4cm}, level 2/.style={sibling distance=3cm}, grow=right, yscale=-1, xscale=1.4]
218 |
219 | % target tree
220 | \node [rectangle, draw] (a) {Signal}
221 | child {node [rectangle, draw] (b) {Detect Signal} % detect
222 | child {node [rectangle, draw] (c) [anchor=west] {hit}}}
223 | child {node [rectangle, draw] (d) {Fail to Detect} % not detect
224 | child {node [rectangle, draw] (e) [anchor=west] {hit}}
225 | child {node [rectangle, draw] (f) [anchor=west] {miss}}};
226 | % non-target tree
227 | \node [rectangle, draw] (g) [right =6.5cm] {Noise}
228 | child {node [rectangle, draw] (h) {Detect Noise} % detect
229 | child {node [rectangle, draw] (i) [anchor=west] {correct rejection}}}
230 | child {node [rectangle, draw] (j) {Fail to Detect} % not detect
231 | child {node [rectangle, draw] (k) [anchor=west] {false alarm}}
232 | child {node [rectangle, draw] (l) [anchor=west] {correct rejection}}};
233 | % add lines and labels
234 | \draw[->,>=stealth] (a) -- node[midway,fill=white] {$\mathbf{d_s}$} (b);
235 | \draw[->,>=stealth] (a) -- node[midway,fill=white] {$1 - \mathbf{d_s}$} (d);
236 | \draw[->,>=stealth] (d) -- node[midway,fill=white] {$g$} (e);
237 | \draw[->,>=stealth] (d) -- node[midway,fill=white] {$1 - g$} (f);
238 | \draw[->,>=stealth] (b) -- (c);
239 | \draw[->,>=stealth] (g) -- node[midway,fill=white] {$\mathbf{d_n}$} (h);
240 | \draw[->,>=stealth] (g) -- node[midway,fill=white] {$1 - \mathbf{d_n}$} (j);
241 | \draw[->,>=stealth] (j) -- node[midway,fill=white] {$g$} (k);
242 | \draw[->,>=stealth] (j) -- node[midway,fill=white] {$1 - g$} (l);
243 | \draw[->,>=stealth] (h) -- (i);
244 |
245 | \end{tikzpicture}
246 | ```
247 |
248 | ## General High-Threshold Model
249 |
250 | Let's go back to the change-detection example. How would we fit a general high-threshold version of the fixed-capacity model?
251 |
252 | >- Does it even make sense?
253 | >- Here, $d = k/n$
254 | >- Does it make sense that there are separate capacities for items in memory and items *not* in memory?
255 | >- Identifiability issues
256 |
257 | ```{r, echo = F, message=F, warning=F}
258 | group_data = apply(cd, 2, sum)
259 | # starting values
260 | par = runif(n = 5, min = 0, max = c(rep(max(N),3), 1, 1))
261 | vary_k_res = optim(par, ll.vary_k, y = group_data)
262 |
263 | parameter.estimates <- vary_k_res$par
264 | names(parameter.estimates) <- c("k2", "k5", "k8", "a", "g")
265 | ```
266 |
267 | ## Unequal Variance Signal Detection Model (UVSD)
268 |
269 | Equal variance:
270 |
271 | ```{r echo = F}
272 | x <- seq(-3, 5, .01)
273 | y.noise <- dnorm(x)
274 | y.signal <- dnorm(x, 1.5)
275 |
276 | plot(x, y.noise
277 | , type = "l", lwd = 2
278 | , xlim = range(x)
279 | , frame.plot = F
280 | , ylab = "Density"
281 | , xlab = "Sensory Strength"
282 | )
283 | lines(x, y.signal, col = "firebrick4", lwd = 2)
284 | # make.line(0)
285 | # make.line(1.5, 1.5)
286 | abline(v = 1, lwd = 2, col = "darkgreen")
287 | axis(3, at = c(0, 1.5), labels = c("", ""))
288 | mtext("d'", 3, line = .5, at = .75, cex = 1.3)
289 | text(1.2, .03, "c", cex = 1.3)
290 | text(-2, .25, "Stimulus absent")
291 | text(3.5, .25, "Stimulus present")
292 | ```
293 |
294 | ## Unequal Variance Signal Detection Model (UVSD)
295 |
296 | Let mean *and* variance vary for signal distribution!
297 |
298 | ```{r echo = F}
299 | x <- seq(-3, 5, .01)
300 | y.noise <- dnorm(x)
301 | y.signal <- dnorm(x, 1.5, 1.5)
302 |
303 | plot(x, y.noise
304 | , type = "l", lwd = 2
305 | , xlim = range(x)
306 | , frame.plot = F
307 | , ylab = "Density"
308 | , xlab = "Sensory Strength"
309 | )
310 | lines(x, y.signal, col = "firebrick4", lwd = 2)
311 | # make.line(0)
312 | # make.line(1.5, 1.5)
313 | abline(v = 1, lwd = 2, col = "darkgreen")
314 | axis(3, at = c(0, 1.5), labels = c("", ""))
315 | mtext("d'", 3, line = .5, at = .75, cex = 1.3)
316 | text(1.2, .03, "c", cex = 1.3)
317 | text(-2, .25, "Stimulus absent")
318 | text(3.5, .25, "Stimulus present")
319 | ```
320 | ## UVSD for change detection
321 |
322 | ```{r, echo = F}
323 |
324 | par(mar=c(4,3,1,1))
325 | curve(expr = dnorm(x, 0, 1), from = -3, to = 6, xlab="Strength of evidence for 'change'", ylab="", lwd=2)
326 |
327 | curve(expr = dnorm(x, 1, 1.2), col="tomato", from = -3, to = 6, lwd=2, add = T)
328 | curve(expr = dnorm(x, 2, 1.2), col="forestgreen", from = -3, to = 6, lwd=2, add = T)
329 | curve(expr = dnorm(x, 3, 1.2), col="dodgerblue", from = -3, to = 6, lwd=2, add = T)
330 |
331 | legend("topleft", legend = c(2,5,8), lty = 1, col = c("dodgerblue", "forestgreen","tomato"), title = "N", lwd=2, bty='n')
332 |
333 | ```
334 |
335 | ## Even more UVSD for change detection
336 |
337 | ```{r echo = F}
338 |
339 | par(mar=c(4,3,1,1))
340 | curve(expr = dnorm(x, 0, 1), from = -3, to = 6, xlab="Strength of evidence for 'change'", ylab="", lwd=2)
341 |
342 | curve(expr = dnorm(x, 1, 1.5), col="tomato", from = -3, to = 6, lwd=2, add = T)
343 | curve(expr = dnorm(x, 2, 1.2), col="forestgreen", from = -3, to = 6, lwd=2, add = T)
344 | curve(expr = dnorm(x, 3, 2), col="dodgerblue", from = -3, to = 6, lwd=2, add = T)
345 |
346 | legend("topleft", legend = c(2,5,8), lty = 1, col = c("dodgerblue", "forestgreen","tomato"), title = "N", lwd=2, bty='n')
347 |
348 | ```
349 |
350 | ## Unequal Variance Signal Detection Model (UVSD)
351 |
352 | Downside:
353 |
354 | >- This is an extremely flexible mode
355 | >- Can fit nearly all data patterns
356 | >- Not that many parameters
357 | >- Often preferred in frequentist model comparison
358 | >- Interpretation difficult
359 |
360 | ## Unequal Variance Signal Detection Model (UVSD)
361 |
362 | ```{r}
363 | ## Unequal-Variance Signal Detection Model
364 | ll.sdt.uv <- function(par, y){
365 | # length(par) == 7 (d1, d2, d3, c, s1, s2, s3)
366 | ll=0
367 | for(i in 1:length(N)){ # for each set size
368 | p = sdt(d = par[i], c = par[length(N) + 1], s = par[length(N) + 1 + i])
369 | ll = ll + negLL(y[N_i==i], p)
370 | }
371 | if(any(par[5:7] < rep(0,3))){
372 | ll = ll + 10000} # penalty for going out of range
373 | return(ll)
374 | }
375 | ```
376 |
377 | ## Unequal Variance Signal Detection Model (UVSD) {.smaller}
378 |
379 | ```{r}
380 | ## fit uvsd model
381 | par = runif(n = 7, min = .1, max = 3)
382 | sdt_res_uv = optim(par, ll.sdt.uv, y = group_data)
383 | sdt_res_uv$par
384 |
385 | ## fit evsd model
386 | par = runif(n = 4, min = .1, max = 3)
387 | sdt_res = optim(par, ll.sdt.ev, y = group_data)
388 | sdt_res$par
389 |
390 | c(sdt_res_uv$value, sdt_res$value)
391 | ```
392 |
393 | # Model comparison
394 |
395 | ## Model comparison with "unrelated" models
396 |
397 | >- $\chi^2$-test with $G^2 = 2(LL_g - LL_r)$ only works with nested models
398 | >- We can compare UVSD to EVSD, or Varying Capacity to Fixed Capacity
399 | >- We cannot compare EVSD to Fixed Capacity with the $G^2$-test
400 | >- Needed: Test statistic that rewards low likelihood values and punishes complexity
401 | >- AIC and BIC
402 |
403 | ##Akaike information criterion (AIC)
404 |
405 | \[AIC = - 2 \log(L) + 2 p,\]
406 |
407 | where $m$ is the number of parameters and $- 2 \log(L)$ is two times the negative log likelihood.
408 |
409 | ##Bayesian information criterion (BIC)
410 |
411 | \[AIC = - 2 \log(L) + 2 p,\]
412 |
413 | where $p$ is the number of parameters and $- 2 \log(L)$ is two times the negative log likelihood.
414 |
415 | \[BIC = - 2 \log(L) + p \log(n),\]
416 |
417 | where $n$ is the number of observations.
418 |
419 | *Q:* Do you want higher or lower values of AIC/BIC?
420 |
421 | ## AIC and BIC in R
422 |
423 | ```{r}
424 | # function to calculate fit statistics from -LL
425 | fit_stats <- function(nLL, n, p){
426 | # nLL = negative log liklihood
427 | # n = number of observations
428 | # p = number of parameters
429 |
430 | deviance = 2*nLL
431 | aic = deviance + 2*p
432 | bic = deviance + p*log(n)
433 |
434 | return(list("D" = deviance, "AIC" = aic, "BIC" = bic))
435 | }
436 | ```
437 |
438 | ## AIC and BIC in R
439 |
440 | ```{r, echo = F, warning = F}
441 | ## fit k model
442 | # starting values
443 | par = runif(n = 3, min = 0, max = c(max(N), 1, 1))
444 | k_res = optim(par, ll.fixed_k, y = group_data)
445 |
446 | # starting values
447 | par = runif(n = 5, min = 0, max = c(rep(max(N),3), 1, 1))
448 | vary_k_res = optim(par, ll.vary_k, y = group_data)
449 |
450 | ## fit sdt model
451 | par = runif(n = 4, min = 0, max = c(5, 5, 5, 5))
452 | sdt_res = optim(par, ll.sdt.ev, y = group_data)
453 | ```
454 |
455 |
456 | ```{r}
457 | sdt_fit = fit_stats(nLL = sdt_res$value, n = sum(group_data), p = 4)
458 | k_fit = fit_stats(nLL = k_res$value, n = sum(group_data), p = 3)
459 | vary_k_fit = fit_stats(nLL = vary_k_res$value, n = sum(group_data), p = 5)
460 |
461 | c(sdt_fit$AIC, k_fit$AIC, vary_k_fit$AIC)
462 |
463 | c(sdt_fit$BIC, k_fit$BIC, vary_k_fit$BIC)
464 | ```
465 |
466 | ## AIC and BIC in R
467 |
468 | ```{r}
469 | sdt_fit = fit_stats(nLL = sdt_res$value, n = sum(group_data), p = 4)
470 | k_fit = fit_stats(nLL = k_res$value, n = sum(group_data), p = 3)
471 | vary_k_fit = fit_stats(nLL = vary_k_res$value, n = sum(group_data), p = 5)
472 |
473 | c(sdt_fit$AIC, k_fit$AIC, vary_k_fit$AIC)
474 |
475 | c(sdt_fit$BIC, k_fit$BIC, vary_k_fit$BIC)
476 | ```
477 |
478 | Remember: The lower the better
479 |
480 | ## AIC and BIC
481 |
482 | >- Can also be used to compare model fit for all individuals independently
483 | >- A landscape of information criterial
484 | >- s (participants) x m (models) AIC or BIC
485 | >- Who is fit best by model m?
486 | >- Which model fits participant s' data best?
487 | >- Go to `mle-rouder08-indiv.R`
488 |
489 | ## AIC and BIC for individuals
490 |
491 | 1. Fit models to all individuals using a `for()`-loop
492 | 2. Extract negative log likelihood value and calculate AIC/BIC
493 | 3. Summarize in a table
494 | 4. Which mode is preferred for which participant?
495 |
496 |
497 |
498 | # Problems & Fixes: Null counts
499 |
500 | ## Null counts
501 |
502 | >- Occasional absence of either miss or false-alarm event
503 | >- Especially problematic for SDT
504 | >- Especially problematic when fitting models to individuals' data
505 |
506 | ## Null counts {.build}
507 |
508 | There is an easy fix:
509 |
510 | \[
511 | \hat{p}_h = \frac{y_h + .5}{N_s + 1}, \\
512 | \hat{p}_f = \frac{y_f + .5}{N_f + 1}.
513 | \]
514 |
515 | This is done by adding $+.5$ to each observed cell count
516 |
517 | ## Null counts
518 |
519 | This is done by adding $+.5$ to each observed cell count
520 |
521 | ```{r, eval = F}
522 | # this loop takes the data from each row (participant) and fits the three models
523 | for (s in 1:S){
524 | # get the data for this subject
525 | tmp.dat = as.integer(cd[s,]) + .5
526 |
527 | # model that freely estimates response frequencies
528 | fit_statistics[s,1] <- ll.vacuous(y = tmp.dat)
529 |
530 | ...
531 | ```
532 |
533 | You can find the code at the end of `mle-rouder08-indiv.R`
534 |
--------------------------------------------------------------------------------
/day2/change-detection/change-detection.Rmd:
--------------------------------------------------------------------------------
1 | ---
2 | title: "Models for Change Detection"
3 | author: "Stephen Rhodes and Julia Haaf"
4 | output:
5 | ioslides_presentation:
6 | logo: ../../day1/intro-to-R/pictures/MUlogoRGB.png
7 | widescreen: true
8 | subtitle: Analyzing Rouder et al. (2008)
9 | ---
10 |
11 | ```{r setup, include=FALSE}
12 | knitr::opts_chunk$set(echo = FALSE)
13 | ```
14 |
15 | ## Change Detection
16 |
17 |
18 | [Rouder et al. (2008)](http://www.pnas.org/content/105/16/5975)
19 |
20 |
21 |
22 | 
23 |
24 |
25 |
26 |
27 |
28 | - Is there a fixed capacity limit to visual working memory?
29 | - Manipulated:
30 | - set size (number of items to remember): 2, 5, or 8
31 | - probability of a change occuring: 30%, 50%, or 70% of trials
32 |
33 |
34 |
35 | ## Change Detection
36 |
37 | - Cowan (2001) suggested a way of estimating the number of items in working memory, $k$, using the change detection task
38 | - $d = \min(k/N, 1)$ = probability that the probed item is in memory
39 | - If the probed item is in memory the participant responds correctly. If it isn't, they must guess:
40 | - $p(\mbox{resp} = \mbox{change} \mid \mbox{change}) = p_h = d + (1 - d)g$
41 | - $p(\mbox{resp} = \mbox{change} \mid \mbox{no-change}) = p_f = (1 - d)g$
42 | - This gives a formula for $k$:
43 | - $p_h = k/N + p_f \rightarrow k = N(p_h - p_f)$
44 |
45 | ## Change Detection
46 |
47 | - But this formula only works one set size at a time and doesn't work for $k > N$
48 | - Rouder et al. (2008) used MLE to fit a single $k$ across multiple set sizes
49 | - This model didn't fit very well...
50 | - At set size 2 the model predicted perfect performance, but none of the participants performed absolutely perfectly
51 | - To account for errors at low set sizes they added an attention parameter, $a$, which was the probability that the participant attended a given trial. $1 - a$ is their lapse rate.
52 |
53 | ## The extension for 'lapsing'
54 |
55 | If people lapse, they guess
56 |
57 | $$
58 | p(\mbox{resp} = \mbox{change} \mid \mbox{change}) = p_h = a(d + (1 - d)g) + (1 - a)g
59 | $$
60 |
61 | $$
62 | p(\mbox{resp} = \mbox{change} \mid \mbox{no-change}) = p_f = a(1 - d)g + (1 - a)g
63 | $$
64 |
65 | ## Result
66 |
67 | ```{r, out.width = "400px", echo=F}
68 | knitr::include_graphics("pictures/rouder08.png")
69 | ```
70 |
71 | ## Other models
72 |
73 | - Rouder et al. (2008) also considered a version of the model where $k$ was free to vary by set size. The fixed capacity version faired better.
74 |
75 | - They also fit a signal detection theory model, where the probe is always assumed to be in memory. Set size is assumed to reduce sensitivity as a resource is spread more thinly across the items.
76 |
77 | ## SDT model
78 |
79 | ```{r}
80 |
81 | par(mar=c(4,3,1,1))
82 | curve(expr = dnorm(x, 0, 1), from = -3, to = 6, xlab="Strength of evidence for 'change'", ylab="", lwd=2)
83 |
84 | curve(expr = dnorm(x, 1, 1.2), col="tomato", from = -3, to = 6, lwd=2, add = T)
85 | curve(expr = dnorm(x, 2, 1.2), col="forestgreen", from = -3, to = 6, lwd=2, add = T)
86 | curve(expr = dnorm(x, 3, 1.2), col="dodgerblue", from = -3, to = 6, lwd=2, add = T)
87 |
88 | legend("topleft", legend = c(2,5,8), lty = 1, col = c("dodgerblue", "forestgreen","tomato"), title = "N", lwd=2, bty='n')
89 |
90 | ```
91 |
92 | # Implementing these models in R
93 |
94 | ## Implementing these models in R
95 |
96 | We need three elements
97 |
98 | - A `function()` to generate the predictions from the models given some parameter settings
99 | - A `function()` to calculate the likelihood of the parameters given the data
100 | - A `function()` that combines the above two into a specific version of the model (e.g. one that restricts certain parameters)
101 |
102 | ## Implementing these models in R
103 |
104 | We need to write this function with an understanding of what form the data are in.
105 |
106 | The data are given with one participant per row with numbers of *hits*, *misses*, *false alarms*, and *correct rejections* (order is important) for each set size.
107 |
108 | *Note* we only look at the data from the 50% change condition to simplify things.
109 |
110 | ```{r, echo=T}
111 | cd = read.table(file = "data/rouder08-data-0.5.dat")
112 | head(cd, n = 1)
113 | ```
114 |
115 | ## Prediction functions | Fixed capacity model
116 |
117 | With that in mind we make our prediction functions return in the same order
118 |
119 | ```{r, echo=T}
120 | cowan_k <- function(k, a, g, N){
121 | d = min(1,k/N) # p(probe in memory)
122 |
123 | p = 1:4
124 | p[1] = a*(d+(1-d)*g)+(1-a)*g # p(hit)
125 | p[2] = 1-p[1] # p(miss)
126 | p[3] = a*(1-d)*g+(1-a)*g # p(false-alarm)
127 | p[4] = 1-p[3] # p(correct rejection)
128 | return(p)
129 | }
130 | ```
131 |
132 | ## Prediction functions | Signal detection model
133 |
134 | With that in mind we make our prediction functions return in the same order
135 |
136 | ```{r, echo=T}
137 | sdt <- function(d, c, s){
138 | # this is a simplified version of the sdt
139 | # model used by rouder et al.
140 | p = 1:4
141 | p[1] = pnorm((d - c)/s) # p(hit)
142 | p[2] = 1 - p[1] # p(miss)
143 | p[3] = pnorm(- c) # p(false-alarm)
144 | p[4] = 1 - p[3] # p(correct rejection)
145 | return(p)
146 | }
147 | ```
148 |
149 | ## Likelihood function
150 |
151 | ```{r, echo=T, eval=F}
152 | # Multinomial Negative Log-Likelihood
153 | negLL <- function(y,p){
154 | a=ifelse(y==0 & p==0,0, y*log(p))
155 | -sum(a)
156 | }
157 | # this seems to work better than dmultinom
158 | ```
159 |
160 | ## Model functions | Fixed capacity model
161 |
162 | ```{r, echo = T}
163 | N = c(2,5,8)
164 | N_i = rep(1:length(N), each=4) # index
165 |
166 | # fixed capacity model
167 | ll.fixed_k <- function(par, y){
168 | # length(par) == 3 (k, a, g)
169 | ll=0
170 | for(i in 1:length(N)){ # for each set size
171 | p = cowan_k(k = par[1], a = par[2], g = par[3], N = N[i])
172 | ll = ll + negLL(y[N_i==i], p)
173 | }
174 | if(any(c(par < rep(0,3), par > c(max(N),1,1)))){
175 | ll = ll + 10000 # penalty for going out of range
176 | }
177 | return(ll)
178 | }
179 | ```
180 |
181 | ## Model functions | Variable capacity model
182 |
183 | ```{r, echo = T}
184 | N = c(2,5,8)
185 | N_i = rep(1:length(N), each=4) # index
186 |
187 | # variable capacity model
188 | ll.vary_k <- function(par, y){
189 | # length(par) == 5 (k*3, a, g)
190 | ll=0
191 | for(i in 1:length(N)){ # for each set size
192 | p = cowan_k(k = par[i], a = par[4], g = par[5], N = N[i])
193 | ll = ll + negLL(y[N_i==i], p)
194 | }
195 | if(any(c(par < rep(0,5), par > c(rep(max(N), 3),1,1)))){
196 | ll = ll + 10000 # penalty for going out of range
197 | }
198 | return(ll)
199 | }
200 | ```
201 |
202 | ## Model functions | Equal-variance signal detection model
203 |
204 | ```{r, echo = T}
205 | N = c(2,5,8)
206 | N_i = rep(1:length(N), each=4) # index
207 |
208 | # signal detection model with equal variance for change and no-change items
209 | ll.sdt.ev <- function(par, y){
210 | # length(par) == 4 (d1, d2, d3, c)
211 | ll=0
212 | for(i in 1:length(N)){ # for each set size
213 | p = sdt(d = par[i], c = par[length(N)+1], s = 1)
214 | ll = ll + negLL(y[N_i==i], p)
215 | }
216 | return(ll)
217 | }
218 | ```
219 |
220 | ## Scripts
221 |
222 | `mle-rouder08-group.R` fits these models to aggregate data
223 |
224 | `mle-rouder08-indiv.R` fits these models to aggregate data
225 |
226 |
227 |
228 |
--------------------------------------------------------------------------------
/day2/change-detection/data/reshape-rouder-data.R:
--------------------------------------------------------------------------------
1 |
2 | library(plyr)
3 | library(RCurl)
4 |
5 | intext=getURL("https://raw.githubusercontent.com/PerceptionCognitionLab/data0/master/wmPNAS2008/lk2data.csv")
6 | data=read.csv(text=intext)
7 |
8 | head(data)
9 |
10 | ## Wide format for MLE
11 |
12 | counts = ddply(data, c('sub', 'prch', 'N'), summarize,
13 | H = sum(ischange == 1 & resp == 1),
14 | M = sum(ischange == 1 & resp == 0),
15 | Fa = sum(ischange == 0 & resp == 1),
16 | Cr = sum(ischange == 0 & resp == 0))
17 |
18 | counts$N = paste0("N", counts$N)
19 |
20 | counts_wide =
21 | counts %>%
22 | gather(variable, value, -(sub:N)) %>%
23 | unite(temp, N, prch, variable) %>%
24 | spread(temp, value)
25 |
26 | colorder = c()
27 | for (i in c(0.3, 0.5, 0.7)){
28 | for (j in c("N2", "N5", "N8")){
29 | colorder <- c(colorder, paste(j, i, c("H", "M", "Fa", "Cr"), sep="_"))
30 | }
31 | }
32 |
33 | # re-order columns
34 | counts_wide = counts_wide[, colorder]
35 | apply(counts_wide, 1, sum)
36 |
37 | write.table(x = counts_wide, file = "rouder08-data-full.dat")
38 |
39 | # only the 50:50 trials
40 | counts_wide_0.5 = counts_wide[,grep(colorder, pattern = "0.5")]
41 |
42 | write.table(x = counts_wide_0.5, file = "rouder08-data-0.5.dat")
43 |
44 | # -~ -~ -~ -~ -~ -~ -~ -~ -~ -~ -~ -~ -~ -~ -~ -~ -~ -~ -~ -~ -~ -~ -~ -~ -~ -~ -~ -~
45 | ## Long format for JAGS
46 |
47 | data_long = ddply(data, c("sub", "prch", "N", "ischange"), summarize,
48 | respchange = sum(resp), ntrials = length(resp))
49 |
50 | colnames(data_long)[1] = "ppt"
51 |
52 | data_long$ppt = as.numeric(as.factor(data_long$ppt)) # renumber participants 1:23
53 |
54 | setwd("../../../day2/bayesian-models/jags-change-det/")
55 |
56 | write.table(x = data_long, file = "rouder08-longdata-full.dat")
57 |
58 | data_long_0.5 = subset(data_long, prch==0.5)
59 |
60 | write.table(x = data_long_0.5, file = "rouder08-longdata-0.5.dat")
61 |
--------------------------------------------------------------------------------
/day2/change-detection/data/rouder08-data-0.5.dat:
--------------------------------------------------------------------------------
1 | "N2_0.5_H" "N2_0.5_M" "N2_0.5_Fa" "N2_0.5_Cr" "N5_0.5_H" "N5_0.5_M" "N5_0.5_Fa" "N5_0.5_Cr" "N8_0.5_H" "N8_0.5_M" "N8_0.5_Fa" "N8_0.5_Cr"
2 | "1" 29 1 1 29 25 5 7 23 24 6 11 19
3 | "2" 28 2 0 30 25 5 6 24 25 5 9 21
4 | "3" 27 3 7 23 23 7 10 20 19 11 19 11
5 | "4" 30 0 0 30 27 3 7 23 26 4 15 15
6 | "5" 30 0 0 30 27 3 4 26 24 6 6 24
7 | "6" 29 1 0 30 23 7 7 23 19 11 5 25
8 | "7" 29 1 3 27 23 7 9 21 15 15 6 24
9 | "8" 28 2 5 25 29 1 12 18 19 11 18 12
10 | "9" 30 0 2 28 27 3 11 19 25 5 14 15
11 | "10" 29 1 0 30 29 1 11 19 26 4 19 11
12 | "11" 30 0 5 25 25 5 7 23 23 7 11 19
13 | "12" 28 2 2 28 25 5 19 11 20 10 13 17
14 | "13" 30 0 1 29 27 3 6 24 23 7 7 23
15 | "14" 30 0 0 30 27 3 4 26 26 4 13 17
16 | "15" 28 2 3 27 24 6 4 26 27 3 10 20
17 | "16" 30 0 0 30 25 5 7 23 18 12 10 20
18 | "17" 30 0 2 28 29 1 6 24 28 2 10 20
19 | "18" 29 1 2 28 23 7 12 18 21 9 14 16
20 | "19" 26 4 9 21 27 3 12 18 25 5 17 13
21 | "20" 30 0 0 30 29 1 3 27 29 1 5 25
22 | "21" 29 1 1 29 27 3 7 23 24 6 12 18
23 | "22" 30 0 2 28 20 10 14 16 21 9 15 15
24 | "23" 27 3 2 28 27 3 8 22 22 8 9 21
25 |
--------------------------------------------------------------------------------
/day2/change-detection/data/rouder08-data-full.dat:
--------------------------------------------------------------------------------
1 | "N2_0.3_H" "N2_0.3_M" "N2_0.3_Fa" "N2_0.3_Cr" "N5_0.3_H" "N5_0.3_M" "N5_0.3_Fa" "N5_0.3_Cr" "N8_0.3_H" "N8_0.3_M" "N8_0.3_Fa" "N8_0.3_Cr" "N2_0.5_H" "N2_0.5_M" "N2_0.5_Fa" "N2_0.5_Cr" "N5_0.5_H" "N5_0.5_M" "N5_0.5_Fa" "N5_0.5_Cr" "N8_0.5_H" "N8_0.5_M" "N8_0.5_Fa" "N8_0.5_Cr" "N2_0.7_H" "N2_0.7_M" "N2_0.7_Fa" "N2_0.7_Cr" "N5_0.7_H" "N5_0.7_M" "N5_0.7_Fa" "N5_0.7_Cr" "N8_0.7_H" "N8_0.7_M" "N8_0.7_Fa" "N8_0.7_Cr"
2 | "1" 17 1 1 41 16 2 11 31 12 6 6 36 29 1 1 29 25 5 7 23 24 6 11 19 41 1 0 18 40 2 3 15 35 7 8 10
3 | "2" 17 1 2 40 14 4 6 36 12 6 10 32 28 2 0 30 25 5 6 24 25 5 9 21 40 2 0 18 38 4 3 15 37 5 6 12
4 | "3" 13 5 1 41 11 7 9 32 12 6 13 29 27 3 7 23 23 7 10 20 19 11 19 11 42 0 6 12 41 1 15 3 41 1 12 6
5 | "4" 18 0 1 41 18 0 4 38 12 6 8 34 30 0 0 30 27 3 7 23 26 4 15 15 42 0 0 18 39 3 6 12 41 1 9 9
6 | "5" 17 1 0 42 16 2 3 39 16 2 8 34 30 0 0 30 27 3 4 26 24 6 6 24 40 2 0 18 40 2 7 11 34 8 6 12
7 | "6" 18 0 0 42 14 4 3 39 10 8 8 34 29 1 0 30 23 7 7 23 19 11 5 25 42 0 1 17 38 4 3 15 33 9 10 8
8 | "7" 17 1 3 39 10 8 9 33 9 9 13 29 29 1 3 27 23 7 9 21 15 15 6 24 40 2 5 13 39 3 6 12 36 6 12 6
9 | "8" 16 2 11 31 10 8 13 29 10 8 22 20 28 2 5 25 29 1 12 18 19 11 18 12 36 6 6 12 36 6 9 9 34 8 15 3
10 | "9" 15 3 5 37 13 5 8 34 6 12 8 34 30 0 2 28 27 3 11 19 25 5 14 15 41 1 1 17 40 2 6 12 39 3 12 6
11 | "10" 17 1 0 42 17 1 10 32 15 3 21 21 29 1 0 30 29 1 11 19 26 4 19 11 40 2 1 17 40 2 4 14 39 3 13 5
12 | "11" 17 1 2 40 16 2 13 29 12 6 14 28 30 0 5 25 25 5 7 23 23 7 11 19 42 0 0 18 38 4 7 11 37 5 9 9
13 | "12" 16 2 2 40 14 4 8 34 13 5 12 30 28 2 2 28 25 5 19 11 20 10 13 17 39 3 6 12 37 5 11 7 38 4 13 5
14 | "13" 18 0 0 42 15 3 7 35 13 5 11 31 30 0 1 29 27 3 6 24 23 7 7 23 42 0 0 18 40 2 1 17 39 3 3 15
15 | "14" 17 1 0 42 16 2 6 36 12 6 18 24 30 0 0 30 27 3 4 26 26 4 13 17 41 1 1 17 40 2 5 13 40 2 8 10
16 | "15" 16 2 2 40 16 2 3 39 12 6 8 34 28 2 3 27 24 6 4 26 27 3 10 20 41 1 2 16 40 2 2 16 39 3 7 11
17 | "16" 17 1 0 42 16 2 6 36 9 9 8 34 30 0 0 30 25 5 7 23 18 12 10 20 41 1 1 17 37 5 4 14 34 8 11 7
18 | "17" 18 0 0 42 16 2 1 41 16 2 12 30 30 0 2 28 29 1 6 24 28 2 10 20 42 0 1 17 41 1 0 18 37 5 3 15
19 | "18" 17 1 2 40 11 7 18 24 6 12 18 24 29 1 2 28 23 7 12 18 21 9 14 16 41 1 0 18 32 10 12 6 32 10 9 9
20 | "19" 12 6 14 28 12 6 17 25 10 8 24 18 26 4 9 21 27 3 12 18 25 5 17 13 41 1 5 13 36 6 12 6 37 5 14 4
21 | "20" 17 1 0 42 18 0 5 37 18 0 10 32 30 0 0 30 29 1 3 27 29 1 5 25 42 0 3 15 41 1 3 15 35 7 5 13
22 | "21" 17 1 2 40 17 1 7 35 13 5 16 26 29 1 1 29 27 3 7 23 24 6 12 18 40 2 1 16 39 3 7 11 34 8 6 12
23 | "22" 17 1 0 42 13 5 16 26 3 15 12 30 30 0 2 28 20 10 14 16 21 9 15 15 41 1 3 15 36 6 8 10 34 8 11 7
24 | "23" 18 0 2 40 15 3 4 38 16 2 12 30 27 3 2 28 27 3 8 22 22 8 9 21 39 3 1 17 40 2 3 15 34 8 11 7
25 |
--------------------------------------------------------------------------------
/day2/change-detection/mle-rouder08-group.R:
--------------------------------------------------------------------------------
1 |
2 | # MLE Rouder et al (2008) PNAS
3 |
4 | cd = read.table(file = "day1/change-detection/data/rouder08-data-0.5.dat")
5 |
6 | group_data = apply(cd, 2, sum)
7 |
8 | # the data frame gives numbers of hits, misses, false-alarms, and correct rejections
9 | # for three set sizes: N = 2,5,8
10 |
11 | N = c(2,5,8)
12 | N_i = rep(1:length(N), each=4) # index
13 |
14 | #Multinomial Negative Log-Likelihood
15 | negLL <- function(y,p){
16 | a = suppressWarnings(ifelse(y==0 & p==0 | p < 0, 0, y*log(p)))
17 | -sum(a)
18 | }
19 |
20 | cowan_k <- function(k, a, g, N){
21 | d = min(1,k/N) # p(probe in memory)
22 |
23 | p = 1:4
24 | p[1] = a*(d+(1-d)*g)+(1-a)*g # p(hit)
25 | p[2] = 1-p[1] # p(miss)
26 | p[3] = a*(1-d)*g+(1-a)*g # p(false-alarm)
27 | p[4] = 1-p[3] # p(correct rejection)
28 | return(p)
29 | }
30 |
31 | sdt <- function(d, c, s){
32 | # this is a simplified version of the sdt
33 | # model used by rouder et al.
34 | p = 1:4
35 | p[1] = pnorm((d - c)/s) # p(hit)
36 | p[2] = 1 - p[1] # p(miss)
37 | p[3] = pnorm(- c) # p(false-alarm)
38 | p[4] = 1 - p[3] # p(correct rejection)
39 | return(p)
40 | }
41 |
42 | # test this function out... plot an ROC curve
43 | # m = sapply(seq(0,5, .1), FUN = function(x) sdt(d=0, c = x, s = 1))
44 | # plot(m[3,], m[1,], type='l')
45 |
46 | # Likelihood functions
47 |
48 | ## Binomial Model
49 | ll.vacuous <- function(y){
50 | ll = 0
51 | lenY = length(y)
52 | y1 = y[rep(c(T, F), lenY/2)]
53 | y2 = y[rep(c(F, T), lenY/2)]
54 | n = (rep((y1+y2), each=2))
55 | p = y/n
56 | ll = negLL(y, p)
57 | return(ll)
58 | }
59 |
60 | ## Fixed Capacity Model
61 | ll.fixed_k <- function(par, y){
62 | # length(par) == 3 (k, a, g)
63 | ll = 0
64 | for (i in 1:length(N)){ # for each set size
65 | p = cowan_k(k = par[1], a = par[2], g = par[3], N = N[i])
66 | ll = ll + negLL(y[N_i==i], p)
67 | }
68 | if(any(c(par < rep(0,3), par > c(max(N),1,1)))){
69 | ll = ll + 10000 # penalty for going out of range
70 | }
71 | return(ll)
72 | }
73 |
74 | ## Varying Capacity Model
75 | ll.vary_k <- function(par, y){
76 | # length(par) == 5 (k*3, a, g)
77 | ll=0
78 | for(i in 1:length(N)){ # for each set size
79 | p = cowan_k(k = par[i], a = par[4], g = par[5], N = N[i])
80 | ll = ll + negLL(y[N_i==i], p)
81 | }
82 | if(any(c(par < rep(0,5), par > c(rep(max(N), 3),1,1)))){
83 | ll = ll + 10000 # penalty for going out of range
84 | }
85 | return(ll)
86 | }
87 |
88 | ## Equal-Variance Signal Detection Model
89 | ll.sdt.ev <- function(par, y){
90 | # length(par) == 4 (d1, d2, d3, c)
91 | ll=0
92 | for(i in 1:length(N)){ # for each set size
93 | p = sdt(d = par[i], c = par[length(N)+1], s = 1)
94 | ll = ll + negLL(y[N_i==i], p)
95 | }
96 | return(ll)
97 | }
98 |
99 | # get LL from vacuous model
100 | ll.vac = ll.vacuous(y = group_data)
101 |
102 | ## fit k model
103 | # starting values
104 | par = runif(n = 3, min = 0, max = c(max(N), 1, 1))
105 | k_res = optim(par, ll.fixed_k, y = group_data)
106 | k_res$value
107 |
108 | k_res$par
109 |
110 | # starting values
111 | par = runif(n = 5, min = 0, max = c(rep(max(N),3), 1, 1))
112 | vary_k_res = optim(par, ll.vary_k, y = group_data)
113 | vary_k_res$value
114 |
115 | vary_k_res$par
116 |
117 | ## fit sdt model
118 | par = runif(n = 4, min = 0, max = c(5, 5, 5, 5))
119 | sdt_res = optim(par, ll.sdt.ev, y = group_data)
120 | sdt_res$value
121 |
122 | sdt_res$par
123 |
124 | #### TASKS -----
125 |
126 | # try making and fitting the following models:
127 | # - unequal variance signal detection
128 | # - a fixed capacity model with no attention parameter (i.e. a = 1)
129 | # - compare the fixed and variable capacity (k) models via G^2
130 |
131 |
132 |
133 | ### SCROLL DOWN TO SEE SOLUTIONS ----
134 |
135 |
136 |
137 |
138 |
139 |
140 |
141 | # unequal variance signal detection
142 | ll.sdt.uev <- function(par, y){
143 | # length(par) == 5 (d1, d2, d3, c, s)
144 | ll=0
145 | for(i in 1:length(N)){ # for each set size
146 | p = sdt(d = par[i], c = par[4], s = par[5])
147 | ll = ll + negLL(y[N_i==i], p)
148 | }
149 | return(ll)
150 | }
151 |
152 | par = runif(n = 5, min = 0, max = c(5, 5, 5, 5, 2))
153 | sdtuv_res = optim(par, ll.sdt.uev, y = group_data)
154 | sdtuv_res$value
155 |
156 | sdtuv_res$par
157 |
158 | # a fixed capacity model with no attention parameter (i.e. a = 1)
159 | ll.fixed_k_noA <- function(par, y){
160 | # length(par) == 2 (k, g)
161 | ll = 0
162 | for (i in 1:length(N)){ # for each set size
163 | p = cowan_k(k = par[1], a = 1, g = par[2], N = N[i])
164 | ll = ll + negLL(y[N_i==i], p)
165 | }
166 | if(any(c(par < rep(0,2), par > c(max(N),1)))){
167 | ll = ll + 10000 # penalty for going out of range
168 | }
169 | return(ll)
170 | }
171 |
172 | par = runif(n = 2, min = 0, max = c(max(N), 1))
173 | par = c(1, .5)
174 | k_noA_res = optim(par, ll.fixed_k_noA, y = group_data)
175 | k_noA_res$value
176 |
177 | k_noA_res$par
178 |
179 | # compare the fixed and variable capacity (k) models via G^2
180 | G = 2*(k_res$value - vary_k_res$value)
181 |
182 | 1 - pchisq(G, df = 2)
183 |
184 |
--------------------------------------------------------------------------------
/day2/change-detection/mle-rouder08-indiv.R:
--------------------------------------------------------------------------------
1 |
2 | # MLE Rouder et al (2008) PNAS
3 |
4 | # get the MLE functions from the group script
5 | source("day1/change-detection/mle-rouder08-group.R")
6 |
7 | # the data is also read in under cd
8 | head(cd)
9 |
10 | # function to calculate fit statistics from -LL
11 | fit_stats <- function(nLL, n, p){
12 | # nLL = negative log liklihood
13 | # n = number of observations
14 | # p = number of parameters
15 |
16 | deviance = 2*nLL
17 | aic = deviance + 2*p
18 | bic = deviance + p*log(n)
19 |
20 | return(list("D" = deviance, "AIC" = aic, "BIC" = bic))
21 | }
22 |
23 | sdt_fit = fit_stats(nLL = sdt_res$value, n = sum(group_data), p = 4)
24 |
25 | k_fit = fit_stats(nLL = k_res$value, n = sum(group_data), p = 3)
26 |
27 | vary_k_fit = fit_stats(nLL = vary_k_res$value, n = sum(group_data), p = 5)
28 |
29 | sdt_fit$AIC
30 | k_fit$AIC
31 | vary_k_fit$AIC
32 |
33 | sdt_fit$BIC
34 | k_fit$BIC
35 | vary_k_fit$BIC
36 |
37 | #### FIT TO INDIVIDUALS ----
38 |
39 | S = nrow(cd) # number of participants
40 |
41 | # create matrices to hold the resulting parameter estimates
42 | # 1 row per participant, 1 column per parameter
43 | estimates_fix_k <- matrix(NA, nrow = S, ncol = 3)
44 | colnames(estimates_fix_k) <- c("k", "a", "g")
45 |
46 | estimates_vary_k <- matrix(NA, nrow = S, ncol = 5)
47 | colnames(estimates_vary_k) <- c("k1", "k2", "k3", "a", "g")
48 |
49 | estimates_sdt <- matrix(NA, nrow = S, ncol = 4)
50 | colnames(estimates_sdt) <- c("d1", "d2", "d3", "c")
51 |
52 | # create a matrix to hold the -log likelihood for each individual (row)
53 | # and each model (col)
54 | fit_statistics <- matrix(NA, nrow = S, ncol = 5)
55 | colnames(fit_statistics) <- c("LL_vac", "LL_fix_k", "LL_vary_k", "LL_sdt", "N_obs")
56 |
57 | # this loop takes the data from each row (participant) and fits the three models
58 | for (s in 1:S){
59 | # get the data for this subject
60 | tmp.dat = as.integer(cd[s,])
61 |
62 | # model that freely estimates response frequencies
63 | fit_statistics[s,1] <- ll.vacuous(y = tmp.dat)
64 |
65 | # fixed k
66 | par = runif(n = 3, min = 0, max = c(max(N), 1, 1))
67 | k_res_s = optim(par, ll.fixed_k, y = tmp.dat)
68 |
69 | fit_statistics[s,2] <- k_res_s$value # add estimates and LL to matrices
70 | estimates_fix_k[s,] <- k_res_s$par
71 |
72 | # variable k
73 | par = runif(n = 5, min = 0, max = c(rep(max(N),3), 1, 1))
74 | vary_k_res_s = optim(par, ll.vary_k, y = tmp.dat)
75 |
76 | fit_statistics[s,3] <- vary_k_res_s$value
77 | estimates_vary_k[s,] <- vary_k_res_s$par
78 |
79 | ## sdt model
80 | par = runif(n = 4, min = 0, max = c(5, 5, 5, 5))
81 | sdt_res_s = optim(par, ll.sdt.ev, y = tmp.dat)
82 |
83 | fit_statistics[s,4] <- sdt_res_s$value
84 | estimates_sdt[s,] <- sdt_res_s$par
85 |
86 | fit_statistics[s,5] = sum(tmp.dat)
87 | }
88 | # remove stuff we no longer need...
89 | rm(list = c("tmp.dat", "k_res_s", "vary_k_res_s", "sdt_res_s"))
90 |
91 | # look at resulting parameter estimates
92 | hist(estimates_fix_k[,'k'], main="Fixed k", xlab="k estimate")
93 |
94 |
95 | #################### Model Comparison #######################
96 |
97 | ##Let's do AIC first
98 | AIC.ind <- fit_statistics
99 | for(s in 1:S){
100 | for(m in 1:M){
101 | AIC.ind[s, m] <- fit_stats(nLL = fit_statistics[s, m], n = fit_statistics[s, 5], p = npar[m])$AIC
102 | }
103 | AIC.ind[s, 5] <- order(AIC.ind[s, 1:4])[1]
104 | }
105 |
106 | colnames(AIC.ind) <- c("vac", "fix_k", "vary_k", "sdt", "winner")
107 | AIC.ind <- as.data.frame(AIC.ind)
108 | AIC.ind$winner <- factor(AIC.ind$winner
109 | , labels = c("fix_k", "vary_k", "sdt"))
110 | table(AIC.ind$winner)
111 |
112 | ##BIC
113 | BIC.ind <- fit_statistics
114 | M <- ncol(BIC.ind)
115 | npar <- c(12, 3, 5, 4)
116 |
117 | for(s in 1:S){
118 | for(m in 1:M){
119 | BIC.ind[s, m] <- fit_stats(nLL = fit_statistics[s, m], n = fit_statistics[s, 5], p = npar[m])$BIC
120 | }
121 | BIC.ind[s, 5] <- order(BIC.ind[s, 1:4])[1]
122 | }
123 |
124 | colnames(BIC.ind) <- c("vac", "fix_k", "vary_k", "sdt", "winner")
125 | BIC.ind <- as.data.frame(BIC.ind)
126 | BIC.ind$winner <- factor(BIC.ind$winner
127 | , labels = c("fix_k"))
128 | table(BIC.ind$winner)
129 |
130 |
131 | ##################### More Stuff #####################################
132 |
133 | #### Unequal Variance Signal Detection Model
134 |
135 | ll.sdt.uv <- function(par, y){
136 | # length(par) == 7 (d1, d2, d3, c, s1, s2, s3)
137 | ll=0
138 | for(i in 1:length(N)){ # for each set size
139 | p = sdt(d = par[i], c = par[length(N) + 1], s = par[length(N) + 1 + i])
140 | ll = ll + negLL(y[N_i==i], p)
141 | }
142 | if(any(par[5:7] < rep(0,3))){
143 | ll = ll + 10000} # penalty for going out of range
144 | return(ll)
145 | }
146 |
147 | ## fit sdt model
148 | par = runif(n = 7, min = 0, max = 3)
149 | sdt_res_uv = optim(par, ll.sdt.uv, y = group_data)
150 | sdt_res_uv$par
151 |
152 | ## fit sdt model
153 | par = runif(n = 4, min = 0, max = 3)
154 | sdt_res = optim(par, ll.sdt.ev, y = group_data)
155 | sdt_res$par
156 |
157 | c(sdt_res_uv$value, sdt_res$value)
158 |
159 | ## Try with differen random seeds set.seed(123)
160 |
161 |
162 |
163 | ##### Dealing with zero counts
164 |
165 |
166 | # create a matrix to hold the -log likelihood for each individual (row)
167 | # and each model (col)
168 | fit_statistics <- matrix(NA, nrow = S, ncol = 5)
169 | colnames(fit_statistics) <- c("LL_vac", "LL_fix_k", "LL_vary_k", "LL_sdt", "N_obs")
170 |
171 | # this loop takes the data from each row (participant) and fits the three models
172 | for (s in 1:S){
173 | # get the data for this subject
174 | tmp.dat = as.integer(cd[s,]) + .5
175 |
176 | # model that freely estimates response frequencies
177 | fit_statistics[s,1] <- ll.vacuous(y = tmp.dat)
178 |
179 | # fixed k
180 | par = runif(n = 3, min = 0, max = c(max(N), 1, 1))
181 | k_res_s = optim(par, ll.fixed_k, y = tmp.dat)
182 |
183 | fit_statistics[s,2] <- k_res_s$value # add estimates and LL to matrices
184 | estimates_fix_k[s,] <- k_res_s$par
185 |
186 | # variable k
187 | par = runif(n = 5, min = 0, max = c(rep(max(N),3), 1, 1))
188 | vary_k_res_s = optim(par, ll.vary_k, y = tmp.dat)
189 |
190 | fit_statistics[s,3] <- vary_k_res_s$value
191 | estimates_vary_k[s,] <- vary_k_res_s$par
192 |
193 | ## sdt model
194 | par = runif(n = 4, min = 0, max = c(5, 5, 5, 5))
195 | sdt_res_s = optim(par, ll.sdt.ev, y = tmp.dat)
196 |
197 | fit_statistics[s,4] <- sdt_res_s$value
198 | estimates_sdt[s,] <- sdt_res_s$par
199 |
200 | fit_statistics[s,5] = sum(tmp.dat)
201 | }
202 | # remove stuff we no longer need...
203 | rm(list = c("tmp.dat", "k_res_s", "vary_k_res_s", "sdt_res_s"))
204 |
205 | # look at resulting parameter estimates
206 | hist(estimates_fix_k[,'k'], main="Fixed k", xlab="k estimate")
207 |
208 |
--------------------------------------------------------------------------------
/day2/change-detection/pictures/MUlogoRGB.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/jstbcs/CognitiveModelingWorkshop/080db90e6745f28247a7829222982912e6f9b6dd/day2/change-detection/pictures/MUlogoRGB.png
--------------------------------------------------------------------------------
/day2/change-detection/pictures/SP.pdf:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/jstbcs/CognitiveModelingWorkshop/080db90e6745f28247a7829222982912e6f9b6dd/day2/change-detection/pictures/SP.pdf
--------------------------------------------------------------------------------
/day2/change-detection/pictures/SP.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/jstbcs/CognitiveModelingWorkshop/080db90e6745f28247a7829222982912e6f9b6dd/day2/change-detection/pictures/SP.png
--------------------------------------------------------------------------------
/day2/change-detection/pictures/rouder08.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/jstbcs/CognitiveModelingWorkshop/080db90e6745f28247a7829222982912e6f9b6dd/day2/change-detection/pictures/rouder08.png
--------------------------------------------------------------------------------
/day2/intro-to-bayes/metropolis-example.R:
--------------------------------------------------------------------------------
1 |
2 | # Example of the Metropolis algorithm
3 | # Estimating the mean of a normal distribution with known variance (15^2)
4 | # and a normal(mu_prior, sigma_prior) prior distribution on the mean
5 |
6 | #### FUNCTIONS ----
7 |
8 | metropolis_iq <- function(y, prior_mean, prior_sd, proposal_sd = 5, n_samples = 1000, start = 100){
9 | # metropolis algorithm for estimating the mean of a normal distribution
10 | # with a known variance (15 like iq tests) and a normal prior distribution on the mean
11 |
12 | samples = rep(NA, n_samples) # create a vector to store our samples
13 | current_mu = start # set the current value of mu to the starting value (set by user)
14 |
15 | for (i in 1:n_samples){ # do the samples
16 |
17 | samples[i] = current_mu # store the current value of mu
18 |
19 | proposed_mu = rnorm(n = 1, mean = current_mu, sd = proposal_sd) # sample a proposed value of mu
20 | # the proposal distribution is itself normal and is centered on the current value with a modifyable
21 | # standard deviation (which determines how much the chain can move around)
22 |
23 | # calculate the posterior probabilities for the current and proposed value of mu
24 | # we do things on the log scale to minimize problems due to rounding
25 | f_current = dnorm(x = current_mu, mean = prior_mean, sd = prior_sd, log = T) + sum(dnorm(x = y, mean = current_mu, sd = 15, log = T))
26 | f_proposed = dnorm(x = proposed_mu, mean = prior_mean, sd = prior_sd, log = T) + sum(dnorm(x = y, mean = proposed_mu, sd = 15, log = T))
27 |
28 | # take the ratio and thus the probability of accepting the proposed move
29 | # as we are working on the log scale we subtract rather then divide
30 | p_accept = exp(min(f_proposed - f_current, 0)) # same as min(f_proposed/f_current, 1) on natural scale
31 |
32 | if (runif(n = 1, min = 0, max = 1) < p_accept){
33 | # if the random uniform value is smaller than p_accept set the proposed mu
34 | # to the current mu for the next step
35 | current_mu = proposed_mu
36 | }
37 | }
38 | # return the vector of sampled values of mu
39 | return(samples)
40 | }
41 |
42 | posterior_quantities <- function(y, prior_mean, prior_sd, known_sd = 15){
43 | # for a normal likelihood with a known variance and normal prior on the mean
44 | # the posterior distribution is also normal
45 | # this function returns the mean and sd of the posterior distribution
46 | # for comparison with the results of the metropolis algorithm
47 |
48 | # details on the derivation can be found here: https://mcs.utm.utoronto.ca/~nosedal/sta313/sta313-normal-mean.pdf
49 | ybar = mean(y)
50 | n = length(y)
51 |
52 | prior_prec = 1/prior_sd^2
53 | lik_prec = n/known_sd^2
54 |
55 | post_prec = prior_prec + lik_prec
56 | post_sd = sqrt(1/post_prec)
57 |
58 | post_mu = prior_mean*(prior_prec/post_prec) + ybar*(lik_prec/post_prec)
59 |
60 | return(c(post_mu, post_sd))
61 | }
62 |
63 |
64 | #### START HERE ----
65 |
66 | N = 50 # number of observations in the group
67 | mu_real = 110 # the 'true' mean
68 |
69 | set.seed(123)
70 | Y = rnorm(N, mu_real, 15) # simulate data
71 | prior_m = 100
72 | prior_sd = 10
73 |
74 | # run the algorithm
75 | samples = metropolis_iq(y = Y, # data
76 | # set the first 2 arguments above
77 | prior_mean = prior_m, # prior mean on the unknown mean (mu) we are trying to estimate
78 | prior_sd = prior_sd, # prior standard deviation on mu
79 | proposal_sd = 5, # standard deviation of the proposal distribution
80 | n_samples = 1000, # number of samples from the posterior that we want
81 | start = 100) # starting value for mu
82 |
83 | # plot the steps in the chain
84 | plot(samples, xlab = "Step", ylab = bquote(mu), type="l", col="blue")
85 |
86 | # plot the histogram
87 | hist(samples, xlab = bquote(mu), main = paste0("N samples = ", length(samples)), col = "grey", breaks = 30, probability = T)
88 |
89 | # calculate the exact form of the posterior to compare to the samples
90 | post = posterior_quantities(y = Y, prior_mean = prior_m, prior_sd = prior_sd)
91 | curve(dnorm(x, mean = post[1], sd = post[2]), from = min(samples), to = max(samples), col = "red", lwd = 2, add = T)
92 |
93 | # run more samples to better approximate the posterior
94 |
95 | more_samples = metropolis_iq(y = Y,
96 | prior_mean = prior_m,
97 | prior_sd = prior_sd,
98 | proposal_sd = 5,
99 | n_samples = 10000, # instead of 1000
100 | start = 100)
101 |
102 | plot(more_samples, xlab = "Step", ylab = bquote(mu), type="l", col="blue")
103 |
104 | # plot the histogram
105 | hist(more_samples, xlab = bquote(mu), main = paste0("N samples = ", length(more_samples)), col = "grey", breaks = 30, probability = T)
106 | curve(dnorm(x, mean = post[1], sd = post[2]), from = min(samples), to = max(samples), col = "red", lwd = 2, add = T)
107 |
108 | # an example showing the need for burn in or warm up
109 |
110 | burn_samples = metropolis_iq(y = Y,
111 | prior_mean = prior_m,
112 | prior_sd = prior_sd,
113 | proposal_sd = 5,
114 | n_samples = 2000,
115 | start = 10)
116 |
117 | # the starting value can influence the first steps of the chain
118 | plot(burn_samples, xlab = "Step", ylab = bquote(mu), type="l", col="blue", main="before burn in")
119 |
120 | # so was can disgard some samples as a burn in period
121 | plot(x = 1001:2000, burn_samples[1001:2000], xlab = "Step", ylab = bquote(mu), type="l", col="blue", main = "after burn in")
122 |
123 | # an example of a chain with bad autocorrelation
124 |
125 | autocor_samples = metropolis_iq(y = Y,
126 | prior_mean = prior_m,
127 | prior_sd = prior_sd,
128 | proposal_sd = .25, # this means that each step in the chain will be smaller. Leading to more autocorrelation
129 | n_samples = 10000,
130 | start = 100)
131 |
132 | plot(autocor_samples, xlab = "Step", ylab = bquote(mu), type="l", col="blue", main="before thinning")
133 |
134 | K = 10 # what level of thinning should we use? We'll keep every K^th sample
135 | thin_samples = autocor_samples[seq(0, 10000, by = K)]
136 |
137 | plot(thin_samples, xlab = "Step", ylab = bquote(mu), type="l", col="blue", main="after thinning")
138 |
139 | coda::autocorr.plot(coda::as.mcmc(autocor_samples, main="before thinning"))
140 |
141 | coda::autocorr.plot(coda::as.mcmc(thin_samples, main="after thinning"))
142 |
143 |
--------------------------------------------------------------------------------
/day2/intro-to-bayes/rjags-basic-hier.R:
--------------------------------------------------------------------------------
1 |
2 | library(rjags)
3 | library(coda)
4 |
5 | # a basic hierarchical model where we estimate a mean for each participant
6 | # as coming from a population distribution of means
7 |
8 | #### SIMULATE DATA -----
9 |
10 | I = 30 # number of participants
11 | J = 10 # number of trials per participant
12 | N = I*J # number of observations
13 |
14 | set.seed(123)
15 | # sample the 'true' participant means from a normal
16 | # with a population mean of 700 and sd of 100
17 | mu_i = rnorm(I, 700, 100)
18 |
19 | # create the data frame to hold the simulated data
20 | hier_data = expand.grid(ppt = 1:I, trial = 1:J, y = NA)
21 | for (i in 1:I){
22 | y_i = rnorm(J, mu_i[i], 100) # generate the trials for this participant
23 | hier_data$y[hier_data$ppt == i] <- y_i # and add to the data frame
24 | }
25 |
26 | # observed participant means
27 | (xbars = aggregate(y ~ ppt, data = hier_data, FUN = mean))
28 |
29 | #### MODEL -----
30 |
31 | # JAGS model code for the basic hierarchical model
32 | model = "
33 | model {
34 | for (n in 1:N){
35 | # likelihood
36 | y[n] ~ dnorm(mu[id[n]], 1/sigma^2)
37 | }
38 | # sample participant parameters from population distribution
39 | for (i in 1:I){
40 | mu[i] ~ dnorm(m, 1/s^2)
41 | }
42 | # priors
43 | m ~ dnorm(800, 1/200^2)
44 | s ~ dgamma(2, .01)
45 | sigma ~ dgamma(2, .01) # a gamma prior on SD
46 | }
47 | "
48 |
49 | head(hier_data)
50 |
51 | # put the data into a list
52 | data_list = list(
53 | 'y' = hier_data$y,
54 | 'id' = hier_data$ppt, # participant id for each observation
55 | 'I' = length(unique(hier_data$ppt)), # number of participants
56 | 'N' = nrow(hier_data) # number of observations
57 | )
58 |
59 | # initialize the jags model
60 | jags <- jags.model(file = textConnection(model), data = data_list, n.chains = 4, n.adapt = 1000)
61 |
62 | # warm up the chains
63 | update(jags, 1000)
64 |
65 | samples = coda.samples(model = jags, variable.names = c("mu", "sigma", "m", "s"), n.iter = 1000)
66 |
67 | summary(samples)
68 |
69 | plot(samples[,"m"])
70 | plot(samples[,"s"])
71 | plot(samples[,"sigma"])
72 |
73 | gelman.diag(samples)
74 |
75 | # plot histogram of samples for some participants
76 | samples_matrix = as.matrix(samples) # convert mcmc.list into a matrix
77 |
78 | head(samples_matrix)
79 |
80 | plot_ids = sample(1:I, 8) # select 8 random participant numbers
81 |
82 | par(mfrow=c(4,2), mar=c(4,4,1,1)) # set layout for plots
83 | for (i in plot_ids){
84 | hist(samples_matrix[,paste0("mu[", i, ']')], main = paste0("ppt = ", i), xlab="", col="lightgreen")
85 | }
86 |
87 | # calculate crucial quantities of interest
88 | # posterior means (apply takes a matrix and applies a function to the rows [MARGIN=1] or columns [MARGIN=2])
89 | (post_m <- apply(samples_matrix, MARGIN = 2, FUN = mean))
90 | # posterior medians
91 | apply(samples_matrix, MARGIN = 2, FUN = median)
92 | # 95% credible intervals
93 | (post_cis <- apply(samples_matrix, MARGIN = 2, FUN = quantile, probs = c(.025, .975)))
94 |
95 | # you can also get this information via
96 | summary(samples)
97 |
98 | # lets plot the posterior means against the 'true' means
99 | post_m = post_m[2:31]
100 | post_cis = post_cis[,2:31]
101 |
102 | par(mfrow=c(1,1), mar=c(5,4,3,2)) # back to a 1 panel plot
103 |
104 | plot(x = mu_i, y = post_m, xlab="True", ylab="Estimated (95% CI)", main="True means vs estimated", pch=16, col="red")
105 | segments(x0 = mu_i, y0 = post_cis[1,], x1 = mu_i, y1 = post_cis[2,]) # error bars
106 | abline(0,1, lty=2, col="grey") # line of 1:1 correspondence
107 |
108 | # plot the posteriors against the sample means
109 | plot(x = xbars$y, y = post_m, xlab=bquote(bar(y)[i]), ylab="Estimated (95% CI)", main="Participant means vs estimated", pch=16, col="red")
110 | segments(x0 = xbars$y, y0 = post_cis[1,], x1 = xbars$y, y1 = post_cis[2,]) # error bars
111 | abline(0,1, lty=2, col="grey") # line of 1:1 correspondence
112 |
113 | ## Posterior predictive check
114 |
115 | hier_ppsamples <- function(m, s, sigma){
116 | # this function takes the hyperparameters from the above model
117 | # and generates new observations
118 | m_n = rnorm(length(m), m, s) # samples means from population distribution
119 |
120 | y_rep = rnorm(length(m), m_n, sigma) # generate new "data"
121 |
122 | return(y_rep)
123 | }
124 |
125 | pp_samples = hier_ppsamples(samples_matrix[,'m'], samples_matrix[,'s'], samples_matrix[,'sigma'])
126 |
127 | par(mfrow=c(1,2))
128 | hist(pp_samples, main="Posterior Predictive Samples", probability = T, xlab="y", breaks=30, col="lightblue")
129 |
130 | hist(hier_data$y, xlim=range(pp_samples), main="Data", xlab='y', col="lightgreen")
131 |
--------------------------------------------------------------------------------
/day2/intro-to-bayes/rjags-basics.R:
--------------------------------------------------------------------------------
1 |
2 | library(rjags)
3 | library(coda)
4 |
5 | set.seed(123)
6 | N = 100
7 | mu_real = 110
8 |
9 | Y = rnorm(N, mu_real, 15) # data
10 |
11 | data_list = list('y' = Y,
12 | 'N' = N)
13 |
14 | model = "
15 | model {
16 | for (i in 1:N){
17 | # likelihood
18 | y[i] ~ dnorm(mu, 1/15^2) # normal likelihood with known SD of 15
19 | }
20 | # prior
21 | mu ~ dnorm(prior_m, 1/prior_sd^2) # normal prior on mu
22 |
23 | prior_m <- 100
24 | prior_sd <- 10
25 | }
26 | "
27 |
28 | # create the JAGS model. n.adapt 'tunes' the samplers and don't contribute to the mcmc chains - rjags will warn you if n.adapt is too small
29 | jags <- jags.model(file = textConnection(model), data = data_list, n.chains = 4, n.adapt = 1000)
30 |
31 | update(jags, 1000) # warm up
32 |
33 | samples = coda.samples(model = jags, variable.names = "mu", n.iter = 1000)
34 |
35 | summary(samples)
36 |
37 | effectiveSize(samples)
38 |
39 | # look at the chains and the distribution of mu
40 | plot(samples)
41 |
42 | # look at convergence (Rhat) and autocorrelation
43 | gelman.diag(samples)
44 |
45 | par(mfrow=c(2,2))
46 | autocorr.plot(samples, auto.layout = F) # produces a plot for each chain
47 | par(mfrow=c(1,1))
48 |
49 |
50 | # suppose that we do not know the SD and want to estimate it as well
51 |
52 | # we need a new model specification (data stays the same)
53 |
54 | model2 = "
55 | model {
56 | for (i in 1:N){
57 | # likelihood
58 | y[i] ~ dnorm(mu, 1/sigma^2) # normal likelihood with known SD of 15
59 | }
60 | # prior
61 | mu ~ dnorm(100, 1/90^2) # normal prior on mu
62 | sigma ~ dgamma(1, .1) # a gamma prior on SD
63 | }
64 | "
65 |
66 | jags2 <- jags.model(file = textConnection(model2), data = data_list, n.chains = 4, n.adapt = 1000)
67 |
68 | update(jags2, 1000) # warm up
69 |
70 | samples2 = coda.samples(model = jags2, variable.names = c("mu", "sigma"), n.iter = 1000)
71 |
72 | plot(samples2)
73 | gelman.diag(samples2)
74 |
75 | par(mfcol=c(2,4))
76 | autocorr.plot(samples2, auto.layout = F)
77 | par(mfcol=c(1,1))
78 |
79 | # plot the joint posterior samples
80 | plot(as.matrix(samples2), col = 'grey', type='l')
81 |
82 |
83 |
84 |
85 |
--------------------------------------------------------------------------------
/gettingstarted.txt:
--------------------------------------------------------------------------------
1 | Getting started
2 | -----------------
3 |
4 | - Go to https://github.com/jstbcs/CognitiveModelingWorkshop
5 | - Clone or Download Button
6 | - Download zip
7 | - Unzip into a directory called CognitiveModelingWorkshop (or whatever you want)
8 | - Open R/RStudio
9 | - Set working directory to CognitiveModelingWorkshop using setwd("location-of-folder-on-your-computer/CognitiveModelingWorkshop") (or whatever you unzipped into)
10 | - You're ready!
11 |
12 |
13 |
--------------------------------------------------------------------------------
/mcpr-description.Rmd:
--------------------------------------------------------------------------------
1 | ---
2 | title: "Modeling Cognitive Processes in R"
3 | author: "Stephen Rhodes and Julia Haaf"
4 | date: "`r Sys.Date()`"
5 | output: pdf_document
6 | urlcolor: blue
7 | ---
8 |
9 | ```{r setup, include=FALSE}
10 | knitr::opts_chunk$set(echo = TRUE)
11 | ```
12 |
13 | ## General Description
14 |
15 | Cognitive process models provide a powerful tool to disentangle different cognitive processes contributing to the same observable responses. These models are successfully applied in many fields of psychology (e.g., memory, decision making, and social cognition). This two day workshop covers the essentials of cognitive modeling using the programming language `R`. Attendees will be introduced to several commonly used models in cognitive psychology and how to fit them using both maximum likelihood and hierarchical Bayesian methods.
16 |
17 | ## Prerequisites
18 |
19 | These are not absolutely required but would be useful:
20 |
21 | - Passing familiarity with the [`R` programming language](https://www.r-project.org/). You can find a free online introduction [here](https://www.datacamp.com/courses/free-introduction-to-r).
22 | - Familiarity with statistical concepts such as likelihood.
23 |
24 | ## Cognitive Process Models
25 |
26 | The workshop focusses mainly on the process models themselves --- we will apply *signal detection models* and *multinomial processing tree models*. The workshop is not suitable for participants who want to learn generally applicable statistical analysis in `R`. If you have questions about the workshop objectives, please contact [Julia](mailto:jmh4zc@mail.missouri.edu) or [Stephen](mailto:rhodessp@missouri.edu). An introduction to the main concepts of the workshop - maximum likelihood, multinomial process models, and signal detection theory - can be found [here (Chapters 2-4)](http://pcl.missouri.edu/jeff/sites/pcl.missouri.edu.jeff/files/b1_0.pdf)
27 |
28 | **Multinomial Processing Tree models** are useful for responses that fall into discrete categories (e.g. chose to buy product A, B, or C; voted for candidate W, X, Y, or Z; recognized a stimulus or not). They allow the researcher to model these observable responses as arising from different latent processes that form a tree-like structure [(see Erdfelder et al., 2009 for more background)](https://www.researchgate.net/profile/Morten_Moshagen/publication/220032645_Multinomial_processing_tree_models_A_review_of_the_literature/links/553e744b0cf210c0bdaaa5b9/Multinomial-processing-tree-models-A-review-of-the-literature.pdf).
29 |
30 | **Signal Detection Theory** offers a range of models to analyze data resulting from tasks requiring a choice between alternatives (e.g. is this stimulus old or new?). These models allow researchers to separate the participants' sensitivity (ability to do the task or discriminate between alternatives) from response bias (tendency to choose one of the options over the other).
31 |
32 | ## Workshop Outline
33 |
34 | The workshop will take place on **August 6th and 7th at the University of Missouri**. Tentatively we would start at 10/11 am on the 6th to allow for travel from WashU and go to 5/6 pm both days.
35 |
36 | Here's an outline of what we aim to cover on each day:
37 |
38 | #### Day 1
39 |
40 | *Morning*
41 |
42 | - Introduction to `R`:
43 | - basic commands
44 | - reading and restructuring data
45 | - installing packages
46 | - defining simple functions
47 | - graphing data
48 | - basic data simulation
49 |
50 | - Maximum Likelihood Estimation:
51 | - what is the likelihood function
52 | - how to define likelihood functions for models in `R`
53 | - searching for maximum likelihood estimates of models parameters
54 | - how to compare model fit via maximum likelihood
55 | - fitting to individual participants vs the group as a whole
56 | - potential pitfalls of maximum likelihood (e.g. avoiding local maxima)
57 |
58 | *Afternoon*
59 |
60 | - Fitting models to aggregate data:
61 | - A Multinomial Processing Tree (MPT) model for the process dissociation paradigm
62 | - A Signal Detection Theory (SDT) model for a recognition paradigm with confidence ratings
63 |
64 | #### Day 2
65 |
66 | *Morning*
67 |
68 | - Fitting models to individual participant data:
69 | - MPT example
70 | - SDT example
71 | - comparing model fit using AIC and BIC
72 | - conceptual issues in fitting models to individual participants
73 |
74 | *Afternoon*
75 |
76 | - Introduction to Bayesian Estimation of Cognitive Models:
77 | - The benefits of fitting hierarchical models (how to get group *and* individual estimates)
78 | - Using JAGS and the `rjags` package to fit MPT and SDT models
79 |
80 | **There will be time at the end of each day for attendees to ask questions regarding the modeling of their own data.**
81 |
82 | #### Potential Extra Topics
83 |
84 | - Reaction time models (e.g. drift diffusion)
85 |
86 | - Models for circular data (e.g. perception or memory tasks requiring reconstruction of an orientation)
87 |
88 | - "Does everyone" analyses (does every participant show an effect in the same direction?)
89 |
90 |
--------------------------------------------------------------------------------
/mcpr-description.pdf:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/jstbcs/CognitiveModelingWorkshop/080db90e6745f28247a7829222982912e6f9b6dd/mcpr-description.pdf
--------------------------------------------------------------------------------