**Econometrics by Simulation**, and kindly contributed to R-bloggers)

# Reckase (2003) proposes a method for designing an item pool for a computer

# adaptive test that has been known as the bin and union method. This method

# involves drawing a subject from a distribution of abilities. Then selecting

# the item that maximizes that subject's information from the possible set of

# all items given a standard CAT proceedure. This is repeated until the test

# reaches the predifined stopping point.

# Then then next subject is drawn and a new set of items is drawn. Items are

# divided into bins such that there is a kind of rounding. Items which are

# sufficiently close to other items it terms of parameter fit are considered

# the same item and the two sets are unionized together into a larger pool.

# As more subjects are added more items are collected though at a decreasing

# rate as fewer new items become neccessary.

# In the original paper he uses a fixed length test though in a forthcoming

# paper he and his student Wei He is also using a variable length test.

# I have modified his proceedure slightly in this simulation. Rather than

# selecting optimal items for each subject based from the continuous pool

# of possible items I have the test look within the already constructed pool

# to see if any items are within bin length of the subject's estimated ability.

# If there is no item then I add an item that perfectly matches the subject's

# estimated ability. The reason I prefer this method is that I think it better

# represents the process that a CAT test typically must go through with items

# close to but rarely exactly at the level of the subjects. Thus the information

# for each subject will be slightly less as a result of this modified method

# relative to the original.

# As with the new paper this simulation uses a variable length test. My stopping

# rule is simple. Once the test achieves a sufficiently high level of

# information, then it stops.

# I have constructed this simulation as one with three nested loops.

# Over subjects within the item pool construction.

# It simulates the item pool construction a number of times to get the

# average number of items after each subject as well as a histogram

# of average number of items required at each difficulty level.

# I have also included a control for item exposure. This control

# dicatates that as the acceptable exposure rate is reduced, more items

# will be required since some are too frequently exposed.

# Overall this method is seems pretty great to me. It allows for

# item selection criteria, stopping rules, and exposure controls

# to be easily modified to accomidate most any CAT design.

require("catR")

# Variable Length Test

# The number of times to repeat the simulation

nsim <- 10

# The number of subjects to simulate

npop <- 1000

# The maximum number of items

max.items <- 5000

# Maximum exposure rate of individual item

max.exposure <- .2

# Stop the test when information reaches this level

min.information <- 10

# How far away will the program reach for a new item (b-b_ideal)

bin.width <- .25

expect.a <- 1

p <- function(theta, b) exp(theta-b)/(1+exp(theta-b))

info <- function(theta, b, a=expect.a) p(theta,b)*(1-p(theta,b))*a^2

info(0,0)

# The choose.item funciton takes an input thetahat and searches

# available items to see if any already exist that can be used

# otherwise it finds a new item.

choose.item <- function(thetahat, item.b, items.unavailable, bin.width) {

# Construct a vector of indexes of available items

avail.n <- (1:length(item.b))

# Remove any already make unusuable

if (length(items.unavailable)>0)

avail.n <- (1:length(item.b))[-items.unavailable]

# If there are no items available then generate the next item

# equal to thetaest.

if (length(avail.n)==0)

return(c(next.b=thetahat, next.n=length(item.b)+1))

# Figure out how far each item is from thetahat

avail.dist <- abs(item.b[avail.n]-thetahat)

# Reorder the n's and dist in terms of proximity

avail.n <- avail.n[order(avail.dist)]

avail.dist <- sort(avail.dist)

# If the closest item is within the bin width return it

if (avail.dist[1])

return(c(next.b=item.b[avail.n[1]], next.n=avail.n[1]))

# Otherwise generate a new item

if (avail.dist[1]>=bin.width)

return(c(next.b=thetahat, next.n=length(item.b)+1))

}

# Define the simulation level vectors which will become matrices

Tnitems <- Ttest.length <- Titems.taken.N <- Titem.b<- NULL

# Loop through the number of simulations

for (j in 1:nsim) {

# Seems to be working well

choose.item(3, c(0,4,2,2,3.3), NULL, .5)

# This is the initial item pool

item.b <- 0

# This is the initial number of items taken

items.taken.N <- rep(0,max.items)

# A vector to record the individual test lengths

test.length <- NULL

# Number of total items after each individual

nitems <- NULL

# Draw theta from a population distribution

theta.pop <- rnorm(npop)

# Start the individual test

for (i in 1:npop) {

# The this person has a theta of:

theta0 <- theta.pop[i]

# Our initial guess at theta = 0

thetahat <- 0

print(paste("Subject:", i,"- Item Pool:", length(item.b)))

response <- items.taken <- NULL

# Remove any items that would have been overexposed

items.unavailable <- (1:length(item.b))[!(items.taken.N < max.exposure*npop)]

# The initial imformation on each subject is zero

infosum <- 0

# Loop through each subject

while(infosum < min.information) {

chooser <- choose.item(thetahat, item.b, items.unavailable, bin.width)

nextitem <- chooser[2]

nextb <- chooser[1]

names(nextitem) <- names(nextb) <- NULL

items.unavailable <- c(items.unavailable,nextitem)

item.b[nextitem] <- nextb

response <- c(response, runif(1)(theta0, nextb))

items.taken <- c(items.taken, nextitem)

it <- cbind(1, item.b[items.taken], 0,1)

thetahat <- thetaEst(it, response)

infosum <- infosum+info(theta0, nextb)

}

# Save individual values

nitems <- c(nitems, length(item.b))

test.length <- c(test.length, length(response))

items.taken.N[items.taken] <- items.taken.N[items.taken]+1

}

# Save into matrices the results of each simulation

Titem.b <- c(Titem.b, sort(item.b))

Tnitems <- cbind(Tnitems, nitems)

Ttest.length <- cbind(Ttest.length, test.length)

Titems.taken.N <- cbind(Titems.taken.N, items.taken.N)

}

plot(apply(Tnitems, 1, max), type="n",

xlab = "N subjects", ylab = "N items",

main = paste(nsim, "Different Simulations"))

for (i in 1:nsim) lines(Tnitems[,i], col=grey(.3+.6*i/nsim))

# We can see that the number of items is a function of the number of

# subjects taking the exam. This relationship becomes relaxed

# when the number of subjects becomes large and the exposure controls

# are removed.

hist(Titem.b, breaks=30)

hist(Ttest.length, breaks=20)

**leave a comment**for the author, please follow the link and comment on their blog:

**Econometrics by Simulation**.

R-bloggers.com offers

**daily e-mail updates**about R news and tutorials on topics such as: Data science, Big Data, R jobs, visualization (ggplot2, Boxplots, maps, animation), programming (RStudio, Sweave, LaTeX, SQL, Eclipse, git, hadoop, Web Scraping) statistics (regression, PCA, time series, trading) and more...