### Supplemental Material

# "Improving confidence intervals for normed test scores: 
# Include uncertainty due to sampling variability"
# R code to compute CInorm with posterior simulation
# Authors: Voncken, Albers, and Timmerman
# doi: 10.3758/s13428-018-1122-8

# -----------------------------INITIALIZATION --------------------------------#
# Load R Packages =============================================================
#install.packages("gamlss")
library(gamlss)
#install.packages("foreign")
library(foreign); # for read.spss
#install.packages("MASS")
library(MASS) # for mvr.norm

# Importing Data ==============================================================
# Set the working directory!
owndata <- read.table("examplenormingdata.txt", header = TRUE)
normingdata <- data.frame(age = owndata$age, y = owndata$y) 
# normingdata$y <- normingdata$y + 0.0001 (if minimum score is 0)

# Choosing age and test score =================================================
# For which age value(s) and test score(s) do you want to compute CInorm?
# Example: 8-year-old with test score 9, and 10-year-old with test score 12.
chosenage <- c(8, 10) # age value(s)
chosenscore <- c(9, 12) # test score(s)

# Which confidence level do you want? =========================================
CIlevel <- 0.95 # 0.95 = CI95

# Some general settings =======================================================
set.seed(1234)
S <- 5000 # number of posterior simulations
n <- nrow(normingdata) # sample size, based on the provided data set

# ------------------------------ MODEL SELECTION -----------------------------#
# Used procedure: Free order automated model selection procedure, with the BIC 
# as selection criterion. See Voncken, Albers, and Timmerman (2017) for more 
# details about the procedure.

# ----------------------------- MODEL ESTIMATION -----------------------------#

mod <- {gamlss(y ~ poly(age, 4), sigma.formula = ~ 1, nu.formula = ~ 1, 
               tau.formula = ~ 1, family = BCPE, data = normingdata, method = RS(10000))}
#summary(mod)
centiles.fan(mod, xvar = normingdata$age, points = TRUE, cent = c(5, 10, 15, 25, 50, 75, 85, 90, 95), pch = 1, col = "black", colors = "gray", xlab = "Age", ylab = "Test score")


# ------------------ POSTERIOR SIMULATION (WOOD, 2006) -----------------------#
# Simulate from multivariate distribution =====================================
# Mean and variance-covariance matrix
means <- {c(mod$mu.coefficients, mod$sigma.coefficients, 
            mod$nu.coefficients, mod$tau.coefficients)} # means
Sigma <- vcov(mod) # covariance matrix of the estimated model parameters
 
mvr.sample <- mvrnorm(n = S, mu = means, Sigma = Sigma) 
# If Sigma not positive definite:
# - specify tolerance ("tol") in "mvrnorm()", or
# - use a transformation to force positive definiteness 

# Substract length model parameters ===========================================
l.mu <- length(mod$mu.coefficients)
l.sigma <- length(mod$mu.coefficients) + length(mod$sigma.coefficients)
l.nu <- {length(mod$mu.coefficients) + length(mod$sigma.coefficients) + 
    length(mod$nu.coefficients)}
l.tau <- {length(mod$mu.coefficients) + length(mod$sigma.coefficients) + 
    length(mod$nu.coefficients) + length(mod$tau.coefficients)}

# Predict mu, sigma, nu, and tau for simulated parameters =====================
newdata.mu <- cbind(rep(1, times = length(chosenage)), predict(poly(normingdata$age, 4), chosenage)) # polynomial of degree 4 of age
est.muvalues <- newdata.mu %*% t(mvr.sample[,(1:(l.mu))])

newdata.sigma <- cbind(rep(1, times = length(chosenage))) # intercept
est.sigmavalues <- exp(newdata.sigma %*% mvr.sample[,((l.mu+1):l.sigma)])

newdata.nu <- cbind(rep(1, times = length(chosenage))) # intercept
est.nuvalues <- newdata.nu %*% t(mvr.sample[,((l.sigma+1):l.nu)])

newdata.tau <- cbind(rep(1, times = length(chosenage))) # intercept
est.tauvalues <- exp(newdata.tau %*% t(mvr.sample[,(l.nu+1):l.tau]))



# Determine probabilities lower and upper bound CInorm ========================
prob1 <- (1-CIlevel)/2 # probability lower bound (LB) CI
prob2 <- 1-((1-CIlevel)/2) # probability upper bound (UB) CI

# Create matrix to store lower and upper bound percentiles CInorm =============
pCI.matrix <- matrix(NA, nrow = length(chosenscore), ncol = 2)
rownames(pCI.matrix) <- paste("score=",chosenscore,"|age=",chosenage, sep="")
colnames(pCI.matrix) <- c("LB", "UB")

# For each chosen age value: Determine, conditional on age, 
# for each simulated set of parameters the percentile corresponding 
# to the chosen test score ====================================================

# Determine percentile for each simulation
simulation.sample <- matrix(NA, ncol = length(chosenage), nrow = S)
for (l in 1:length(chosenage)){
  
  for (i in 1:S){
    simulation.sample[i, l] <- pBCPE(chosenscore[l], mu = est.muvalues[l, i], sigma = est.sigmavalues[l, i], nu = est.nuvalues[l, i], tau = est.tauvalues[l, i])
  }
  
  # Compute CInorm with the percentile CI method ================================
  pCI.matrix[l,] <- {c(quantile(simulation.sample[,l], probs = prob1), 
                       quantile(simulation.sample[,l], probs = prob2))}
}

# Store the results in a user-friendly matrix =================================
CInorm <- matrix(NA, nrow = length(chosenage), ncol = 1)
CInorm[,1] <-  {paste("[",round(as.vector(t(100*pCI.matrix[,"LB"])), 2),", ",
                      round(as.vector(t(100*pCI.matrix[,"UB"])), 2),"]", sep = "")}
rownames(CInorm) <- paste("score=",chosenscore,"|age=",chosenage, sep="")
colnames(CInorm) <- paste("CI", CIlevel*100, "norm", sep = "")
CInorm

# Interpretation of the results ===============================================
{paste("The estimated ",CIlevel*100,"% CInorm for someone of age ",chosenage[1],
       " with test score ",chosenscore[1]," is ",CInorm[1,1],".", sep = "")}
{paste("The estimated ",CIlevel*100,"% CInorm for someone of age ",chosenage[2],
       " with test score ",chosenscore[2]," is ",CInorm[2,1],".", sep = "")}