##############################################
# R-code for paper:
# Mahmood Ul Hassan, Frank Miller (2019). 
# Optimal item calibration for computerized achievement tests.
# Psychometrika to appear.
#   code uses R package nloptr V1.2.1 (check compatibility of later versions)
#
# Here: Calibration of ONE item (Section 3)
#
# This code leads to the optimal design for all scenarios with one item in the paper
##############################################

# load the library nloptr
require(nloptr)

# a=discrimination b=difficulty

# function to calculate criterion function
crit<-function(x,a,b){
  #a=discrimination b=difficulty
  xl<-x[1:2]
  xu<-x[3:4]
  n<-length(xl)
  f1<- function(x,a,b){(1/(1+exp(-a*(x-b))))*(1-(1/(1+exp(-a*(x-b)))))*((a^2/sqrt(2*pi))*exp(-x^2/2))}
  f2<- function(x,a,b){(1/(1+exp(-a*(x-b))))*(1-(1/(1+exp(-a*(x-b)))))*(((-a*(x-b))/sqrt(2*pi))*exp(-x^2/2))}
  f3<- function(x,a,b){(1/(1+exp(-a*(x-b))))*(1-(1/(1+exp(-a*(x-b)))))*((((x-b)^2)/sqrt(2*pi))*exp(-x^2/2))}
  M1<-matrix(0,2,2)
  for(i in 1:n){
    f11<-integrate(f1,a,b,lower=xl[i],upper=xu[i])
    f22<-integrate(f3,a,b,lower=xl[i],upper=xu[i])
    f12<-integrate(f2,a,b,lower=xl[i],upper=xu[i]) 
    M2<-matrix(c(f11$value,f12$value,f12$value,f22$value),2,2)
    M1<-M1+M2
  }
  -log(det(M1))
}

# equality constrains
heq<-function(x,a,b){
  h<-rep(NA,1)
  f1<- function(x){(1/sqrt(2*pi))*exp(-x^2/2)}
  f11<-integrate(f1,lower=x[1],upper=x[3])$value
  f22<-integrate(f1,lower=x[2],upper=x[4])$value
  h[1]<-f11+f22-A    # A=proportion of examinees population
  h
}

# inequality constrains
hin<-function(x,a,b){
  h<-rep(NA,3)
  h[1]<-x[3]-x[1]
  h[2]<-x[4]-x[2]
  h[3]<-x[2]-x[3]
  h
}

# define some function to make graph

# logistic model
FL<-function(theta = NULL, a = 1, b = 0) {
  #a=discrimination b=difficulity theta=ability 
  return(1/(1 + exp(-a*(theta-b))))
}

# directional derivative
sv<-function(z,a,b,ID){
  #a=discrimination b=difficulty theta=ability ID=information matrix
  z1<-c()
  for(i in 1:length(z)){
    k1<-c(-a,(z[i]-b))
    k2<-t(k1)
    k3<-k2%*%solve(ID)%*%k1
    k4=2-FL(z[i],a,b)*(1-FL(z[i],a,b))*k3
    z1[i]<-k4  
  }
  z1
}

# function to calculate information matrix using design
crit1<-function(x,a,b){
  #a=discrimination b=difficulty
  xl<-x[1:2]
  xu<-x[3:4]
  n<-length(xl)
  f1<- function(x,a,b){(1/(1+exp(-a*(x-b))))*(1-(1/(1+exp(-a*(x-b)))))*((a^2/sqrt(2*pi))*exp(-x^2/2))}
  f2<- function(x,a,b){(1/(1+exp(-a*(x-b))))*(1-(1/(1+exp(-a*(x-b)))))*(((-a*(x-b))/sqrt(2*pi))*exp(-x^2/2))}
  f3<- function(x,a,b){(1/(1+exp(-a*(x-b))))*(1-(1/(1+exp(-a*(x-b)))))*((((x-b)^2)/sqrt(2*pi))*exp(-x^2/2))}
  M1<-matrix(0,2,2)
  for(i in 1:n){
    f11<-integrate(f1,a,b,lower=xl[i],upper=xu[i])
    f22<-integrate(f3,a,b,lower=xl[i],upper=xu[i])
    f12<-integrate(f2,a,b,lower=xl[i],upper=xu[i]) 
    M2<-matrix(c(f11$value,f12$value,f12$value,f22$value),2,2)
    M1<-M1+M2
  }
  M1
}

# function to calculate information matrix 
crit2<-function(a,b){
  f1<- function(x,a,b){(1/(1+exp(-a*(x-b))))*(1-(1/(1+exp(-a*(x-b)))))*((a^2/sqrt(2*pi))*exp(-x^2/2))}
  f2<- function(x,a,b){(1/(1+exp(-a*(x-b))))*(1-(1/(1+exp(-a*(x-b)))))*(((-a*(x-b))/sqrt(2*pi))*exp(-x^2/2))}
  f3<- function(x,a,b){(1/(1+exp(-a*(x-b))))*(1-(1/(1+exp(-a*(x-b)))))*((((x-b)^2)/sqrt(2*pi))*exp(-x^2/2))}
  
  f11<-integrate(f1,a,b,lower=-Inf,upper=Inf)
  f22<-integrate(f3,a,b,lower=-Inf,upper=Inf)
  f12<-integrate(f2,a,b,lower=-Inf,upper=Inf) 
  M1<-matrix(c(f11$value,f12$value,f12$value,f22$value),2,2)
  M1
}

# function to calculate difference from unrestricted design point for boundaries of symmetrical design
f <- function(a, thetaunres, prob)
{
  pnorm(thetaunres+a)-pnorm(thetaunres-a)-prob
}

# function to calculate symmetrical design 
sydesign<-function(a,b, prob){
  
  y1<-b-(1.5434/a) 
  y2<-b+(1.5434/a)
  thetaunres<-c(y1,y2)
  
  delta1 <- uniroot(f, c(0,3), thetaunres=thetaunres[1], prob=prob,tol= 0.000000000000000001)$root 
  delta2 <- uniroot(f, c(0,3), thetaunres=thetaunres[2], prob=prob,tol= 0.000000000000000001)$root  
  
  z<-c(y1-delta1, y2-delta2, y1+delta1, y2+delta2) 
  z
}

# function to calculate the efficiency of restricted design compare to random and symmetrical design
effd<-function(a,b,A,x,y){
  # a,b= Item parameters value
  # A= Proportion of population 
  # x= restricted optimal design
  # y= symmetrical design
  
  # information matrix of symmetrical design
  m1<-crit1(y,a,b)
  # information matrix of random design
  m2<-crit2(a,b)*A
  # information matrix of restricted design
  m3<-crit1(x,a,b)
  
  # efficiency of symmetrical design compared to restricted optimal design
  RE<-(det(m1)/det(m3))^(1/2)
    # if the intervals in the symmetrical design are overlapping, this design is not possible and the efficiency calculation incorrect
    if (y[3]>y[2])  RE <- NA
  SRE<-((1/RE)-1)*100

  # efficiency of random design compared to restricted optimal design
  RE1<-(det(m2)/det(m3))^(1/2)
  SRE1<-((1/RE1)-1)*100
  
  w<-data.frame(rbind(RE,RE1),rbind(SRE,SRE1))
  row.names(w)<-c("Symmetrical design","Random design")
  colnames(w)<-c("RE","Sample size gain ")
  w
}


#########################################################################################################
# Choose item parameter values and proportion of population 
# a and b= Guess values for item paramters (a=discrimination, b=difficulty)
# A= proportion of examinees population  (in publication called s)

# calibration of Item 1
#a=1;b=0.5;A=0.1

# calibration of Item 2
#a=1.5;b=-1.2;A=0.25

# calibration of Item 3
a=1.6;b=2;A=0.35


# starting values for interval boundaries; might to be adjusted in specific cases 
y<-c(-0.5,1,0.5,2) 

opdes<-suppressWarnings(slsqp(y,fn=crit,lower=rep(-7,length(y)),upper=rep(7,length(y)),heq=heq,hin=hin,a=a,b=b,
           control =list(stopval=-Inf, xtol_rel = 1e-99, maxeval = 1000)))
x<-opdes$par

z<-c(x[1],x[3],x[2],x[4])

# optimal unrestricted design points
y1<-b-(1.5434/a) 
y2<-b+(1.5434/a)

par(mfrow=c(3,1), oma=c(1,1,0,1), mar=c(1,4.5,0.5,0)) #for combined graph
x00<- seq(-7,7,length=1001)
y00<-FL(theta=x00,a=a,b=b)
plot(x00,y00,type="l",lwd=2,xaxt = "n",axes=FALSE,ylim=c(0.03,1),ylab="Probability of a correct response",xlab="Ability",cex.lab=1.7)
text(0.02,0.02,labels="Ability",cex.lab=1.7)
axis(side=2,cex.axis=1.7)
axis(side=1,tick=TRUE,labels = FALSE,at=seq(-7,7, by=1)) 


# add centre line in logistic curve
x0<- c(y1,y2)
y0<-FL(theta=x0,a=a,b=b)
segments(x0,-0.05,x0,y0,col="blue",lwd=2)


# plot for normal distribution
x11<- seq(-7,7,length=1001)
y11<- dnorm(x11)
plot(x11,y11,type="l",lwd=1,axes=FALSE,ylab="",xlab="")
text(0,0,labels="")
axis(side=1,tick=TRUE,labels = FALSE,at=seq(-7,7, by=1))


# add highlighted area in normal curve
cord.x1 <- c(z[1],seq(z[1],z[2],0.01),z[2]) 
cord.y1 <- c(-0.02,dnorm(seq(z[1],z[2],0.01)),-0.02) 
polygon(cord.x1,cord.y1,col='skyblue')

cord.x1 <- c(z[3],seq(z[3],z[4],0.01),z[4]) 
cord.y1 <- c(-0.02,dnorm(seq(z[3],z[4],0.01)),-0.02) 
polygon(cord.x1,cord.y1,col='skyblue')


# plot of directional derivative
ID<-crit1(x,a,b)
z0<-seq(-7,7,length=1001)
z1<-sv(z0,a,b,ID)
plot(z0,z1,type="l",axes=FALSE,xlab="",ylab="Directional derivative",col="black",
     ylim=c(min(z1),2),cex.lab=1.7,frame.plot = FALSE)

x1<-sv(z,a,b,ID)
points(z,x1,col="black",pch=19,cex=1.7)
p2<-sv(z,a,b,ID)
# determine constant c which separates sampling from non-sampling area
if (z[3]-z[2]>0.00001) cs<-p2[2] else { 
  if (abs(z[1])<abs(z[4])) cs<-p2[1] else cs<-p2[4] 
}
abline(h=cs, col = "blue")
axis(side=2,cex.axis=1.7)
axis(side=1,tick=TRUE,cex.axis=1,labels=TRUE,at=seq(-7,7, by=1)) 


# calcultion of symmetrical design
sy<-sydesign(a,b,A/2)

# calculate the relative efficiency of design
effd(a,b,A,x,sy)