autoFC: An R Package for Automatic Item Pairing in Forced-Choice Test Construction

Step 1: Input data

In this tutorial, we suppose that 60 5-Point Likert items measuring Big Five traits, each with a certain item location, are used to build a FC scale with block size 3. We also simulate responses from 1,000 participants for the 60 items on their social desirability.

set.seed(2021)
# Simulation of 1,000 respondents on 60 items. A better simulation should be
# consisting of responses produced by specific IRT parameters.
s1 <- sample(seq(1:5), 500*60, replace = TRUE, 
                                prob = c(0.10, 0.15, 0.20, 0.25, 0.30))
s2 <- sample(seq(1:5), 500*60, replace = TRUE, 
                                prob = c(0.50, 0.10, 0.10, 0.15, 0.15))

item_responses <- matrix(c(s1, s2), ncol = 60)

item_dims <- sample(c("Openness","Conscientiousness","Neuroticism",
                      "Extraversion","Agreeableness"), 60, replace = TRUE)
item_mean <- colMeans(item_responses)
item_difficulty <- runif(60, -1, 1)

# Then we build a data frame with item characteristics
item_chars <- data.frame(DIM = item_dims, SD_Mean = item_mean, DIFF = item_difficulty)

char_weights = c(1, -1, -3)

Step 2: Construct an initial solution

Next, we build a random FC scale using the 60 items with block size 3. You can see from initial_FC that now all 60 items are divided into 20 triplets.

initial_FC <- make_random_block(total_items = 60, item_per_block = 3)
knitr::kable(initial_FC)

Also let’s see the how the item characteristics look like for each of the 20 triplets.

First, the underlying latent traits. We see that there are some cases where two items measuring the same traits appear in the same block, which is something we want to avoid.

knitr::kable(matrix(item_chars$DIM[t(initial_FC)], ncol = 3, byrow = TRUE))

Then, scores on social desirability. We do see many cases where items differ in their social desirability on a magnitude of >1 on a 5-point scale, within a block. That’s not good.

sd_initial <- matrix(item_chars$SD_Mean[t(initial_FC)], ncol = 3, byrow = TRUE)
knitr::kable(sd_initial)

Lastly, item difficulty. We also see that item difficulties within a block are also inconsistent.

diff_initial <- matrix(item_chars$DIFF[t(initial_FC)], ncol = 3, byrow = TRUE)
knitr::kable(diff_initial)

Step 3: Calculate the energy for the initial FC scale, without and with IIAs

Next we calculate the energy for initial_FC, with FUN set to be default. weights is set to -1 for social desirability and -3 for item difficulty because we want the discrepancy of these characteristics to be as low as possible within a block.

The weight for item difficulty is higher to scale for its smaller range than social desirability. Beware about the scaling difference among different item characteristics and use different weights accordingly.

cal_block_energy(block = initial_FC, item_chars = item_chars, weights = char_weights)
#> [1] -25.28441

If IIAs are to be involved we have lower energy value. This is because these randomly generated responses are not likely to be consistent with each other, hence very low and even negative IIAs:

cal_block_energy_with_iia(block = initial_FC, item_chars = item_chars, 
                          weights = char_weights,
                          rater_chars = item_responses)
#>           [,1]
#> [1,] -33.31589

Notice that if we give zero weights to all IIAs we will get the same energy value as cal_block_energy:

cal_block_energy_with_iia(block = initial_FC, item_chars = item_chars, 
                          weights = char_weights,
                          rater_chars = item_responses, 
                          iia_weights = c(0, 0, 0, 0))
#>           [,1]
#> [1,] -25.28441

Also, if you want to see the inter-item agreement metrics for each block, you can use get_iia(). It should not be too impressive and is for demonstration purposes only. Users are suggested to use real world response data to see the IIA within each block.

knitr::kable(get_iia(block = initial_FC, data = item_responses))

Step 4: Automatic pairing

To produce an optimized paired FC scale, we have the objective of:
* Keeping items in the same block being from different latent traits;
* Minimizing variance of social desirability within each block;
* Minimizing variance of item difficulty within each block.

For IIAs, we also want to maximize the mean of the four IIAs within each block.

# Note that this will take some time to run! (~ 1-2 minutes with this setting)

# Weights for social desirability score and item difficulty should be set to -1, 
# because we don't want variance for these characteristics to be big.
result <- sa_pairing_generalized(block = initial_FC, eta_Temperature = 0.01,
                                 r = 0.995, end_criteria = 10^(-6), 
                                 weights = char_weights,
                                 item_chars = item_chars, use_IIA = TRUE,
                                 rater_chars = item_responses)

Step 5: See how this improves over the initial one

Finally, let’s see how this pairing method improves from the initial solution!

Let’s first see the total energy compared to the previous one. First are the initial energy, which is identical to what we have calculated in Step 4.

# Initial energy with IIA
cal_block_energy_with_iia(block = result$block_initial, item_chars = item_chars, 
                          weights = char_weights, rater_chars = item_responses)
#>           [,1]
#> [1,] -33.31589

# Alternative way to calculate initial energy
print(result$energy_initial)
#> [1] -33.31589

And the final result:

# Final energy with IIA
cal_block_energy_with_iia(block = result$block_final, item_chars = item_chars, 
                          weights = char_weights, rater_chars = item_responses)
#>          [,1]
#> [1,] 21.69018

# Alternative way to calculate final energy
print(result$energy_final)
#> [1] 21.69018

Let’s take a look at how items are matched within each block. First are underlying latent traits.

This time, within each block, the three items are already coming from three distinct latent traits!

(Note: It does not guarantee that items will ALWAYS come from different latent traits after pairing. But if you want to increase the likelihood for such a result, you can increase the weight corresponding to item dimension)

knitr::kable(matrix(item_chars$DIM[t(result$block_final)], ncol = 3, byrow = TRUE))

Next let’s look at difference in social desirability within each block. Item social desirability scores are much closer to each other within each block, but we see that there are still big discrepancies two blocks.

sd_final <- matrix(item_chars$SD_Mean[t(result$block_final)], ncol = 3, byrow = TRUE)
knitr::kable(sd_final)

A more intuitive way to present this: how much have we improved on the average variance for all blocks? Still, it is much lower, but we see there is always space to improve.

# Initial
print(mean(apply(sd_initial, 1, var)))   
#> [1] 0.3317092

# Final
print(mean(apply(sd_final, 1, var)))     
#> [1] 0.04195382

Finally we look at item difficulty. Good improvement is also observed. We see that difference in item difficulty within a block also decreases:

diff_final <- matrix(item_chars$DIF[t(result$block_final)], ncol = 3, byrow = TRUE)
knitr::kable(diff_final)

How much have we improved on the average variance for all blocks in this case?

print(mean(apply(diff_initial, 1, var)))   
#> [1] 0.4275037
print(mean(apply(diff_final, 1, var)))     
#> [1] 0.04305659

We also list IIAs for demonstration purposes, which also improves.

colMeans(get_iia(result$block_final, data = item_responses))
#>      BPlin     BPquad      AClin     ACquad 
#>  0.0195425 -0.0498910  0.1263995  0.1595815

Step 6: Automatic pairing with a multi-step optimization process

In some cases, users may want to optimize item characteristics sequentially, rather than in a simultaneous manner. This makes sense because it is possible that simultaneous optimization will inevitably favor the improvement in one characteristic at the cost of losing the best fit for the other, as we have observed in Step 5.

Two solutions can be made to address this problem:

1. Pay careful attention to the distribution of each item characteristic and try out different weights for characteristics with different scales. Alternatively, try smaller end_criteria or larger r and n_exchange values to allow for more iterations to be run;

2. Use a multi-step optimization process, where some item characteristics are optimized first, then others. This involves running sa_pairing_generalized() several times, which each time optimizing more and more item characteristics. Those characteristics optimized will remain their weight in later stages, but have 0 weights if they are not yet optimized.

With the previous example, we show how method 2 will work, starting from initial_FC. First we perform optimization on latent traits:

FC_1 <- sa_pairing_generalized(initial_FC, eta_Temperature = 0.01,
                                 r = 0.995, end_criteria = 10^(-6), 
                                 weights = c(1, 0, 0),
                                 item_chars = item_chars, use_IIA = TRUE,
                                 rater_chars = item_responses)

Then, we optimize based on minimizing variance in social desirability within a block.

FC_2 <- sa_pairing_generalized(FC_1$block_final, eta_Temperature = 0.01,
                               r = 0.995, end_criteria = 10^(-6), 
                               weights = c(1, -1, 0),
                               item_chars = item_chars, use_IIA = TRUE,
                               rater_chars = item_responses)

Finally, we optimize bease on minimizing variance in item difficulty.

FC_3 <- sa_pairing_generalized(FC_2$block_final, eta_Temperature = 0.01,
                               r = 0.995, end_criteria = 10^(-6), 
                               weights = c(1, -1, -3),
                               item_chars = item_chars, use_IIA = TRUE,
                               rater_chars = item_responses)

Step 7: See how a multi-step iteration improves

First, underlying latent traits. It does look nice like what we have in Step 5.

knitr::kable(matrix(item_chars$DIM[t(FC_3$block_final)], ncol = 3, byrow = TRUE))

Next let’s look at difference in social desirability within each block. It performs better than in Step 5, where the discrepancy within block is removed!

sd_FC3 <- matrix(item_chars$SD_Mean[t(FC_3$block_final)], ncol = 3, byrow = TRUE)
knitr::kable(sd_FC3)

As before, let’s see how much have we improved on the average variance for all blocks. Improvement in social desirability is verified by seeing the decrease in variance.

# Initial solution
print(mean(apply(sd_initial, 1, var)))   
#> [1] 0.3317092

# Simultaneous optimization
print(mean(apply(sd_final, 1, var)))    
#> [1] 0.04195382

# Sequential optimization
print(mean(apply(sd_FC3, 1, var)))       
#> [1] 0.002573133

Finally we look at item difficulty.

diff_fc3 <- matrix(item_chars$DIF[t(FC_3$block_final)], ncol = 3, byrow = TRUE)
knitr::kable(diff_final)

Average variance of item difficulty also decreases!

# Initial solution
print(mean(apply(diff_initial, 1, var))) 
#> [1] 0.4275037

# Simultaneous optimization
print(mean(apply(diff_final, 1, var)))   
#> [1] 0.04305659

# Sequential optimization
print(mean(apply(diff_fc3, 1, var)))      
#> [1] 0.04012038

How about IIAs?

colMeans(get_iia(FC_3$block_final, data = item_responses))
#>      BPlin     BPquad      AClin     ACquad 
#>  0.0335635 -0.0304330  0.1459820  0.1892760