####################################################################################################### ### OPTIC - OPImal Item Calibration ### Computation of optimal calibration design for Swedish national tests åk 6 in mathematics 2022 ### Models implemented: ### Rasch model (discrimination assumed to be known), 2PL, 3PL, and GPCM (for 2-point item, only) ### Version 1.8.5 - 2024-03-10 ### Supplementary material for publication: ### PARALLEL OPTIMAL CALIBRATION OF MIXED-FORMAT ITEMS FOR ACHIEVEMENT TESTS. Psychometrika. ####################################################################################################### # INSTRUCTIONS: Run first all functions until ### Preprocessing # From there, run only selected parts for the model/setting of choice, see the instructions there! # Partial information values generation for all models (currently, for Rasch, 2PL, 3PL, and GPCM (2-point)) # Note: factor after dnorm(x) is number of categories which belongs to infomation matrix. If only items with same number of categories # belong to test, the factor can be neglected for computing optimal designs. pinf <- function(ip, ity, V){ a <- ip[, 1] b <- ip[, 2] c <- ip[, 3] I <- length(b) # Interval boundaries for versions (first at -Inf, last at Inf (problems for 3PL, therefore replaced by 4)) z <- c(-Inf, qnorm(1:(V-1)/V), 4) # integration function for Rasch fr <- function(x, b) { 1/(1+exp(-x+b)) * (1-1/(1+exp(-x+b))) * dnorm(x)*2 } # integration functions for 2PL f11 <- function(x, a, b) { (1/(1+exp(-a*(x-b)))) * (1-(1/(1+exp(-a*(x-b))))) * ((x-b)^2) * dnorm(x)*1 } f12 <- function(x, a, b) { (1/(1+exp(-a*(x-b)))) * (1-(1/(1+exp(-a*(x-b))))) * (-a*(x-b)) * dnorm(x)*1 } f22 <- function(x, a, b) { (1/(1+exp(-a*(x-b)))) * (1-(1/(1+exp(-a*(x-b))))) * a^2 * dnorm(x)*1 } # integration functions for 3PL f <- function(x, a, b, c) { (c+(1-c)*(1/(1+exp(-a*(x-b))))) * (1-(c+(1-c)*(1/(1+exp(-a*(x-b)))))) * dnorm(x)*1 } fA <- function(x, a, b, c) { (x-b) * ((exp(a*(x-b))) / (c + exp(a*(x-b)))) } fB <- function(x, a, b, c) { (-a*(exp(a*(x-b)))) / (c + exp(a*(x-b))) } fC <- function(x, a, b, c) { (1+(exp(a*(x-b)))) / ((1-c) * (c + exp(a*(x-b)))) } a11 <- function(x, a, b, c) { f(x, a, b, c) * (fA(x, a, b, c))^2 } a12 <- function(x, a, b, c) { f(x, a, b, c) * fA(x, a, b, c) * fB(x, a, b, c) } a13 <- function(x, a, b, c) { f(x, a, b, c) * fA(x, a, b, c) * fC(x, a, b, c) } a22 <- function(x, a, b, c) { f(x, a, b, c) * (fB(x, a, b, c))^2 } a23 <- function(x, a, b, c) { f(x, a, b, c) * fB(x, a, b, c) * fC(x, a, b, c) } a33 <- function(x, a, b, c) { f(x, a, b, c) * (fC(x, a, b, c))^2 } # integration functions for GP2 (a=discrimination, parameters d1 and d2 belong to parametrisation a*i*theta+d_i) pi1 <- function(x, a, d1, d2) { exp(a*x+d1)/(1+exp(a*x+d1)+exp(a*2*x+d2)) } pi2 <- function(x, a, d1, d2) { exp(a*2*x+d2)/(1+exp(a*x+d1)+exp(a*2*x+d2)) } g11 <- function(x, a, d1, d2) { x^2*(pi1(x, a, d1, d2)+4*pi2(x, a, d1, d2)-(pi1(x, a, d1, d2)+2*pi2(x, a, d1, d2))^2) * dnorm(x)*2 } g12 <- function(x, a, d1, d2) { x*(pi1(x, a, d1, d2)-pi1(x, a, d1, d2)*(pi1(x, a, d1, d2)+2*pi2(x, a, d1, d2))) * dnorm(x)*2 } g13 <- function(x, a, d1, d2) { x*(2*pi2(x, a, d1, d2)-pi2(x, a, d1, d2)*(pi1(x, a, d1, d2)+2*pi2(x, a, d1, d2))) * dnorm(x)*2 } g22 <- function(x, a, d1, d2) { pi1(x, a, d1, d2)*(1-pi1(x, a, d1, d2)) * dnorm(x)*2 } g23 <- function(x, a, d1, d2) { -pi1(x, a, d1, d2)*pi2(x, a, d1, d2) * dnorm(x)*2 } g33 <- function(x, a, d1, d2) { pi2(x, a, d1, d2)*(1-pi2(x, a, d1, d2)) * dnorm(x)*2 } piv11 <- piv12 <- piv13 <- piv22 <- piv23 <- piv33 <- matrix(rep(0, I*V), ncol=V) for (i in 1:I){ for (v in 1:V){ if (ity[i]=="1PL"){ piv11[i, v] <- integrate(fr, b=b[i], lower=z[v], upper=z[v+1])$value # Note: other piv-matrices are imputed as 0s for faster handling in ocrit function } if (ity[i]=="2PL"){ piv11[i, v] <- integrate(f11, a=a[i], b=b[i], lower=z[v], upper=z[v+1])$value piv12[i, v] <- integrate(f12, a=a[i], b=b[i], lower=z[v], upper=z[v+1])$value piv22[i, v] <- integrate(f22, a=a[i], b=b[i], lower=z[v], upper=z[v+1])$value } if (ity[i]=="3PL"){ piv11[i, v] <- integrate(a11, a=a[i], b=b[i], c=c[i], lower=z[v], upper=z[v+1])$value piv12[i, v] <- integrate(a12, a=a[i], b=b[i], c=c[i], lower=z[v], upper=z[v+1])$value piv13[i, v] <- integrate(a13, a=a[i], b=b[i], c=c[i], lower=z[v], upper=z[v+1])$value piv22[i, v] <- integrate(a22, a=a[i], b=b[i], c=c[i], lower=z[v], upper=z[v+1])$value piv23[i, v] <- integrate(a23, a=a[i], b=b[i], c=c[i], lower=z[v], upper=z[v+1])$value piv33[i, v] <- integrate(a33, a=a[i], b=b[i], c=c[i], lower=z[v], upper=z[v+1])$value } if (ity[i]=="GP2"){ # check carefully how your model used for obtaining guessed values is parametrisised; # we assume that 1, exp(a*(theta-b1)), exp(a*(2*theta-b1-b2)) was used for the guessed item parameters, # but in this optic program, we use parametrisation 1, exp(a*theta+d1), exp(a*2*theta+d2) for optimisation; # therefore the re-parametrisation from b=b1 and c=b2 to d1 and d2 below piv11[i, v] <- integrate(g11, a=a[i], d1=-a[i]*b[i], d2=-a[i]*(b[i]+c[i]), lower=z[v], upper=z[v+1])$value piv12[i, v] <- integrate(g12, a=a[i], d1=-a[i]*b[i], d2=-a[i]*(b[i]+c[i]), lower=z[v], upper=z[v+1])$value piv13[i, v] <- integrate(g13, a=a[i], d1=-a[i]*b[i], d2=-a[i]*(b[i]+c[i]), lower=z[v], upper=z[v+1])$value piv22[i, v] <- integrate(g22, a=a[i], d1=-a[i]*b[i], d2=-a[i]*(b[i]+c[i]), lower=z[v], upper=z[v+1])$value piv23[i, v] <- integrate(g23, a=a[i], d1=-a[i]*b[i], d2=-a[i]*(b[i]+c[i]), lower=z[v], upper=z[v+1])$value piv33[i, v] <- integrate(g33, a=a[i], d1=-a[i]*b[i], d2=-a[i]*(b[i]+c[i]), lower=z[v], upper=z[v+1])$value } } } list(v11=piv11, v12=piv12, v13=piv13, v22=piv22, v23=piv23, v33=piv33) } # computes the D- or A-criterion value for design des ocrit <- function(piv, ity, des, oc="D", eachitem=FALSE, eachpar=FALSE){ # item information values iiv11 <- rowSums(des*piv$v11) iiv12 <- rowSums(des*piv$v12) iiv13 <- rowSums(des*piv$v13) iiv22 <- rowSums(des*piv$v22) iiv23 <- rowSums(des*piv$v23) iiv33 <- rowSums(des*piv$v33) # imputation which do not change D- and A-optimality iiv22[(ity=="1PL")] <- 1 iiv33[(ity=="1PL" | ity=="2PL")] <- 1 # item criterion values (D-optimality) if (oc=="D") icv <- iiv11*iiv22*iiv33+2*iiv12*iiv23*iiv13-iiv11*iiv23^2-iiv22*iiv13^2-iiv33*iiv12^2 # faster than using det-function if (oc=="A") icv <- iiv11+iiv22+iiv33 icv1 <- icv*(icv>0)+(1e-30)*(icv<=0) # to handle numerical instabilities which lead to det<0 if (eachpar) res <- cbind(iiv11, iiv22, iiv33) else { if (eachitem) res <- log(icv1) else res <- sum(log(icv1)) } res } # computes the D- or A-criterion value with random allocation of items to examinees # each item will be allocated with proportion/probability 'prop' to each examinee; the value prop need to be # chosen sensibly outside of this function. If a fixed number of items S per version is required, prob=S/I is meaningful. ocritrand <- function(piv, ity, oc="D", eachitem=FALSE, eachpar=FALSE, prop){ # item information values iiv11 <- prop * rowSums(piv$v11) iiv12 <- prop * rowSums(piv$v12) iiv13 <- prop * rowSums(piv$v13) iiv22 <- prop * rowSums(piv$v22) iiv23 <- prop * rowSums(piv$v23) iiv33 <- prop * rowSums(piv$v33) # imputation which do not change D- and A-optimality iiv22[(ity=="1PL")] <- 1 iiv33[(ity=="1PL" | ity=="2PL")] <- 1 # item criterion values (D-optimality) if (oc=="D") icv <- iiv11*iiv22*iiv33+2*iiv12*iiv23*iiv13-iiv11*iiv23^2-iiv22*iiv13^2-iiv33*iiv12^2 # faster than using det-function if (oc=="A") icv <- iiv11+iiv22+iiv33 icv1 <- icv*(icv>0)+(1e-30)*(icv<=0) # to handle numerical instabilities which lead to det<0 if (eachpar) res <- cbind(iiv11, iiv22, iiv33) else { if (eachitem) res <- log(icv1) else res <- sum(log(icv1)) } res } # penalty function for too long time in versions penalty <- function(des, iti, ttt){ timediff <- iti %*% des - ttt[1] accepttime <- ttt[2]-ttt[1] mean(timediff*(timediff>0) + timediff^2*(timediff>accepttime)) } # create a design matrix from a design sequence (used for startdesign) createdm <- function(ds, I, S){ V <- length(ds) design <- matrix(rep(0, I*V), ncol=V) for (v in 1:length(ds)){ design[ds[v]:(ds[v]+S-1), v] <- 1 } design } # Plot D-optimal design; three different styles (types) plotdes <- function(ity, des, xtext="Version", ytext="Item", type=1){ V <- dim(des)[2] I <- dim(des)[1] plot(c(0, V+1), c(0, I+1), type="n", xlab=xtext, ylab=ytext, las=1) for (i in 1:I){ for (v in 1:V){ if (type==1){ pchv <- 1 cexv <- 1 } if (type==2){ pchv <- des[i, v]*(1*(ity[i]=="2PL")+16*(ity[i]=="3PL")+16*(ity[i]=="GP2")) cexv <- des[i, v]*((ity[i]=="2PL")+1.1*(ity[i]=="3PL")+0.6*(ity[i]=="GP2")) } if (type==3){ pchv <- des[i, v]*(2*(ity[i]=="2PL")+3*(ity[i]=="3PL")+4*(ity[i]=="GP2")) cexv <- 1 } points(v, i, col=des[i, v]*(1+(ity[i]=="2PL")+2*(ity[i]=="3PL")+3*(ity[i]=="GP2")), pch=pchv, cex=cexv, lwd=2) } } NULL } # create startdesign respecting item groups startdesign <- function(V, S, iig){ I <- length(iig) G <- max(iig) startdes <- matrix(rep(0, I*V), ncol=V) while (min(rowSums(startdes))==0){ startdes <- matrix(rep(0, I*V), ncol=V) for (v in 1:V){ addgroups <- sample(1:G, S) for (g in addgroups){ startdes[iig==g, v] <- 1 } } } startdes } ### Optimisation with simulated annealing algorithm # des = starting design for the algorithm, IxV-matrix of 0's and 1's fulfilling requirement of S 1's per version (column) # ip = item parameters (first column=discrimination, second column=difficulties, in Rasch or 2PL model) # ity = item type vector ("1PL", "2PL", "3PL", "GP2" (GPCM with 2 points) are possible) # iig = group number for items; iig=0 (default) means non-existence of item groups # iti = estimated time in minutes needed for item; iti=0 (default) requires a fixed number of items S in each version # ttt = target time for test in minutes (ideal value, upper bound) # pf = penalty factor, for longer duration of single versions than the allowed ttt[1] # oc = optimality criterion, either "D" or "A" ### technical parameters for simulated annealing algorithm # temp = starting temperature # cooling = cooling factor from one outer iteration to the next, needs to be between 0 and 1, cooling^(oin-1) is the temperature in the final outer iteration # oin = number of outer iterations (with decreasing temperature); the corresponding parameter is called tmax in the optim-function # iin = number of inner iterations (with constant temperature) ### simann <- function(des, ip, ity, iig=0, iti=0, pf=1, ttt=c(60, 69), oc="D", temp=1, cooling=0.84, oin=50, iin=100000){ V <- dim(des)[2] I <- dim(des)[1] if (iig[1]==0) iig <- 1:I # default is that no item groups exist and no item requires that another specific item is included in the version as well if (iti[1]==0){ iti <- rep(1, I); ttt <- c(S, S) } # default is that each version has S items, exactly iigm <- c(0, iig[1:I-1]) iigs <- (1:I)[iig>iigm] # intem numbers where a new group starts (usually, part a of problems) G <- length(iigs) # number of item groups # IxV-matrix with partial information values: piv <- pinf(ip, ity, V) # sample new candidate design sequence in the neighbourhood of ds gold <- ocrit(piv, ity, des, oc=oc) - pf * penalty(des, iti, ttt) tds <- des plotdes(ity, tds) title("Starting design") ctemp <- temp for (oiter in 1:oin){ chco <- 0 # change counter chcod <- 0 # change counter for double change for (iiter in 1:iin){ ve <- sample(1:V, 1) # Version for first exchange groupind <- tds[iigs, ve] ir <- sample(1:G, 2, prob=groupind) # Item group(s) to be removed from first version ia <- sample(1:G, 2, prob=(1-groupind)) # Item group(s) to be added to first version # cds removes 1 and adds 1 item group; cds12 removes 1 and adds 2 item groups; cds21 removes 2 and adds 1 item group # cds is first choice; cds12, cds21 are used instead if their time closer to target time than cds cds <- tds cds[iig==ir[1], ve] <- 0 cds[iig==ia[1], ve] <- 1 cds12 <- cds21 <- cds cds21[iig==ir[2], ve] <- 0 cds12[iig==ia[2], ve] <- 1 tt <- sum(cds[, ve] * iti) tt21 <- sum(cds21[, ve] * iti) tt12 <- sum(cds12[, ve] * iti) if (abs(tt-ttt[1])>abs(tt21-ttt[1]) || tt>ttt[2]){ cds <- cds21 tt <- tt21 } if (abs(tt-ttt[1])>abs(tt12-ttt[1]) && tt120){ vs <- sample(1:V, 1, prob=prve) # Version for second exchange (where item groups are exchanged back) cdsd <- cds cdsd[iig==ia[1], vs] <- 0 cdsd[iig==ir[1], vs] <- 1 cdsd12 <- cdsd21 <- cdsd groupindd <- cdsd[iigs, vs] ir[2] <- sample(1:G, 1, prob=(1-groupindd)) # Second item group to be added to second version ia[2] <- sample(1:G, 1, prob=groupindd) # Second item group to be removed from second version cdsd21[iig==ia[2], vs] <- 0 cdsd12[iig==ir[2], vs] <- 1 tt <- sum(cdsd[, vs] * iti) tt21 <- sum(cdsd21[, vs] * iti) tt12 <- sum(cdsd12[, vs] * iti) if (abs(tt-ttt[1])>abs(tt21-ttt[1]) || tt>ttt[2]){ cdsd <- cdsd21 tt <- tt21 } if (abs(tt-ttt[1])>abs(tt12-ttt[1]) && tt12 gcand){ cds <- cdsd gcand <- gcandd cdf <- TRUE } } # compute acceptance probability h h <- exp((gcand-gold)/ctemp) # accept or reject candidate if (!is.na(h) && h>runif(1)){ tds <- cds gold <- gcand if (cdf==TRUE) chcod <- chcod+1 else chco <- chco+1 } } gocrit <- ocrit(piv, ity, tds, oc=oc) gpenal <- penalty(tds, iti, ttt) print(round(c(oiter, ctemp, chco, chcod, gold, gocrit, gpenal), 4)) if (oiter %% 10 == 0) { plotdes(ity, tds) title(paste("Design after", oiter*iin, "iterations")) } ctemp <- ctemp*cooling } print(gold) tds } ###################################################################################### ### Preprocessing ### below follow different scenarios ### Examples with 60 items ### 2PL, 3PL, GPCM (2 point), Mixed (Rasch and 2PL), Mixed (2PL and 3PL), 3PL with item groups ### then the real 2022 May/June-pretesting with 85 items ### choose ONLY ONE of these code-blocks starting with ## and run it; ### go then to the line with: ### Running the simulated annealing algorithm ### and run then the simulated annealing (NOTE: this may take 30-90 minutes, depending on your hardware); ### the intention of the postprocessing code is that one chooses only parts of it which create the needed output ###################################################################################### ## Chosen item types and assumed item parameters - 2PL model I <- 60; V <- 40; S <- 9 ity <- rep("2PL", I) ip <- cbind(rep(1, I), seq(-2, 2, length=I), rep(NA, I)) iig <- 1:I G <- iig[length(iig)] iti <- 0 ## Chosen item types and assumed item parameters - 3PL model I <- 60; V <- 40; S <- 9 ity <- rep("3PL", I) ip <- cbind(rep(1, I), seq(-2, 2, length=I), rep(0.2, I)) iig <- 1:I G <- iig[length(iig)] iti <- 0 ## Chosen item types and assumed item parameters - Generalized partial credit model for 0-1-2-item I <- 60; V <- 40; S <- 9 ity <- rep("GP2", I) ip <- cbind(rep(1, I), seq(-1.5, 2, length=I), seq(-2, 1.5, length=I)) iig <- 1:I G <- iig[length(iig)] iti <- 0 ## Chosen item types and assumed item parameters - Generalized partial credit model for 0-1-2-item; theoretical situation with b2-b1 and a large I <- 60; V <- 40; S <- 9 ity <- rep("GP2", I) ip <- cbind(rep(1.5, I), seq(-2, 0, length=I), seq(0, 2, length=I)) iig <- 1:I G <- iig[length(iig)] iti <- 0 ## Chosen item types and assumed item parameters - Mixed 2PL and 3PL model I <- 60; V <- 40; S <- 9 ity <- rep(c("2PL", "3PL"), I/2) ip <- cbind(rep(1, I), seq(-2, 2, length=I), rep(c(NA, 0.2), I/2)) iig <- 1:I G <- iig[length(iig)] iti <- 0 ## 85 items for May/June 2022 testing; 2PL, 3PL, and GPCM (2 points) items # fromitems are the placement in 2021-precalibration, e.g. 5_6b is version 5, problem 6, part b # fromvers is the version in 2021-precalibration (should correspond to first part of fromitems, but numeric) # ity item types; iig item groups # ip item parameters are based on estimates in 2021-precalibration # b-values for items 2_6, 4_2, 4_7 reduced with 0.3 since they became easier (corresponding to around 8% more correct solutions) # item 6_3 was rated at 0 and 2 only; the estimated b-value for the 2PL case was used with +-1 for b1 and b2 which imposes 2.7% # probability to obtain 1 point # The estimated a-parameters for 10_2a1 and 10_2a2 where large and they were capped at 5 # iti assumed item times needed for item groups in minutes; time assigned to first item in group - the other items in groups are set to 0 I <- 85 V <- 20 itemname <- c("su_np6_optic_22u2_sust_001", "su_np6_optic_22u2_sust_003", "su_np6_optic_22u2_sust_005", "su_np6_optic_22u2_sust_006", "su_np6_optic_22u2_sust_007", "su_np6_optic_22u2_sust_022", "su_np6_optic_22u2_sust_002a", "su_np6_optic_22u2_sust_002b", "su_np6_optic_22u2_sust_024a", "su_np6_optic_22u2_anny_001a", "su_np6_optic_22u2_anny_001b", "su_np6_optic_22u2_anny_003", "su_np6_optic_22u2_anny_007", "su_np6_optic_22u2_anny_008", "su_np6_optic_22u2_anny_010", "su_np6_optic_22u2_anny_009", "su_np6_optic_22u2_anny_006a", "su_np6_optic_22u2_anny_006b", "su_np6_optic_22u2_anny_006c", "su_np6_optic_22u2_sust_020", "su_np6_optic_22u2_sust_018", "su_np6_optic_22u2_sust_014a", "su_np6_optic_22u2_sust_014b", "su_np6_optic_22u2_anny_035", "su_np6_optic_22u2_anny_036", "su_np6_optic_22u2_anny_038", "su_np6_optic_22u2_anny_039", "su_np6_optic_22u2_anny_040", "su_np6_optic_22u2_anny_034a", "su_np6_optic_22u2_anny_025", "su_np6_optic_22u2_anny_028", "su_np6_optic_22u2_anny_030a", "su_np6_optic_22u2_anny_030b", "su_np6_optic_22u2_anny_031", "su_np6_optic_22u2_anny_032", "su_np6_optic_22u2_anny_026a", "su_np6_optic_22u2_anny_026b", "su_np6_optic_22u2_anny_029a", "su_np6_optic_22u2_anny_029b", "su_np6_optic_22u2_join_003", "su_np6_optic_22u2_join_004", "su_np6_optic_22u2_join_005", "su_np6_optic_22u2_join_007", "su_np6_optic_22u2_join_008a", "su_np6_optic_22u2_join_008b", "su_np6_optic_22u2_join_008c", "su_np6_optic_22u2_join_009a", "su_np6_optic_22u2_join_009b", "su_np6_optic_22u2_join_009c", "su_np6_optic_22u2_join_011", "su_np6_optic_22u2_join_012", "su_np6_optic_22u2_join_013", "su_np6_optic_22u2_join_014", "su_np6_optic_22u2_join_016", "su_np6_optic_22u2_anny_044", "su_np6_optic_22u2_anny_043", "su_np6_optic_22u2_anny_045a", "su_np6_optic_22u2_anny_045b", "su_np6_optic_22u2_anny_048", "su_np6_optic_22u2_anny_046a", "su_np6_optic_22u2_anny_046b", "su_np6_optic_22u2_anny_046c", "su_np6_optic_22u2_anny_049a", "su_np6_optic_22u2_anny_049b", "su_np6_optic_22u2_sust_010a", "su_np6_optic_22u2_sust_010b", "su_np6_optic_22u2_sust_010c", "su_np6_optic_22u2_join_031", "su_np6_optic_22u2_anny_075", "su_np6_optic_22u2_anny_056", "su_np6_optic_22u2_anny_069a", "su_np6_optic_22u2_anny_069b", "su_np6_optic_22u2_anny_084a", "su_np6_optic_22u2_anny_084b", "su_np6_optic_22u2_anny_051", "su_np6_optic_22u2_anny_058", "su_np6_optic_22u2_anny_077", "su_np6_optic_22u2_anny_068", "su_np6_optic_22u2_anny_082", "su_np6_optic_22u2_anny_079", "su_np6_optic_22u2_anny_063", "su_np6_optic_22u2_anny_083", "su_np6_optic_22u2_anny_062a", "su_np6_optic_22u2_anny_062b", "su_np6_optic_22u2_anny_062c") fromitem <- c( "1_1", "1_3", "1_5", "1_6", "1_7", "1_9", "1_2a", "1_2b", "1_8a", "2_1a", "2_1b", "2_3", "2_6", "2_7", "2_8", "2_9", "2_10a", "2_10b", "2_10c", "3_6", "3_8", "3_1a", "3_1b", "4_2", "4_3", "4_5", "4_6", "4_7", "4_1a", "5_1", "5_4", "5_6a", "5_6b", "5_7", "5_8", "5_2a", "5_2b", "5_5a", "5_5b", "6_2", "6_3", "6_4", "6_6", "6_7a", "6_7b", "6_7c", "7_1a", "7_1b", "7_1c", "7_3", "7_4", "7_5", "7_6", "7_8", "8_1", "8_2", "8_3a", "8_3b", "8_6", "8_4a", "8_4b", "8_4c", "8_7a", "8_7b", "10_2a1", "10_2a2", "10_2b", "13_6", "16_2", "16_3", "16_1a", "16_1b", "16_7a", "16_7b", "17_1", "17_2", "!7_3", "17_5", "17_8", "17_10", "18_8", "18_10", "18_4a", "18_4b", "18_4c") fromvers <- c(rep(1, 9), rep(2, 10), rep(3, 4), rep(4, 6), rep(5, 10), rep(6, 7), rep(7, 8), rep(8, 10), rep(10, 3), 13, rep(16, 6), rep(17, 6), rep(18, 5)) ity <- c( "2PL", "2PL", "GP2", "2PL", "3PL", "GP2", "2PL", "2PL", "2PL", "2PL", "2PL", "2PL", "GP2", "GP2", "2PL", "GP2", "2PL", "2PL", "2PL", "GP2", "GP2", "2PL", "2PL", "GP2", "2PL", "GP2", "2PL", "GP2", "2PL", "GP2", "2PL", "2PL", "2PL", "GP2", "2PL", "2PL", "2PL", "2PL", "2PL", "GP2", "GP2", "2PL", "2PL", "2PL", "2PL", "2PL", "2PL", "2PL", "2PL", "2PL", "3PL", "2PL", "2PL", "2PL", "3PL", "2PL", "2PL", "2PL", "2PL", "2PL", "2PL", "2PL", "2PL", "2PL", "2PL", "2PL", "2PL", "3PL", "3PL", "2PL", "2PL", "2PL", "2PL", "2PL", "3PL", "3PL", "2PL", "GP2", "2PL", "3PL", "GP2", "3PL", "2PL", "2PL", "2PL") iig <- c(1:7, 7:9, 9:15, 15, 15:18, 18:27, 27:30, 30:31, 31:36, 36, 36:37, 37, 37:45, 45:47, 47, 47:48, 48:49, 49, 49:53, 53:54, 54:63, 63, 63) G <- iig[length(iig)] ip <- matrix(c( 1.348, 0.454, NA, 1.501, 0.983, NA, 0.889, 1.415, -1.636, 2.178, 0.332, NA, 0.744, 1.289, 0.001, 0.829, 0.269, -0.196, 1.444, -0.905, NA, 2.097, -0.072, NA, 0.822, 0.720, NA, 1.511, -0.232, NA, 1.375, 1.245, NA, 1.708, -0.128, NA, 1.047, -0.035-0.3, -0.843-0.3, 1.312, -0.411, -1.084, 1.478, 0.557, NA, 1.708, 1.705, 0.851, 1.822, -1.632, NA, 2.046, -0.686, NA, 2.009, 0.359, NA, 0.911, 2.236, -1.967, 1.226, -0.088, 0.443, 0.919, -2.092, NA, 0.982, 1.129, NA, 1.505, 1.004-0.3, 0.090-0.3, 1.695, 0.079, NA, 0.994, 0.011, -0.407, 1.938, -0.895, NA, 1.496, 0.323-0.3, 0.109-0.3, 0.224, 3.047, NA, 0.965, 0.548, -1.466, 1.024, -0.417, NA, 1.684, -0.905, NA, 1.593, -0.454, NA, 1.211, 1.112, 0.465, 1.752, 0.411, NA, 0.682, -2.431, NA, 0.928, 0.205, NA, 3.234, -0.233, NA, 2.756, -0.072, NA, 0.924, 2.827, -0.205, 1.982, 0.773+1, 0.773-1, 1.078, -0.998, NA, 2.033, 1.556, NA, 1.793, -0.036, NA, 2.629, 0.039, NA, 2.981, 0.468, NA, 1.561, -3.134, NA, 1.454, -1.656, NA, 1.161, -0.692, NA, 2.143, -0.083, NA, 2.541, -0.775, 0.274, 1.709, -1.521, NA, 3.883, -1.302, NA, 0.748, 1.126, NA, 1.883, 1.035, 0.246, 1.086, -1.465, NA, 2.229, 0.082, NA, 2.014, 0.250, NA, 1.077, -0.500, NA, 1.480, -1.877, NA, 2.931, -0.438, NA, 2.289, -0.325, NA, 0.771, 0.723, NA, 1.006, 0.057, NA, min(8.660, 5), -0.162, NA, min(12.288, 5), -0.128, NA, 3.417, 0.372, NA, 0.753, 0.721, 0.001, 1.925, -0.280, 0.001, 1.307, 0.590, NA, 1.305, -1.642, NA, 1.362, -0.901, NA, 1.595, -1.951, NA, 1.482, -1.341, NA, 2.337, 0.807, 0.292, 4.972, 0.657, 0.426, 1.482, 1.092, NA, 0.675, 2.023, -2.625, 1.121, 0.412, NA, 0.147, 14.163, 0.001, 0.942, 1.168, -1.184, 1.005, -1.610, 0.003, 1.472, -1.416, NA, 0.902, -2.298, NA, 0.662, -2.291, NA ), ncol=3, byrow=TRUE) iti <- c(2, 3, 5, 5, 3, 3, 5, 0, 5, 3, 0, 3, 5, 2, 3, 3, 3, 0, 0, 8, 5, 3, 0, 8, 3, 2, 2, 5, 2, 2, 5, 3, 0, 3, 5, 3, 0, 3, 0, 8, 5, 3, 5, 5, 0, 0, 3, 0, 0, 3, 3, 2, 2, 5, 2, 2, 3, 0, 2, 3, 0, 0, 5, 0, 5, 0, 0, 2, 2, 3, 2, 0, 3, 0, 2, 2, 3, 5, 3, 5, 5, 3, 5, 0, 0) # Total target time is 40 minutes for whole test tttime <- 40 S <- 9 # just used here for creating a starting design ### Running the simulated annealing algorithm # NOTE: running the algorithm may take 30-90 minutes, depending on your hardware # NOTE: for the illustrative 2PL, 3PL, and GPCM examples in the paper (Figure 2), the result of the optimisation is saved in the datasets # des2PLparallel.xls, des3PLparallel.xls, desGP2parallel.xls. Instead of running the following algorithm, you could read in the design directly. # Read in with: des <- read.table(file="... .xls", header=TRUE, sep="\t") # graphical output shown during computing shows the progress of the actual computed best design after each 10 outer iterations # text output shows (outer) iteration number 1, 2, ..., oin; then temperature of sim.ann.alg., then two counts of exchanges done; # then two optimality criteria; and penalty # NOTE: a stochastic optimization algorithm is used here which implies that results might not exactly the same when rerunning! # possibility to standardize: set.seed(2024) startdes <- startdesign(V, S, iig) # create startdesign respecting item groups dev.new(width=15, height=10, unit="cm") oldpar <- par(mfrow=c(2, 5)) des <- simann(startdes, ip=ip, ity=ity, iig=iig, iti=iti, pf=10, ttt=c(tttime, tttime+5), oc="D", temp=1, cooling=sqrt(0.84), oin=90, iin=100000) par(oldpar) ### Postprocessing # Plot Optimal design # For panels in Figures 2, 4, 9 dev.new(width=4, height=6, unit="cm") oldpar <- par(mfrow=c(1, 1)) plotdes(ity, des, type=1) par(oldpar) # Compare with random design # Results in Table 1 if (iti[1]==0) prop <- S/I else prop <- tttime/sum(iti) # average proportion examinees calibrating an item, either fixed length case (iti[1]=0) or target time case piv <- pinf(ip, ity, V) rDcrit <- ocritrand(piv, ity, prop=prop, oc="D") # randomly allocating items to examinees without version restriction oDcrit <- ocrit(piv, ity, des, oc="D") parnum <- sum(ity=="1PL")+2*sum(ity=="2PL")+3*sum(ity=="3PL")+3*sum(ity=="GP2") # total number of parameters in the model # D-efficiency vs. random design exp(oDcrit - rDcrit)^(1/parnum) # Compare effect on individual items rDcrit <- ocritrand(piv, ity, oc="D", eachitem=TRUE, prop=prop) oDcrit <- ocrit(piv, ity, des, oc="D", eachitem=TRUE) vnp <- 1.0*(ity=="1PL") + 2.0*(ity=="2PL") + 3.0*(ity=="3PL") + 3.0*(ity=="GP2") itynum <- 1.0*(ity=="1PL") + 2.0*(ity=="2PL") + 3.0*(ity=="3PL") + 4.0*(ity=="GP2") releff <- exp(oDcrit - rDcrit)^(1/vnp) # Efficiencies by item type # For calculating results in Table 2 and 4 exp(mean(log(releff[ity=="2PL"]))) exp(mean(log(releff[ity=="3PL"]))) exp(mean(log(releff[ity=="GP2"]))) # Plot criterion values per item # For Figure 5b, when mixed 2PL & 3PL model was run (for non-mixed item types, make a change as described below) dev.new(width=15, height=10, unit="cm") oldpar <- par(mfrow=c(1, 1)) plot(c(1, I), c(min(c(rDcrit, oDcrit)), max(c(rDcrit, oDcrit))), type="n", xlab="Item number", ylab="log criterion value", las=1) points(1:I, oDcrit, col=itynum, pch=itynum, lwd=2) points(1:I, rDcrit, col=1, pch=itynum, lwd=2) #lines(1:I, rDcrit, col=1, pch=1) # For models with a single item type (no such plot included in publication) lines(1:(I/2)*2-1, rDcrit[ity=="2PL"], col=1, pch=1) # For mixed format 2PL & 3PL lines(1:(I/2)*2, rDcrit[ity=="3PL"], col=1, pch=1) # For mixed format 2PL & 3PL par(oldpar) # Plot relative efficiencies by item # For Figure 3 dev.new(width=15, height=10, unit="cm") oldpar <- par(mfrow=c(1, 1)) plot(1:I, releff, type="p", ylim=c(min(c(releff, 1)), max(c(releff, 1))), xlab="Item number", ylab="relative efficiency optimal vs. random", log="y", pch=2, las=1, lwd=2, col=itynum) abline(h=1, lty=2) par(oldpar) # Compare effect on individual items # For Figure 10 rDcrit <- ocritrand(piv, ity, oc="D", eachpar=TRUE, prop=prop) oDcrit <- ocrit(piv, ity, des, oc="D", eachpar=TRUE) itynum <- 1.0*(ity=="1PL") + 2.0*(ity=="2PL") + 3.0*(ity=="3PL") + 4.0*(ity=="GP2") releff <- oDcrit / rDcrit # Plot relative efficiencies by parameter dev.new(width=15, height=10, unit="cm") oldpar <- par(mfrow=c(1, 1)) sset <- 1:I #sset <- (1:(I/2))*2-1 # 2PL-items only for mixed 2/3PL model #sset <- (1:(I/2))*2 # 3PL-items only for mixed 2/3PL model plot(sset, releff[sset,1], type="p", ylim=c(min(c(releff, 1)), max(c(releff, 1))), xlab="Item number", ylab="relative efficiency optimal vs. random", log="y", pch=3, las=1, lwd=2, col=itynum[sset]) points(sset, releff[sset,2], pch=5, lwd=2, col=itynum[sset]) #points(sset, releff[sset,3], pch=7, lwd=2, col=itynum[sset]) # activate this line for 3PL and GPCM (not for 2PL) abline(h=1, lty=2) par(oldpar) # For real study. # Run first preprocessing for this data above starting with ## 85 items for May/June 2022 testing; 2PL, 3PL, and GPCM (2 points) items # Optimal design can be calculated with algorithm above. # Here, we read in the optimal design previously calculated with that algorithm desigr <- read.table(file="desRealTestparallel.xls", header=TRUE, sep="\t") iig <- c(1:7, 7:9, 9:15, 15, 15:18, 18:27, 27:30, 30:31, 31:36, 36, 36:37, 37, 37:45, 45:47, 47, 47:48, 48:49, 49, 49:53, 53:54, 54:63, 63, 63) I <- length(iig) V <- 20 des <- matrix(rep(NA, V*I), ncol=V) for (i in 1:I){ for (j in 1:V){ des[i, j] <- desigr[iig[i], j] } } # Compare with random design if (iti[1]==0) prop <- S/I else prop <- tttime/sum(iti) # average proportion examinees calibrating an item, either fixed length case (iti[1]=0) or target time case piv <- pinf(ip, ity, V) rDcrit <- ocritrand(piv, ity, prop=prop, oc="D") # randomly allocating items to examinees without version restriction oDcrit <- ocrit(piv, ity, des, oc="D") parnum <- sum(ity=="1PL")+2*sum(ity=="2PL")+3*sum(ity=="3PL")+3*sum(ity=="GP2") # total number of parameters in the model # D-efficiency vs. random design exp(oDcrit - rDcrit)^(1/parnum) # Compare effect on individual items rDcrit <- ocritrand(piv, ity, oc="D", eachitem=TRUE, prop=prop) oDcrit <- ocrit(piv, ity, des, oc="D", eachitem=TRUE) vnp <- 1.0*(ity=="1PL") + 2.0*(ity=="2PL") + 3.0*(ity=="3PL") + 3.0*(ity=="GP2") itynum <- 1.0*(ity=="1PL") + 2.0*(ity=="2PL") + 3.0*(ity=="3PL") + 4.0*(ity=="GP2") releff <- exp(oDcrit - rDcrit)^(1/vnp) # Create vector marking single/double/triple items gty <- rep(1, 85) for (i in 1:84){ if (iig[i]==iig[i+1] && (i>1 && iig[i-1]0){ ig <- ig+1 if (i==I || iti[i+1]>0){ idig[ig] <- idi[i] itig[ig] <- iti[i] releffg[ig] <- releff[i] itynumg[ig] <- itynum[i] igrsize[ig] <- 1 } else { if (i+1==I || iti[i+2]>0){ idig[ig] <- (idi[i]+idi[i+1])/2 itig[ig] <- iti[i] releffg[ig] <- exp((log(releff[i])+log(releff[i+1]))/2) itynumg[ig] <- exp((log(itynum[i])+log(itynum[i+1]))/2) igrsize[ig] <- 2 } else { idig[ig] <- (idi[i]+idi[i+1]+idi[i+2])/3 itig[ig] <- iti[i] releffg[ig] <- exp((log(releff[i])+log(releff[i+1])+log(releff[i+2]))/3) itynumg[ig] <- exp((log(itynum[i])+log(itynum[i+1])+log(itynum[i+2]))/3) igrsize[ig] <- 3 } } } } dev.new(width=4, height=6, unit="cm") oldpar <- par(mfrow=c(1, 1)) desig <- des[(iti>0), ] desigo <- desig[order(idig), ] ityig <- ity[(iti>0)] ityigo <- ityig[order(idig)] plotdes(ityigo, desigo, ytext="Item group (sorted by difficulty)", type=3) par(oldpar) # Relative item group efficiencies; item groups sorted by difficulty - version for publication dev.new(width=15, height=10, unit="cm") oldpar <- par(mfrow=c(1, 1)) plot(1:G, releffg[order(idig)], type="p", xlab="Item group (sorted by difficulty)", ylab="relative efficiency optimal vs. random", log="y", pch=itynumg[order(idig)], col=itynumg[order(idig)], lwd=2, las=1, cex=igrsize[order(idig)]*0.5+0.5) abline(h=1, lty=2) par(oldpar)