Polytomous Rasch Model (Generalized Partial Credit Model)

# The Polytomous Rasch Model (prm) allows for items to receive credit or value that is polytomous (more values than just full credit or no credit).

# The prm is related to the generalized graded response model discussed in a previous post (http://www.econometricsbysimulation.com/2012/10/generalized-graded-response-data.html).

# The prm category characteristic curve is given by: P(x=k) = exp(sum{v=1 to k} D*a_i(theta-b_iv)) / sum{h= 1 to m} exp(sum{v=1 to h} D*a_i(theta-b_iv))

# Where k is the credit value, D is 1.7, a is the discriminatory power of this item, b_iv is the difficulty of this particular grade, k = 1 , 2, ... m.  Theta is the ability level of the test taker.

# Let's first write a function that generates the numerator.

numerator <- function(a, b, theta, k, D=1.7) exp(sum(D*a*(theta-b[1:k])))

denominator <- function(a, b, theta, D=1.7) {
  sumval <- 0
  for (i in 1:length(b)) sumval <- sumval + numerator(a,b,theta,i,D)
  return(sumval)
}
denominator(1,c(1,2,3),theta=2)

# Category characteristic curve
prm <- function(a, b, theta, k, D=1.7) numerator(a, b, theta, k, D)/denominator(a, b, theta, D)

prm(1,c(1,2,3),1,1)

# Now let's create a cumulative probability function
cprm <- function(a, b, theta, D=1.7) {
  ncat = length(b)
  p=1
  for (i in 1:ncat) p[i]<- prm(a,b,theta,i,D)
  pmf = p
  for (i in 1:ncat) pmf[1:ncat>i]<-pmf[1:ncat>i]+p[i]
  return(pmf)
}
cprm(1,c(1,2,3),1,1)

# To generate a random score value from any cprm, we only need draw a random uniform and count how many times the random uniform is greater than the category.

sum(cprm(1,c(1,2,3),1)
# Let's try with:
a = 1.4902
b = c(0, -1.2248, -0.7039,  -0.2333)
  # It turns out the first b does not matter what the value is.

#  If we wanted to draw an item for a group of individuals with thetas equal to
theta = c(1,2,3,4,1,1,2,2,1,1,0,-9,-1,-2,-3,2)
for (v in theta) print(paste("Theta=", v, "; Score=", sum(cprm(a,b,v)