#Creation of the Shadow Test algorithm: ---- #The first step is to install the ShadowCAT function from GitHub (Kroeze, 2017). #IMPORTANT: the function appears to work with version 4.2 of R but not with later versions. #Therefore, we strongly recommend retrieving the earlier version from the R repository and setting that version when running this simulation. #Otherwise, the entire code may encounter errors. library(remotes) remotes::install_github("cran/MultiGHQuad") remotes::install_github("Karel-Kroeze/ShadowCAT") ##Then we have modified the function ShadowCAT (my_shadowCAT) so that it could perfectly meet our requirements---- library(ShadowCAT) `%not_in%`<- function (x, y) { !(x %in% y) } my_shadowcat<-function (answers, estimate, variance, model, alpha, beta, start_items, stop_test, estimator, information_summary, prior_form = NULL, prior_parameters = NULL, guessing = NULL, eta = NULL, constraints_and_characts = NULL, lower_bound = NULL, upper_bound = NULL, safe_eap = FALSE, eap_estimation_procedure = "riemannsum") { result <- function() { switch_to_maximum_aposteriori <- estimator == "maximum_likelihood" && !is.null(lower_bound) && !is.null(upper_bound) estimator <- get_estimator(switch_to_maximum_aposteriori = switch_to_maximum_aposteriori) prior_form <- get_prior_form(switch_to_maximum_aposteriori = switch_to_maximum_aposteriori) prior_parameters <- get_prior_parameters(switch_to_maximum_aposteriori = switch_to_maximum_aposteriori) beta <- get_beta() guessing <- get_guessing() number_items <- nrow(alpha) number_dimensions <- ncol(alpha) number_itemsteps_per_item <- ShadowCAT:::number_non_missing_cells_per_row(beta) lp_constraints_and_characts <- get_lp_constraints_and_characts(number_items = number_items) item_keys <- rownames(alpha) item_keys_administered <- rownames(answers) answers_vector<- c(answers) names(answers_vector)<-rownames(answers) item_keys_available <- get_item_keys_available(item_keys_administered = item_keys_administered, item_keys = item_keys) attr(estimate, "variance") <- matrix(variance, ncol = number_dimensions) estimate <- update_person_estimate(estimate = estimate, answers_vector = answers_vector, item_indices_administered = match(item_keys_administered, item_keys), number_dimensions = number_dimensions, alpha = alpha, beta = beta, guessing = guessing, number_itemsteps_per_item = number_itemsteps_per_item, estimator = estimator, prior_form = prior_form, prior_parameters = prior_parameters) continue_test <- !ShadowCAT:::terminate_test(number_answers = length(answers), estimate = estimate, min_n = stop_test$min_n, max_n = stop_test$max_n, variance_target = stop_test$target, cutoffs = stop_test$cutoffs) if (continue_test) { index_new_item <- ShadowCAT:::get_next_item(start_items = start_items, information_summary = information_summary, lp_constraints = lp_constraints_and_characts$lp_constraints, lp_characters = lp_constraints_and_characts$lp_chars, estimate = estimate, model = model, answers = answers_vector, prior_form = prior_form, prior_parameters = prior_parameters, available = match(item_keys_available, item_keys), administered = match(item_keys_administered, item_keys), number_items = number_items, number_dimensions = number_dimensions, estimator = estimator, alpha = alpha, beta = beta, guessing = guessing, number_itemsteps_per_item = number_itemsteps_per_item, stop_test = stop_test, eap_estimation_procedure = eap_estimation_procedure) key_new_item <- item_keys[index_new_item] } else { key_new_item <- NULL } list(key_new_item = ShadowCAT:::as.scalar2(key_new_item), continue_test = ShadowCAT:::as.scalar2(continue_test), estimate = as.vector(estimate), variance = as.vector(attr(estimate, "variance"))) } update_person_estimate <- function(estimate, answers_vector, item_indices_administered, number_dimensions, alpha, beta, guessing, number_itemsteps_per_item, estimator, prior_form, prior_parameters) { if (length(answers) > start_items$n) ShadowCAT:::estimate_latent_trait(estimate = estimate, answers = answers_vector, prior_form = prior_form, prior_parameters = prior_parameters, model = model, administered = item_indices_administered, number_dimensions = number_dimensions, estimator = estimator, alpha = alpha, beta = beta, guessing = guessing, number_itemsteps_per_item = number_itemsteps_per_item, safe_eap = safe_eap, eap_estimation_procedure = eap_estimation_procedure) else estimate } get_item_keys_available <- function(item_keys_administered, item_keys) { if (is.null(item_keys_administered)) item_keys else item_keys[-which(item_keys %in% item_keys_administered)] } get_beta <- function() { if (model == "GPCM" && is.null(beta) && !is.null(eta)) row_cumsum(eta) else beta } get_guessing <- function() { if (is.null(guessing)) matrix(0, nrow = nrow(as.matrix(alpha)), ncol = 1, dimnames = list(rownames(alpha), NULL)) else guessing } get_estimator <- function(switch_to_maximum_aposteriori) { if (switch_to_maximum_aposteriori) "maximum_aposteriori" else estimator } get_prior_form <- function(switch_to_maximum_aposteriori) { if (switch_to_maximum_aposteriori) "uniform" else prior_form } get_prior_parameters <- function(switch_to_maximum_aposteriori) { if (switch_to_maximum_aposteriori) list(lower_bound = lower_bound, upper_bound = upper_bound) else prior_parameters } get_lp_constraints_and_characts <- function(number_items) { if (is.null(constraints_and_characts)) NULL else ShadowCAT:::constraints_lp_format(max_n = stop_test$max_n, number_items = number_items, characteristics = constraints_and_characts$characteristics, constraints = constraints_and_characts$constraints) } validate <- function() { if (is.null(estimate)) return(add_error("estimate", "is missing")) if (is.null(variance)) return(add_error("variance", "is missing")) if (!is.vector(variance)) return(add_error("variance", "should be entered as vector")) if (sqrt(length(variance)) != round(sqrt(length(variance)))) return(add_error("variance", "should be a covariance matrix turned into a vector")) if (is.null(model)) return(add_error("model", "is missing")) if (is.null(alpha)) return(add_error("alpha", "is missing")) if (is.null(start_items)) return(add_error("start_items", "is missing")) if (is.null(stop_test)) return(add_error("stop_test", "is missing")) if (is.null(estimator)) return(add_error("estimator", "is missing")) if (is.null(information_summary)) return(add_error("information_summary", "is missing")) if (!is.matrix(alpha) || is.null(rownames(alpha))) return(add_error("alpha", "should be a matrix with item keys as row names")) if (!is.null(beta) && (!is.matrix(beta) || is.null(rownames(beta)))) return(add_error("beta", "should be a matrix with item keys as row names")) if (!is.null(eta) && (!is.matrix(eta) || is.null(rownames(eta)))) return(add_error("eta", "should be a matrix with item keys as row names")) if (!is.null(guessing) && (!is.matrix(guessing) || ncol(guessing) != 1 || is.null(rownames(guessing)))) return(add_error("guessing", "should be a single column matrix with item keys as row names")) if (!is.null(start_items$type) && start_items$type == "random_by_dimension" && length(start_items$n_by_dimension) %not_in% c(1, length(estimate))) return(add_error("start_items", "length of n_by_dimension should be a scalar or vector of the length of estimate")) if (!ShadowCAT:::row_names_are_equal(rownames(alpha), list(alpha, beta, eta, guessing))) add_error("alpha_beta_eta_guessing", "should have equal row names, in same order") if (!is.null(beta) && !ShadowCAT:::na_only_end_rows(beta)) add_error("beta", "can only contain NA at the end of rows, no values allowed after an NA in a row") if (!is.null(eta) && !ShadowCAT:::na_only_end_rows(eta)) add_error("eta", "can only contain NA at the end of rows, no values allowed after an NA in a row") if (length(estimate) != ncol(alpha)) add_error("estimate", "length should be equal to the number of columns of the alpha matrix") if (length(estimate)^2 != length(variance)) add_error("variance", "should have a length equal to the length of estimate squared") if (is.null(answers) && !matrixcalc::is.positive.definite(matrix(variance, ncol = sqrt(length(variance))))) add_error("variance", "matrix is not positive definite") if (model %not_in% c("3PLM", "GPCM", "SM", "GRM")) add_error("model", "of unknown type") if (model != "GPCM" && is.null(beta)) add_error("beta", "is missing") if (model == "GPCM" && is.null(beta) && is.null(eta)) add_error("beta_and_eta", "are both missing; define at least one of them") if (model == "GPCM" && !is.null(beta) && !is.null(eta) && !all(row_cumsum(eta) == beta)) add_error("beta_and_eta", "objects do not match") if (estimator != "maximum_likelihood" && is.null(prior_form)) add_error("prior_form", "is missing") if (estimator != "maximum_likelihood" && is.null(prior_parameters)) add_error("prior_parameters", "is missing") if (!is.null(prior_form) && prior_form %not_in% c("normal", "uniform")) add_error("prior_form", "of unknown type") if (!is.null(prior_form) && !is.null(prior_parameters) && prior_form == "uniform" && (is.null(prior_parameters$lower_bound) || is.null(prior_parameters$upper_bound))) add_error("prior_form_is_uniform", "so prior_parameters should contain lower_bound and upper_bound") if (!is.null(prior_form) && !is.null(prior_parameters) && prior_form == "normal" && (is.null(prior_parameters$mu) || is.null(prior_parameters$Sigma))) add_error("prior_form_is_normal", "so prior_parameters should contain mu and Sigma") if (!is.null(prior_parameters$mu) && length(prior_parameters$mu) != length(estimate)) add_error("prior_parameters_mu", "should have same length as estimate") if (!is.null(prior_parameters$Sigma) && (!is.matrix(prior_parameters$Sigma) || !all(dim(prior_parameters$Sigma) == c(length(estimate), length(estimate))) || !matrixcalc::is.positive.definite(prior_parameters$Sigma))) add_error("prior_parameters_sigma", "should be a square positive definite matrix, with dimensions equal to the length of estimate") if (!is.null(prior_parameters$lower_bound) && !is.null(prior_parameters$upper_bound) && (length(prior_parameters$lower_bound) != length(estimate) || length(prior_parameters$upper_bound) != length(estimate))) add_error("prior_parameters_bounds", "should contain lower and upper bound of the same length as estimate") if (is.null(stop_test$max_n)) add_error("stop_test", "contains no max_n") if (!is.null(stop_test$max_n) && stop_test$max_n > nrow(alpha)) add_error("stop_test_max_n", "is larger than the number of items in the item bank") if (!is.null(stop_test$max_n) && !is.null(stop_test$cutoffs) && (!is.matrix(stop_test$cutoffs) || nrow(stop_test$cutoffs) < stop_test$max_n || ncol(stop_test$cutoffs) != length(estimate) || any(is.na(stop_test$cutoffs)))) add_error("stop_test_cutoffs", "should be a matrix without missing values, and number of rows equal to max_n and number of columns equal to the number of dimensions") if (start_items$n == 0 && information_summary == "posterior_expected_kullback_leibler") add_error("start_items", "requires n > 0 for posterior expected kullback leibler information summary") if (!is.null(start_items$type) && start_items$type == "random_by_dimension" && length(start_items$n_by_dimension) == length(estimate) && start_items$n != sum(start_items$n_by_dimension)) add_error("start_items_n", "contains inconsistent information. Total length of start phase and sum of length per dimension do not match (n != sum(n_by_dimension)") if (!is.null(start_items$type) && start_items$type == "random_by_dimension" && length(start_items$n_by_dimension) == 1 && start_items$n != sum(rep(start_items$n_by_dimension, length(estimate)))) add_error("start_items_n", "contains inconsistent information. Total length of start phase and sum of length per dimension do not match") if (!is.null(stop_test$cutoffs) && !is.matrix(stop_test$cutoffs)) add_error("stop_test", "contains cutoff values in non-matrix format") if (!all(rownames(answers) %in% rownames(alpha))) add_error("answers", "contains non-existing key") if (estimator %not_in% c("maximum_likelihood", "maximum_aposteriori", "expected_aposteriori")) add_error("estimator", "of unknown type") if (information_summary %not_in% c("determinant", "posterior_determinant", "trace", "posterior_trace", "posterior_expected_kullback_leibler")) add_error("information_summary", "of unknown type") if (estimator == "maximum_likelihood" && information_summary %in% c("posterior_determinant", "posterior_trace", "posterior_expected_kullback_leibler")) add_error("estimator_is_maximum_likelihood", "so using a posterior information summary makes no sense") if (estimator != "maximum_likelihood" && (!is.null(lower_bound) || !is.null(upper_bound))) add_error("bounds", "can only be defined if estimator is maximum likelihood") if (!is.null(lower_bound) && length(lower_bound) %not_in% c(1, length(estimate))) add_error("lower_bound", "length of lower bound should be a scalar or vector of the length of estimate") if (!is.null(upper_bound) && length(upper_bound) %not_in% c(1, length(estimate))) add_error("upper_bound", "length of upper bound should be a scalar or vector of the length of estimate") if (!ShadowCAT:::no_missing_information(constraints_and_characts$characteristics, constraints_and_characts$constraints)) add_error("constraints_and_characts", "constraints and characteristics should either be defined both or not at all") if (!ShadowCAT:::characteristics_correct_format(constraints_and_characts$characteristics, number_items = nrow(alpha))) add_error("characteristics", "should be a data frame with number of rows equal to the number of items in the item bank") if (!ShadowCAT:::constraints_correct_structure(constraints_and_characts$constraints)) add_error("constraints_structure", "should be a list of length three lists, with elements named 'name', 'op', 'target'") if (!ShadowCAT:::constraints_correct_names(constraints_and_characts$constraints, constraints_and_characts$characteristics)) add_error("constraints_name_elements", "should be defined as described in the details section of ShadowCAT:::constraints_lp_format()") if (!ShadowCAT:::constraints_correct_operators(constraints_and_characts$constraints)) add_error("constraints_operator_elements", "should be defined as described in the details section of ShadowCAT:::constraints_lp_format()") if (!ShadowCAT:::constraints_correct_targets(constraints_and_characts$constraints)) add_error("constraints_target_elements", "should be defined as described in the details section of ShadowCAT:::constraints_lp_format()") } invalid_result <- function() { list(errors = errors()) } ShadowCAT:::validate_and_run() } #Simulation WITHOUT algorithm: ---- #In order to compare the use or non-use of the proposed methods, the first simulation was carried out WITHOUT applying the method. #Clearly, to ensure fairness in the comparison, all the various CAT settings are kept the same across all simulations, starting with this one ##Setting---- library(ShadowCAT) library(catIrt) library(dplyr) #Creating the matrices containing the different item parameters. library(readxl) Parametri <- read_excel("Parametri.xlsx") Parametri<-as.data.frame(Parametri) library(readxl) ID <- read_excel("ID.xlsx") library(readxl) PhiL <- read_excel("PhiL .xlsx") library(readxl) errorvar <- read_excel("errorvar.xlsx") library(readxl) IDtotale <- read_excel("IDtotale.xlsx") errorvar<-as.matrix(errorvar) row.names(errorvar)<-ID$ID row.names(Parametri)<-ID$ID Alpha<-as.matrix(Parametri$alpha) row.names(Alpha)<-rownames(Parametri) Beta<-as.matrix(Parametri$beta) row.names(Beta)<-rownames(Parametri) PhiL<-as.matrix(PhiL) row.names(PhiL)<-ID$ID parametri<-as.matrix(cbind(Parametri[,1],Parametri[,2],c=0)) colnames(parametri)<-c("a","b","c") row.names(parametri)<-rownames(Parametri) parametritime<-as.matrix(cbind(Parametri[,3],Parametri[,4])) colnames(parametritime)<-c("phi","lamda") row.names(parametritime)<-rownames(Parametri) model <- "3PLM"#Chosing the IRT model. It' a 3pl model, but we fixed the guessing to be zero, so it's a 2pl model. start_items <- list(type = 'random', n = 5) stop_test <- list(min_n = 6, max_n = 35, target = NULL) #Chosing the sopping rule estimator <- "maximum_aposteriori" #Chosing the estimator method information_summary <- "posterior_determinant" #Chosing the information criterion prior_form <- "normal" prior_parameters <- list(mu = 0, Sigma = diag(1))#Chosing the prior form N=100##Sample size bias<-matrix(data=NA,nrow=N,ncol=1) RMSE<-matrix(data=NA,nrow=N,ncol=1) Estimates<-matrix(data=NA,nrow=N,ncol=1) #Creating the empty matrix for the results perccheater<-0.2 #Percentage of cheaters. It is fixed for each simulation percprek<-0.5 #Percentage of preknowledge. In the different simulation we utilized 3 different values: 0.5; 0.75; 1. cheaters<-matrix(data=0,nrow=N,ncol=1) set.seed(1234) cheaters[,1][sample(nrow(cheaters),N*perccheater)]<-1 #Creating the table in whic is indicated if a test taker is a cheater or not library(MASS) #Creating the correlation matrix for speed and ability sample_size <- N sample_meanvector <- c(0, 0) sample_covariance_matrix <- matrix(c(0.5, -0.15,-0.15 , 0.1), ncol = 2)#N.B. We utilized real values from a previos study on Italian students performances set.seed(1234) sample_distribution <- mvrnorm(n = sample_size, mu = sample_meanvector, Sigma = sample_covariance_matrix) personp<-as.data.frame(sample_distribution) colnames(personp)<-c("Ability","Speed")#Simulating jointly ability and speed for (n in 1:N) { ##Starting the simulation for every test taker---- J<-100 #Number of tests simulated for each individual estimates<-matrix(data=NA,nrow=J,ncol=1) colnames(estimates) <- "estimate" preknowledge<-matrix(data=0,nrow=340,ncol=1) row.names(preknowledge)<-IDtotale$ID if (cheaters[n,] == 0) { preknowledge<-matrix(data=0,nrow=340,ncol=1) row.names(preknowledge)<-IDtotale$ID } else { preknowledge1<-matrix(data=0,nrow=170,ncol=1) set.seed(1234*n) preknowledge1[,1][sample(nrow(preknowledge1),170*percprek)]<-1 preknowledge2<-matrix(data=0,nrow=170,ncol=1) preknowledge<-as.matrix(rbind(preknowledge1,preknowledge2)) row.names(preknowledge)<-IDtotale$ID } #This if-else statement determines how the subject will respond to the questions. #In fact, if they have pre-knowledge, they will always answer correctly; #otherwise, the response will be simulated based on their ability and the psychometric characteristics of the items. for (j in 1:J) { #Starting Items for each test taker. set.seed(1234*j*n) call<- my_shadowcat(answers = NULL, estimate = 0, variance = 1, model = model, alpha = Alpha, beta = Beta, start_items = start_items, stop_test = stop_test, guessing = NULL, estimator = estimator, information_summary = information_summary, prior_form = prior_form, prior_parameters = prior_parameters) param<-t(as.matrix(parametri[call$key_new_item[1],])) rownames(param)<-call$key_new_item[1] paramt<-t(as.matrix(parametritime[call$key_new_item[1],])) rownames(paramt)<-call$key_new_item[1] prek<-t(as.matrix(preknowledge[call$key_new_item[1],])) rownames(prek)<-call$key_new_item[1] error<-t(as.matrix(errorvar[call$key_new_item[1],])) rownames(error)<-call$key_new_item[1] set.seed(1234) Y<-simIrt(theta = personp[n,1], params = param, mod = "brm")[1] if (prek==0) { answers<-as.data.frame(Y) rownames(answers)<-call$key_new_item colnames(answers) <- "resp" } else { answers<-as.data.frame(1) rownames(answers)<-call$key_new_item colnames(answers) <- "resp" } #The first item and the following four items are RANDOMLY selected WITHOUT constraints for (k in 1:4) { set.seed(1234*j*n) call<- my_shadowcat(answers = answers, estimate = call$estimate, variance = call$variance, model = model, alpha = Alpha, beta = Beta, start_items = start_items, stop_test = stop_test, guessing = NULL, estimator = estimator, information_summary = information_summary, prior_form = prior_form, prior_parameters = prior_parameters) paramtemp<-t(as.matrix(parametri[call$key_new_item[1],])) rownames(paramtemp)<-call$key_new_item[1] param<-as.matrix(rbind(param,paramtemp)) paramtempt<-t(as.matrix(parametritime[call$key_new_item[1],])) rownames(paramtempt)<-call$key_new_item[1] paramt<-as.matrix(rbind(paramt,paramtempt)) prektemp<-t(as.matrix(preknowledge[call$key_new_item[1],])) rownames(prektemp)<-call$key_new_item[1] prek<-as.matrix(rbind(prek,prektemp)) errortemp<-t(as.matrix(errorvar[call$key_new_item[1],])) rownames(errortemp)<-call$key_new_item[1] error<-as.matrix(rbind(error,errortemp)) set.seed(1234) Y<-simIrt(theta = personp[n,1], params = param, mod = "brm")[1] index<-1+k if (prektemp==0) { anstemp<- as.data.frame(Y$resp[,index]) rownames(anstemp) <- call$key_new_item colnames(anstemp) <- "resp" } else { anstemp<- as.data.frame(1) rownames(anstemp) <- call$key_new_item colnames(anstemp) <- "resp" } answers<-as.matrix(rbind(answers,anstemp)) } #Subsequent items up to the 35th for each individual for (i in 6:35) { set.seed(1234*j*n) call<- my_shadowcat(answers = answers, estimate = call$estimate, variance = call$variance, model = model, alpha = Alpha, beta = Beta, start_items = start_items, stop_test = stop_test, guessing = NULL, estimator = estimator, information_summary = information_summary, prior_form = prior_form, prior_parameters = prior_parameters) paramtemp<-t(as.matrix(parametri[call$key_new_item[1],])) rownames(paramtemp)<-call$key_new_item[1] param<-as.matrix(rbind(param,paramtemp)) paramtempt<-t(as.matrix(parametritime[call$key_new_item[1],])) rownames(paramtempt)<-call$key_new_item[1] paramt<-as.matrix(rbind(paramt,paramtempt)) prektemp<-t(as.matrix(preknowledge[call$key_new_item[1],])) rownames(prektemp)<-call$key_new_item[1] prek<-as.matrix(rbind(prek,prektemp)) errortemp<-t(as.matrix(errorvar[call$key_new_item[1],])) rownames(errortemp)<-call$key_new_item[1] error<-as.matrix(rbind(error,errortemp)) set.seed(1234*n*j) Y<-simIrt(theta = personp[n,1], params = param, mod = "brm")[1] index<-i if (prektemp==0) { anstemp<- as.data.frame(Y$resp[,index]) rownames(anstemp) <- call$key_new_item colnames(anstemp) <- "resp" } else { anstemp<- as.data.frame(1) rownames(anstemp) <- call$key_new_item colnames(anstemp) <- "resp" } answers<-as.matrix(rbind(answers,anstemp)) } id<-as.data.frame(rownames(answers)) params<-as.data.frame(Parametri[,1:2]) params<-params[id$`rownames(answers)`,] params<-as.matrix(params) params<-cbind(params,c=0) answers<-t(answers) est <- mleEst(resp = answers, params = params, mod = "brm")$theta var<-(mleEst(resp = answers, params = params, mod = "brm")$sem)^2 answers<-t(answers) estimates[j,]<-est } #After estimating the J abilities for the n-th test taker, we compute the biases and the RMSE. distortions<-estimates-personp[n,1] colnames(distortions)<- "distortions" distortionsQuad<-(estimates-personp[n,1])^2 distortion<-mean(distortions) ###Calculating the mean distortion for each test taker distortionQuad<-mean(distortionsQuad) bias[n,]<-distortion RMSE[n,]<-distortionQuad estimate<-mean(estimates) Estimates[n,]<-estimate } bias<-as.matrix(cbind(bias,cheaters)) colnames(bias)<-c("bias","cheater") bias<-as.data.frame(bias) biasCheater<-filter(bias, cheater == 1) biasNoncheater<-filter(bias, cheater == 0) biasmean<-mean(bias[,1]) biasmeanCheater<-mean(biasCheater[,1]) biasmeanNoncheater<-mean(biasNoncheater[,1]) RMSE<-as.matrix(cbind(RMSE,cheaters)) colnames(RMSE)<-c("RMSE","cheater") RMSE<-as.data.frame(RMSE) RMSECheater<-filter(RMSE, cheater == 1) RMSENoncheater<-filter(RMSE, cheater == 0) RMSEmean<-mean(RMSE[,1]) RMSEmeanCheater<-mean(RMSECheater[,1]) RMSEmeanNoncheater<-mean(RMSENoncheater[,1]) #CHIPS---- ##Setting---- #Just to be sure, let's create again the parameters' matrix library(ShadowCAT) library(catIrt) library(dplyr) library(readxl) Parametri <- read_excel("Parametri.xlsx") Parametri<-as.data.frame(Parametri) library(readxl) ID <- read_excel("ID.xlsx") library(readxl) PhiL <- read_excel("PhiL .xlsx") library(readxl) errorvar <- read_excel("errorvar.xlsx") library(readxl) IDtotale <- read_excel("IDtotale.xlsx") row.names(errorvar)<-ID$ID errorvar2<-errorvar+0.0000001 errorvarcomplete<-as.matrix(rbind(errorvar,errorvar2)) row.names(errorvarcomplete)<-IDtotale$ID row.names(Parametri)<-ID$ID Alpha<-as.matrix(Parametri$alpha) row.names(Alpha)<-rownames(Parametri) Beta<-as.matrix(Parametri$beta) row.names(Beta)<-rownames(Parametri) PhiL<-as.matrix(PhiL) row.names(PhiL)<-ID$ID #This time, create also the matrix of the "more secure" database, as a perfect mimic of the first one. #Purely for technical reasons (otherwise the algorithm would return an error), the parameters cannot be exactly the same, #so we use those from the first database and add 0.000001 Parametri2<-Parametri+0.000001 ParametriComplete<-as.matrix(rbind(Parametri,Parametri2)) row.names(ParametriComplete)<-IDtotale$ID AlphaComplete<-as.matrix(ParametriComplete[,1]) row.names(AlphaComplete)<-rownames(ParametriComplete) BetaComplete<-as.matrix(ParametriComplete[,2]) row.names(BetaComplete)<-rownames(ParametriComplete) parametri<-as.matrix(cbind(ParametriComplete[,1],ParametriComplete[,2],c=0)) colnames(parametri)<-c("a","b","c") row.names(parametri)<-rownames(ParametriComplete) parametritime<-as.matrix(cbind(ParametriComplete[,3],ParametriComplete[,4])) colnames(parametritime)<-c("phi","lamda") row.names(parametritime)<-rownames(ParametriComplete) PhiL2<-PhiL+0.000001 PhiLComplete<-as.matrix(rbind(PhiL,PhiL2)) row.names(PhiLComplete)<-IDtotale$ID #As already said, for the CAT settings we will utilize the same of the simulation without model. model <- "3PLM" start_items <- list(type = 'random', n = 5) stop_test <- list(min_n = 6, max_n = 35, target = NULL) estimator <- "maximum_aposteriori" information_summary <- "posterior_determinant" prior_form <- "normal" prior_parameters <- list(mu = 0, Sigma = diag(1)) #We create a dummy database indicating whether the item belongs to the main database or not. characteristics <- data.frame(Dummy=rep("Yes",340)) characteristics[171:340,1]<-"No" row.names(characteristics)<-IDtotale$ID constraints <- list(list(name = 'Dummy/Yes', op = '=', target = 35)) constraints_and_characteristics <- list(characteristics = characteristics, constraints = constraints) N=100 #Sample size #Creating the empty matrix for the final results bias<-matrix(data=NA,nrow=N,ncol=1) biasCorrect<-matrix(data=NA,nrow=N,ncol=1) biasINCorrect<-matrix(data=NA,nrow=N,ncol=1) RMSE<-matrix(data=NA,nrow=N,ncol=1) RMSECorrect<-matrix(data=NA,nrow=N,ncol=1) RMSEINCorrect<-matrix(data=NA,nrow=N,ncol=1) Estimates<-matrix(data=NA,nrow=N,ncol=1) EstimatesCorrect<-matrix(data=NA,nrow=N,ncol=1) EstimatesINCorrect<-matrix(data=NA,nrow=N,ncol=1) accuracy<-matrix(data=NA,nrow=N,ncol=1)#This matrix will indicate how many times the algorithm correctly classified the test takers. perccheater<-0.2 percprek<-0.5 #Again, we tested for 0.5, 0.75 and 1 fretta<-4#Choose the speed multiplier for the cheaters. p<-0.05 #Choose the alpha value for the statistical test. cheaters<-matrix(data=0,nrow=N,ncol=1)#Creating the matrix for cheaters and not cheaters set.seed(1234) cheaters[,1][sample(nrow(cheaters),N*perccheater)]<-1 interimpfit<-matrix(data=0,nrow=N,ncol=1) library(MASS) sample_size <- N sample_meanvector <- c(0, 0) sample_covariance_matrix <- matrix(c(0.5, -0.15,-0.15 , 0.1), ncol = 2)#The same values from the previous simulations set.seed(1234) sample_distribution <- mvrnorm(n = sample_size, mu = sample_meanvector, Sigma = sample_covariance_matrix) personp<-as.data.frame(sample_distribution) colnames(personp)<-c("Ability","Speed")#Again, jointly estimate of speed and ability itemseln<-matrix(data=0,nrow=340,ncol=N)#Creating the matrix of items selected for each individual row.names(itemseln)<-IDtotale$ID for (n in 1:N) { ##Starting the simulation for each test taker---- J<-100 #Number of test simulated for each test taker estimates<-matrix(data=NA,nrow=J,ncol=1) colnames(estimates) <- "estimate" classifications<-matrix(data=NA,nrow=J,ncol=1) colnames(classifications) <- "classification" classificationsvel<-matrix(data=NA,nrow=J,ncol=1) colnames(classificationsvel) <- "classificationvel" partialinterimpfit<-matrix(data=NA,nrow=J,ncol=1) #Creating matrix for the partial results preknowledge<-matrix(data=0,nrow=340,ncol=1) row.names(preknowledge)<-IDtotale$ID if (cheaters[n,] == 0) { preknowledge<-matrix(data=0,nrow=340,ncol=1) row.names(preknowledge)<-IDtotale$ID } else { preknowledge1<-matrix(data=0,nrow=170,ncol=1) set.seed(1234*n) preknowledge1[,1][sample(nrow(preknowledge1),170*percprek)]<-1 preknowledge2<-matrix(data=0,nrow=170,ncol=1) preknowledge<-as.matrix(rbind(preknowledge1,preknowledge2)) row.names(preknowledge)<-IDtotale$ID }#Again,this if-else statement determines how the subject will respond to the questions (with or without pre-knowledge) itemselj<-matrix(data=0,nrow=340,ncol=J)#creo la matrice degli item selezionati per ogni ciclo row.names(itemselj)<-IDtotale$ID for (j in 1:J) { ###Starting Items for each test taker set.seed(1234*j*n) call<- my_shadowcat(answers = NULL, estimate = 0, variance = 1, model = model, alpha = Alpha, beta = Beta, start_items = start_items, stop_test = stop_test, guessing = NULL, estimator = estimator, information_summary = information_summary, prior_form = prior_form, prior_parameters = prior_parameters) param<-t(as.matrix(parametri[call$key_new_item[1],])) rownames(param)<-call$key_new_item[1] paramt<-t(as.matrix(parametritime[call$key_new_item[1],])) rownames(paramt)<-call$key_new_item[1] paramL<-t(as.matrix(PhiLComplete[call$key_new_item[1],])) rownames(paramL)<-call$key_new_item[1] prek<-t(as.matrix(preknowledge[call$key_new_item[1],])) rownames(prek)<-call$key_new_item[1] error<-t(as.matrix(errorvarcomplete[call$key_new_item[1],])) rownames(error)<-call$key_new_item[1] set.seed(1234) Y<-simIrt(theta = personp[n,1], params = param, mod = "brm")[1] if (prek==0) { answers<-as.data.frame(Y) rownames(answers)<-call$key_new_item colnames(answers) <- "resp" } else { answers<-as.data.frame(1) rownames(answers)<-call$key_new_item colnames(answers) <- "resp" } #The first item and the following four items are selected WITHOUT constraints. for (k in 1:4) { set.seed(1234*j*n) call<- my_shadowcat(answers = answers, estimate = call$estimate, variance = call$variance, model = model, alpha = Alpha, beta = Beta, start_items = start_items, stop_test = stop_test, guessing = NULL, estimator = estimator, information_summary = information_summary, prior_form = prior_form, prior_parameters = prior_parameters) paramtemp<-t(as.matrix(parametri[call$key_new_item[1],])) rownames(paramtemp)<-call$key_new_item[1] param<-as.matrix(rbind(param,paramtemp)) paramtempt<-t(as.matrix(parametritime[call$key_new_item[1],])) rownames(paramtempt)<-call$key_new_item[1] paramt<-as.matrix(rbind(paramt,paramtempt)) paramtempL<-t(as.matrix(PhiLComplete[call$key_new_item[1],])) rownames(paramtempL)<-call$key_new_item[1] paramL<-as.matrix(rbind(paramL,paramtempL)) prektemp<-t(as.matrix(preknowledge[call$key_new_item[1],])) rownames(prektemp)<-call$key_new_item[1] prek<-as.matrix(rbind(prek,prektemp)) errortemp<-t(as.matrix(errorvarcomplete[call$key_new_item[1],])) rownames(errortemp)<-call$key_new_item[1] error<-as.matrix(rbind(error,errortemp)) set.seed(1234) Y<-simIrt(theta = personp[n,1], params = param, mod = "brm")[1] index<-1+k if (prektemp==0) { anstemp<- as.data.frame(Y$resp[,index]) rownames(anstemp) <- call$key_new_item colnames(anstemp) <- "resp" } else { anstemp<- as.data.frame(1) rownames(anstemp) <- call$key_new_item colnames(anstemp) <- "resp" } answers<-as.matrix(rbind(answers,anstemp)) } #Now we simulate the corresponding response times for these 5 items times<-matrix(data=NA,nrow=5,ncol=1) #Here we check whether the subject is a cheater or a non-cheater, and then calculate their response speed accordingly. if (cheaters[n,] == 0) { for (t in 1:5) { set.seed(1234*n*j*t) times[t,]<- paramt[t,2] - paramt[t,1]*personp[n,2] + rnorm(1,mean=0,sd= (sqrt(error[t,1]))) } } else { for (t in 1:5) { if (prek[t,]== 0) { set.seed(1234*n*j*t) times[t,]<- paramt[t,2] - paramt[t,1]*personp[n,2] + rnorm(1,mean=0,sd= (sqrt(error[t,1]))) } else { set.seed(1234*n*j*t) lntreal<- paramt[t,2] - paramt[t,1]*personp[n,2] + rnorm(1,mean=0,sd= (sqrt(error[t,1]))) treal<-exp(lntreal) tfake<-treal/fretta lntfake<-log(tfake) times[t,]<- lntfake } } } #Calculating the interim person fit statistics for m=5 diffm<-matrix(data=NA,nrow=5,ncol=1) for (m in 1:5) { diffm[m,]<- (paramL[m,1]^2)*(paramt[m,2] - times[m,1]) } sumdiffm<-matrix(data=NA,nrow=5,ncol=1) sumdiffm[1,]<-diffm[1,] for (m in 2:5) { sumdiffm[m,]<- diffm[m,]+sumdiffm[m-1,] } sumphi2L<-matrix(data=NA,nrow=5,ncol=1) sumphi2L[1,]<-paramL[1,1]^2 for (m in 2:5) { sumphi2L[m,]<- paramL[m,1]^2+sumphi2L[m-1,] } expectedspeed<-matrix(data=NA,nrow=5,ncol=1) for (m in 1:5) { expectedspeed[m,]<- sumdiffm[m,]/sumphi2L[m,] } expectedtime<-matrix(data=NA,nrow=5,ncol=1) for (m in 1:5) { expectedtime[m,]<- paramt[m,2] - expectedspeed[m,] + 1/(2*(paramL[m,1]^2)) } standerrorm<-matrix(data=NA,nrow=5,ncol=1) standerrorm[1,]<-(paramL[1,1]*(times[1,]-expectedtime[1,]))^2 for (m in 2:5) { standerrorm[m,]<-(paramL[m,1]*(times[m,]-expectedtime[m,]))^2 } ltm<-matrix(data=NA,nrow=5,ncol=1) ltm[1,]<-standerrorm[1,] for (m in 2:5) { ltm[m,]<- standerrorm[m,] + ltm[m-1] } if(ltm[5,] > qchisq(p = p, df = 5, lower.tail = FALSE)) { flag<-1 }else { flag<-0 } #Now we continue the simulation for the remaining items until the end of the test for (i in 6:35) { if (flag==0) { characteristics[1:170,1]<-"Yes" characteristics[171:340,1]<-"No" }else { characteristics[1:170,1]<-"No" characteristics[171:340,1]<-"Yes" } characteristics[rownames(answers),1]<-"Yes" constraints_and_characteristics <- list(characteristics = characteristics, constraints = constraints) set.seed(1234*j*n) call<- my_shadowcat(answers = answers, estimate = call$estimate, variance = call$variance, model = model, alpha = AlphaComplete, beta = BetaComplete, start_items = start_items, stop_test = stop_test, guessing = NULL, estimator = estimator, information_summary = information_summary, prior_form = prior_form, prior_parameters = prior_parameters, constraints_and_characts = constraints_and_characteristics) paramtemp<-t(as.matrix(parametri[call$key_new_item[1],])) rownames(paramtemp)<-call$key_new_item[1] param<-as.matrix(rbind(param,paramtemp)) paramtempt<-t(as.matrix(parametritime[call$key_new_item[1],])) rownames(paramtempt)<-call$key_new_item[1] paramt<-as.matrix(rbind(paramt,paramtempt)) paramtempL<-t(as.matrix(PhiLComplete[call$key_new_item[1],])) rownames(paramtempL)<-call$key_new_item[1] paramL<-as.matrix(rbind(paramL,paramtempL)) prektemp<-t(as.matrix(preknowledge[call$key_new_item[1],])) rownames(prektemp)<-call$key_new_item[1] prek<-as.matrix(rbind(prek,prektemp)) errortemp<-t(as.matrix(errorvarcomplete[call$key_new_item[1],])) rownames(errortemp)<-call$key_new_item[1] error<-as.matrix(rbind(error,errortemp)) set.seed(1234*n*j) Y<-simIrt(theta = personp[n,1], params = param, mod = "brm")[1] index<-i if (prektemp==0) { anstemp<- as.data.frame(Y$resp[,index]) rownames(anstemp) <- call$key_new_item colnames(anstemp) <- "resp" } else { anstemp<- as.data.frame(1) rownames(anstemp) <- call$key_new_item colnames(anstemp) <- "resp" } answers<-as.matrix(rbind(answers,anstemp)) timestemp<-matrix(data=NA,nrow=1,ncol=1)#Calculating the response time of items from 6 to 35 if (cheaters[n,] == 0) { set.seed(1234*n*j*i) timestemp[1,1]<- paramt[i,2] - paramt[i,1]*personp[n,2] + rnorm(1,mean=0,sd= (sqrt(error[i,1]))) } else { if (prek[i,]== 0) { set.seed(1234*n*j*i) timestemp[1,1]<- paramt[i,2] - paramt[i,1]*personp[n,2] + rnorm(1,mean=0,sd= (sqrt(error[i,1]))) } else { set.seed(1234*n*j*i) lntreal<- paramt[i,2] - paramt[i,1]*personp[n,2] + rnorm(1,mean=0,sd= (sqrt(error[i,1]))) treal<-exp(lntreal) tfake<-treal/fretta lntfake<-log(tfake) timestemp[1,1]<- lntfake } } times<-as.matrix(rbind(times,timestemp)) #Calculating the interim person fit statistcs for m>5 diffmtemp<-(paramL[i,1]^2)*(paramt[i,2] - times[i,1]) diffm<-as.matrix(rbind(diffm,diffmtemp)) sumdiffmtemp<-matrix(data=NA,nrow=1,ncol=1) sumdiffm<-as.matrix(rbind(sumdiffm,sumdiffmtemp)) sumdiffm[i,]<- diffm[i,1]+sumdiffm[i-1,1] sumphi2Ltemp<-matrix(data=NA,nrow=1,ncol=1) sumphi2L<-as.matrix(rbind(sumphi2L,sumphi2Ltemp)) sumphi2L[i,]<- paramL[i,1]^2+sumphi2L[i-1,] expectedspeedtemp<-sumdiffm[i,]/sumphi2L[i,] expectedspeed<-as.matrix(rbind(expectedspeed,expectedspeedtemp)) expectedtimetemp<- paramt[i,2] - expectedspeed[i,] + 1/(2*(paramL[i,1]^2)) expectedtime<-as.matrix(rbind(expectedtime,expectedtimetemp)) standerrormtemp<-matrix(data=NA,nrow=1,ncol=1) standerrorm<-as.matrix(rbind(standerrorm,standerrormtemp)) standerrorm[i,]<-(paramL[i,1]*(times[i,]-expectedtime[i,]))^2 ltmtemp<-matrix(data=NA,nrow=1,ncol=1) ltm<-as.matrix(rbind(ltm,ltmtemp)) ltm[i,]<- standerrorm[i,] + ltm[i-1] if(ltm[i,] > qchisq(p = p, df = i, lower.tail = FALSE)) { flag<-1 }else { flag<-0 } } id<-as.data.frame(rownames(answers)) params<-as.data.frame(ParametriComplete[,1:2]) params<-params[id$`rownames(answers)`,] params<-as.matrix(params) params<-cbind(params,c=0) answers<-t(answers) est <- mleEst(resp = answers, params = params, mod = "brm")$theta var<-(mleEst(resp = answers, params = params, mod = "brm")$sem)^2 answers<-t(answers) estimates[j,]<-est if (flag == cheaters[n,1]) { correct<-1 } else { correct<-0 } classifications[j,]<-correct itemselj[id$`rownames(answers)`,j]<-1 partialinterimpfit[j,]<-ltm[35,1] } #After estimating the J abilities for the n-th student, we compute the biases and the RMSE distortions<-estimates-personp[n,1] colnames(distortions)<- "distortions" distortionClassification<- as.data.frame(cbind(distortions,classifications)) distortionCorrect<-filter(distortionClassification,classification==1) distortionINCorrect<-filter(distortionClassification,classification==0) distortionsQuad<-(estimates-personp[n,1])^2 distortionQuadClassification<- as.data.frame(cbind(distortionsQuad,classifications)) distortionQuadCorrect<-filter(distortionQuadClassification,classification==1) distortionQuadINCorrect<-filter(distortionQuadClassification,classification==0) estimatesdistortion<- as.data.frame(cbind(estimates,classifications)) estimatesCorrect<-filter(estimatesdistortion,classification==1) estimatesINCorrect<-filter(estimatesdistortion,classification==0) distortion<-mean(distortions) distortionQuad<-mean(distortionsQuad) estimate<-mean(estimates) bias[n,]<-distortion biasCorrect[n,]<-mean(distortionCorrect$distortions) biasINCorrect[n,]<-mean(distortionINCorrect$distortions) RMSE[n,]<-distortionQuad RMSECorrect[n,]<-mean(distortionQuadCorrect$estimate) RMSEINCorrect[n,]<-mean(distortionQuadINCorrect$estimate) Estimates[n,]<-estimate EstimatesCorrect[n,]<-mean(estimatesCorrect$estimate) EstimatesINCorrect[n,]<-mean(estimatesINCorrect$estimate) classification<-mean(classifications) accuracy[n,]<-classification itemseln[,n]<-rowMeans(itemselj) interimpfit[n,]<-mean(partialinterimpfit) } bias<-as.matrix(cbind(bias,cheaters)) colnames(bias)<-c("bias","cheater") bias<-as.data.frame(bias) biasCheater<-filter(bias, cheater == 1) biasNoncheater<-filter(bias, cheater == 0) biasmean<-mean(bias[,1]) biasmeanCheater<-mean(biasCheater[,1]) biasmeanHonest<-mean(biasNoncheater[,1]) biasCorrect<-as.matrix((cbind(biasCorrect,cheaters))) colnames(biasCorrect)<-c("bias","cheater") biasCorrect<-as.data.frame(biasCorrect) biasCorrectCheater<-filter(biasCorrect, cheater ==1) biasCorrectHonest<-filter(biasCorrect, cheater ==0) biasINCorrect<-as.matrix((cbind(biasINCorrect,cheaters))) colnames(biasINCorrect)<-c("bias","cheater") biasINCorrect<-as.data.frame(biasINCorrect) biasINCorrect<-na.omit(biasINCorrect) biasINCorrectCheater<-filter(biasINCorrect, cheater ==1) biasINCorrectHonest<-filter(biasINCorrect, cheater ==0) biasmeanINCorrectCheater<-mean(biasINCorrectCheater$bias) biasmeanINCorrectHonest<-mean(biasINCorrectHonest$bias) biasmeanCorrectCheater<-mean(biasCorrectCheater$bias) biasmeanCorrectHonest<-mean(biasCorrectHonest$bias) accuracy<-as.matrix(cbind(accuracy,cheaters)) colnames(accuracy)<-c("accuracy","cheater") accuracy<-as.data.frame(accuracy) accuracyCheater<-filter(accuracy,cheater==1) accuracyNoncheater<-filter(accuracy, cheater==0) accuracymean<-mean(accuracy[,1]) accuracymeanCheater<-mean(accuracyCheater[,1]) accuracymeanHonest<-mean(accuracyNoncheater[,1]) itemsel<-matrix(data=NA,nrow=340,ncol=1)#Creating the matrix of items selected for each individual. row.names(itemsel)<-IDtotale$ID itemsel[,1]<-rowMeans(itemseln) #Creating the error matrix confusion <- matrix(NA, nrow = 2, ncol = 2) colnames(confusion) <- c("Fail to Reject", "Reject") rownames(confusion) <- c("H0 True", "H0 False") confusion[1,1]<-accuracymeanHonest confusion[1,2]<-(1 - accuracymeanHonest) confusion[2,1]<- (1 - accuracymeanCheater) confusion[2,2]<- accuracymeanCheater #M-CHIPS---- ##Setting---- #From this point onward, the settings are the same as those of CHIPS, except for the modification. #Therefore, only the modification will be commented on in order to highlight the difference from CHIPS library(ShadowCAT) library(catIrt) library(dplyr) library(readxl) Parametri <- read_excel("Parametri.xlsx") Parametri<-as.data.frame(Parametri) library(readxl) ID <- read_excel("ID.xlsx") library(readxl) PhiL <- read_excel("PhiL .xlsx") library(readxl) errorvar <- read_excel("errorvar.xlsx") library(readxl) IDtotale <- read_excel("IDtotale.xlsx") row.names(errorvar)<-ID$ID errorvar2<-errorvar+0.0000001 errorvarcomplete<-as.matrix(rbind(errorvar,errorvar2)) row.names(errorvarcomplete)<-IDtotale$ID row.names(Parametri)<-ID$ID Alpha<-as.matrix(Parametri$alpha) row.names(Alpha)<-rownames(Parametri) Beta<-as.matrix(Parametri$beta) row.names(Beta)<-rownames(Parametri) PhiL<-as.matrix(PhiL) row.names(PhiL)<-ID$ID Parametri2<-Parametri+0.000001 ParametriComplete<-as.matrix(rbind(Parametri,Parametri2)) row.names(ParametriComplete)<-IDtotale$ID AlphaComplete<-as.matrix(ParametriComplete[,1]) row.names(AlphaComplete)<-rownames(ParametriComplete) BetaComplete<-as.matrix(ParametriComplete[,2]) row.names(BetaComplete)<-rownames(ParametriComplete) parametri<-as.matrix(cbind(ParametriComplete[,1],ParametriComplete[,2],c=0)) colnames(parametri)<-c("a","b","c") row.names(parametri)<-rownames(ParametriComplete) parametritime<-as.matrix(cbind(ParametriComplete[,3],ParametriComplete[,4])) colnames(parametritime)<-c("phi","lamda") row.names(parametritime)<-rownames(ParametriComplete) PhiL2<-PhiL+0.000001 PhiLComplete<-as.matrix(rbind(PhiL,PhiL2)) row.names(PhiLComplete)<-IDtotale$ID model <- "3PLM" start_items <- list(type = 'random', n = 5) stop_test <- list(min_n = 6, max_n = 35, target = NULL) estimator <- "maximum_aposteriori" information_summary <- "posterior_determinant" prior_form <- "normal" prior_parameters <- list(mu = 0, Sigma = diag(1)) characteristics <- data.frame(Dummy=rep("Yes",340)) characteristics[171:340,1]<-"No" row.names(characteristics)<-IDtotale$ID constraints <- list(list(name = 'Dummy/Yes', op = '=', target = 35)) constraints_and_characteristics <- list(characteristics = characteristics, constraints = constraints) N=100 bias<-matrix(data=NA,nrow=N,ncol=1) biasCorrect<-matrix(data=NA,nrow=N,ncol=1) biasINCorrect<-matrix(data=NA,nrow=N,ncol=1) RMSE<-matrix(data=NA,nrow=N,ncol=1) RMSECorrect<-matrix(data=NA,nrow=N,ncol=1) RMSEINCorrect<-matrix(data=NA,nrow=N,ncol=1) Estimates<-matrix(data=NA,nrow=N,ncol=1) EstimatesCorrect<-matrix(data=NA,nrow=N,ncol=1) EstimatesINCorrect<-matrix(data=NA,nrow=N,ncol=1) accuracy<-matrix(data=NA,nrow=N,ncol=1) accuracyvel<-matrix(data=NA,nrow=N,ncol=1) perccheater<-0.2 percprek<-0.5 fretta<-4 tresholdvel<-0.693 #This is the speed threshold value for the modification p<-0.05 cheaters<-matrix(data=0,nrow=N,ncol=1) set.seed(1234) cheaters[,1][sample(nrow(cheaters),N*perccheater)]<-1 interimpfit<-matrix(data=0,nrow=N,ncol=1) library(MASS) sample_size <- N sample_meanvector <- c(0, 0) sample_covariance_matrix <- matrix(c(0.5, -0.15,-0.15 , 0.1), ncol = 2) set.seed(1234) sample_distribution <- mvrnorm(n = sample_size, mu = sample_meanvector, Sigma = sample_covariance_matrix) personp<-as.data.frame(sample_distribution) colnames(personp)<-c("Ability","Speed") itemseln<-matrix(data=0,nrow=340,ncol=N) row.names(itemseln)<-IDtotale$ID for (n in 1:N) { ##Starting the simulation---- J<-100 estimates<-matrix(data=NA,nrow=J,ncol=1) colnames(estimates) <- "estimate" classifications<-matrix(data=NA,nrow=J,ncol=1) colnames(classifications) <- "classification" classificationsvel<-matrix(data=NA,nrow=J,ncol=1) colnames(classificationsvel) <- "classificationvel" partialinterimpfit<-matrix(data=NA,nrow=J,ncol=1) preknowledge<-matrix(data=0,nrow=340,ncol=1) row.names(preknowledge)<-IDtotale$ID if (cheaters[n,] == 0) { preknowledge<-matrix(data=0,nrow=340,ncol=1) row.names(preknowledge)<-IDtotale$ID } else { preknowledge1<-matrix(data=0,nrow=170,ncol=1) set.seed(1234*n) preknowledge1[,1][sample(nrow(preknowledge1),170*percprek)]<-1 preknowledge2<-matrix(data=0,nrow=170,ncol=1) preknowledge<-as.matrix(rbind(preknowledge1,preknowledge2)) row.names(preknowledge)<-IDtotale$ID } itemselj<-matrix(data=0,nrow=340,ncol=J) row.names(itemselj)<-IDtotale$ID for (j in 1:J) { set.seed(1234*j*n) call<- my_shadowcat(answers = NULL, estimate = 0, variance = 1, model = model, alpha = Alpha, beta = Beta, start_items = start_items, stop_test = stop_test, guessing = NULL, estimator = estimator, information_summary = information_summary, prior_form = prior_form, prior_parameters = prior_parameters) param<-t(as.matrix(parametri[call$key_new_item[1],])) rownames(param)<-call$key_new_item[1] paramt<-t(as.matrix(parametritime[call$key_new_item[1],])) rownames(paramt)<-call$key_new_item[1] paramL<-t(as.matrix(PhiLComplete[call$key_new_item[1],])) rownames(paramL)<-call$key_new_item[1] prek<-t(as.matrix(preknowledge[call$key_new_item[1],])) rownames(prek)<-call$key_new_item[1] error<-t(as.matrix(errorvarcomplete[call$key_new_item[1],])) rownames(error)<-call$key_new_item[1] set.seed(1234) Y<-simIrt(theta = personp[n,1], params = param, mod = "brm")[1] if (prek==0) { answers<-as.data.frame(Y) rownames(answers)<-call$key_new_item colnames(answers) <- "resp" } else { answers<-as.data.frame(1) rownames(answers)<-call$key_new_item colnames(answers) <- "resp" } for (k in 1:4) { set.seed(1234*j*n) call<- my_shadowcat(answers = answers, estimate = call$estimate, variance = call$variance, model = model, alpha = Alpha, beta = Beta, start_items = start_items, stop_test = stop_test, guessing = NULL, estimator = estimator, information_summary = information_summary, prior_form = prior_form, prior_parameters = prior_parameters) paramtemp<-t(as.matrix(parametri[call$key_new_item[1],])) rownames(paramtemp)<-call$key_new_item[1] param<-as.matrix(rbind(param,paramtemp)) paramtempt<-t(as.matrix(parametritime[call$key_new_item[1],])) rownames(paramtempt)<-call$key_new_item[1] paramt<-as.matrix(rbind(paramt,paramtempt)) paramtempL<-t(as.matrix(PhiLComplete[call$key_new_item[1],])) rownames(paramtempL)<-call$key_new_item[1] paramL<-as.matrix(rbind(paramL,paramtempL)) prektemp<-t(as.matrix(preknowledge[call$key_new_item[1],])) rownames(prektemp)<-call$key_new_item[1] prek<-as.matrix(rbind(prek,prektemp)) errortemp<-t(as.matrix(errorvarcomplete[call$key_new_item[1],])) rownames(errortemp)<-call$key_new_item[1] error<-as.matrix(rbind(error,errortemp)) set.seed(1234) Y<-simIrt(theta = personp[n,1], params = param, mod = "brm")[1] index<-1+k if (prektemp==0) { anstemp<- as.data.frame(Y$resp[,index]) rownames(anstemp) <- call$key_new_item colnames(anstemp) <- "resp" } else { anstemp<- as.data.frame(1) rownames(anstemp) <- call$key_new_item colnames(anstemp) <- "resp" } answers<-as.matrix(rbind(answers,anstemp)) } times<-matrix(data=NA,nrow=5,ncol=1) #Here, we apply the modification and check whether the subject is a cheater or not by calculating ONLY #their response speed and comparing it with the threshold established during the setting phase if (cheaters[n,] == 0) { for (t in 1:5) { set.seed(1234*n*j*t) times[t,]<- paramt[t,2] - paramt[t,1]*personp[n,2] + rnorm(1,mean=0,sd= (sqrt(error[t,1]))) } } else { for (t in 1:5) { if (prek[t,]== 0) { set.seed(1234*n*j*t) times[t,]<- paramt[t,2] - paramt[t,1]*personp[n,2] + rnorm(1,mean=0,sd= (sqrt(error[t,1]))) } else { set.seed(1234*n*j*t) lntreal<- paramt[t,2] - paramt[t,1]*personp[n,2] + rnorm(1,mean=0,sd= (sqrt(error[t,1]))) treal<-exp(lntreal) tfake<-treal/fretta lntfake<-log(tfake) times[t,]<- lntfake } } } #There we confront the speed with the threshold diffm<-matrix(data=NA,nrow=5,ncol=1) for (m in 1:5) { diffm[m,]<- (paramL[m,1]^2)*(paramt[m,2] - times[m,1]) } sumdiffm<-matrix(data=NA,nrow=5,ncol=1) sumdiffm[1,]<-diffm[1,] for (m in 2:5) { sumdiffm[m,]<- diffm[m,]+sumdiffm[m-1,] } sumphi2L<-matrix(data=NA,nrow=5,ncol=1) sumphi2L[1,]<-paramL[1,1]^2 for (m in 2:5) { sumphi2L[m,]<- paramL[m,1]^2+sumphi2L[m-1,] } expectedspeed<-matrix(data=NA,nrow=5,ncol=1) for (m in 1:5) { expectedspeed[m,]<- sumdiffm[m,]/sumphi2L[m,] } expectedtime<-matrix(data=NA,nrow=5,ncol=1) for (m in 1:5) { expectedtime[m,]<- paramt[m,2] - expectedspeed[m,] + 1/(2*(paramL[m,1]^2)) } standerrorm<-matrix(data=NA,nrow=5,ncol=1) standerrorm[1,]<-(paramL[1,1]*(times[1,]-expectedtime[1,]))^2 for (m in 2:5) { standerrorm[m,]<-(paramL[m,1]*(times[m,]-expectedtime[m,]))^2 } ltm<-matrix(data=NA,nrow=5,ncol=1) ltm[1,]<-standerrorm[1,] for (m in 2:5) { ltm[m,]<- standerrorm[m,] + ltm[m-1] } if(expectedspeed[5,] > tresholdvel) { flagvel<-1 }else { flagvel<-0 } #We select items from the sixth to the ninth depending on whether the response speed was #above (more secure database) or below (regular database) the threshold for (i in 6:9) { if (flagvel==0) { characteristics[1:170,1]<-"Yes" characteristics[171:340,1]<-"No" }else { characteristics[1:170,1]<-"No" characteristics[171:340,1]<-"Yes" } characteristics[rownames(answers),1]<-"Yes" constraints_and_characteristics <- list(characteristics = characteristics, constraints = constraints) set.seed(1234*j*n) call<- my_shadowcat(answers = answers, estimate = call$estimate, variance = call$variance, model = model, alpha = AlphaComplete, beta = BetaComplete, start_items = start_items, stop_test = stop_test, guessing = NULL, estimator = estimator, information_summary = information_summary, prior_form = prior_form, prior_parameters = prior_parameters, constraints_and_characts = constraints_and_characteristics) paramtemp<-t(as.matrix(parametri[call$key_new_item[1],])) rownames(paramtemp)<-call$key_new_item[1] param<-as.matrix(rbind(param,paramtemp)) paramtempt<-t(as.matrix(parametritime[call$key_new_item[1],])) rownames(paramtempt)<-call$key_new_item[1] paramt<-as.matrix(rbind(paramt,paramtempt)) paramtempL<-t(as.matrix(PhiLComplete[call$key_new_item[1],])) rownames(paramtempL)<-call$key_new_item[1] paramL<-as.matrix(rbind(paramL,paramtempL)) prektemp<-t(as.matrix(preknowledge[call$key_new_item[1],])) rownames(prektemp)<-call$key_new_item[1] prek<-as.matrix(rbind(prek,prektemp)) errortemp<-t(as.matrix(errorvarcomplete[call$key_new_item[1],])) rownames(errortemp)<-call$key_new_item[1] error<-as.matrix(rbind(error,errortemp)) set.seed(1234*n*j) Y<-simIrt(theta = personp[n,1], params = param, mod = "brm")[1] index<-i if (prektemp==0) { anstemp<- as.data.frame(Y$resp[,index]) rownames(anstemp) <- call$key_new_item colnames(anstemp) <- "resp" } else { anstemp<- as.data.frame(1) rownames(anstemp) <- call$key_new_item colnames(anstemp) <- "resp" } answers<-as.matrix(rbind(answers,anstemp)) timestemp<-matrix(data=NA,nrow=1,ncol=1) if (cheaters[n,] == 0) { set.seed(1234*n*j*i) timestemp[1,1]<- paramt[i,2] - paramt[i,1]*personp[n,2] + rnorm(1,mean=0,sd= (sqrt(error[i,1]))) } else { if (prek[i,]== 0) { set.seed(1234*n*j*i) timestemp[1,1]<- paramt[i,2] - paramt[i,1]*personp[n,2] + rnorm(1,mean=0,sd= (sqrt(error[i,1]))) } else { set.seed(1234*n*j*i) lntreal<- paramt[i,2] - paramt[i,1]*personp[n,2] + rnorm(1,mean=0,sd= (sqrt(error[i,1]))) treal<-exp(lntreal) tfake<-treal/fretta lntfake<-log(tfake) timestemp[1,1]<- lntfake } } times<-as.matrix(rbind(times,timestemp)) diffmtemp<-(paramL[i,1]^2)*(paramt[i,2] - times[i,1]) diffm<-as.matrix(rbind(diffm,diffmtemp)) sumdiffmtemp<-matrix(data=NA,nrow=1,ncol=1) sumdiffm<-as.matrix(rbind(sumdiffm,sumdiffmtemp)) sumdiffm[i,]<- diffm[i,1]+sumdiffm[i-1,1] sumphi2Ltemp<-matrix(data=NA,nrow=1,ncol=1) sumphi2L<-as.matrix(rbind(sumphi2L,sumphi2Ltemp)) sumphi2L[i,]<- paramL[i,1]^2+sumphi2L[i-1,] expectedspeedtemp<-sumdiffm[i,]/sumphi2L[i,] expectedspeed<-as.matrix(rbind(expectedspeed,expectedspeedtemp)) expectedtimetemp<- paramt[i,2] - expectedspeed[i,] + 1/(2*(paramL[i,1]^2)) expectedtime<-as.matrix(rbind(expectedtime,expectedtimetemp)) standerrormtemp<-matrix(data=NA,nrow=1,ncol=1) standerrorm<-as.matrix(rbind(standerrorm,standerrormtemp)) standerrorm[i,]<-(paramL[i,1]*(times[i,]-expectedtime[i,]))^2 ltmtemp<-matrix(data=NA,nrow=1,ncol=1) ltm<-as.matrix(rbind(ltm,ltmtemp)) ltm[i,]<- standerrorm[i,] + ltm[i-1] } if(ltm[i,] > qchisq(p = p, df = i, lower.tail = FALSE)) { flag<-1 }else { flag<-0 } for (i in 10:35) { if (flag==0) { characteristics[1:170,1]<-"Yes" characteristics[171:340,1]<-"No" }else { characteristics[1:170,1]<-"No" characteristics[171:340,1]<-"Yes" } characteristics[rownames(answers),1]<-"Yes" constraints_and_characteristics <- list(characteristics = characteristics, constraints = constraints) set.seed(1234*j*n) call<- my_shadowcat(answers = answers, estimate = call$estimate, variance = call$variance, model = model, alpha = AlphaComplete, beta = BetaComplete, start_items = start_items, stop_test = stop_test, guessing = NULL, estimator = estimator, information_summary = information_summary, prior_form = prior_form, prior_parameters = prior_parameters, constraints_and_characts = constraints_and_characteristics) paramtemp<-t(as.matrix(parametri[call$key_new_item[1],])) rownames(paramtemp)<-call$key_new_item[1] param<-as.matrix(rbind(param,paramtemp)) paramtempt<-t(as.matrix(parametritime[call$key_new_item[1],])) rownames(paramtempt)<-call$key_new_item[1] paramt<-as.matrix(rbind(paramt,paramtempt)) paramtempL<-t(as.matrix(PhiLComplete[call$key_new_item[1],])) rownames(paramtempL)<-call$key_new_item[1] paramL<-as.matrix(rbind(paramL,paramtempL)) prektemp<-t(as.matrix(preknowledge[call$key_new_item[1],])) rownames(prektemp)<-call$key_new_item[1] prek<-as.matrix(rbind(prek,prektemp)) errortemp<-t(as.matrix(errorvarcomplete[call$key_new_item[1],])) rownames(errortemp)<-call$key_new_item[1] error<-as.matrix(rbind(error,errortemp)) set.seed(1234*n*j) Y<-simIrt(theta = personp[n,1], params = param, mod = "brm")[1] index<-i if (prektemp==0) { anstemp<- as.data.frame(Y$resp[,index]) rownames(anstemp) <- call$key_new_item colnames(anstemp) <- "resp" } else { anstemp<- as.data.frame(1) rownames(anstemp) <- call$key_new_item colnames(anstemp) <- "resp" } answers<-as.matrix(rbind(answers,anstemp)) timestemp<-matrix(data=NA,nrow=1,ncol=1) if (cheaters[n,] == 0) { set.seed(1234*n*j*i) timestemp[1,1]<- paramt[i,2] - paramt[i,1]*personp[n,2] + rnorm(1,mean=0,sd= (sqrt(error[i,1]))) } else { if (prek[i,]== 0) { set.seed(1234*n*j*i) timestemp[1,1]<- paramt[i,2] - paramt[i,1]*personp[n,2] + rnorm(1,mean=0,sd= (sqrt(error[i,1]))) } else { set.seed(1234*n*j*i) lntreal<- paramt[i,2] - paramt[i,1]*personp[n,2] + rnorm(1,mean=0,sd= (sqrt(error[i,1]))) treal<-exp(lntreal) tfake<-treal/fretta lntfake<-log(tfake) timestemp[1,1]<- lntfake } } times<-as.matrix(rbind(times,timestemp)) diffmtemp<-(paramL[i,1]^2)*(paramt[i,2] - times[i,1]) diffm<-as.matrix(rbind(diffm,diffmtemp)) sumdiffmtemp<-matrix(data=NA,nrow=1,ncol=1) sumdiffm<-as.matrix(rbind(sumdiffm,sumdiffmtemp)) sumdiffm[i,]<- diffm[i,1]+sumdiffm[i-1,1] sumphi2Ltemp<-matrix(data=NA,nrow=1,ncol=1) sumphi2L<-as.matrix(rbind(sumphi2L,sumphi2Ltemp)) sumphi2L[i,]<- paramL[i,1]^2+sumphi2L[i-1,] expectedspeedtemp<-sumdiffm[i,]/sumphi2L[i,] expectedspeed<-as.matrix(rbind(expectedspeed,expectedspeedtemp)) expectedtimetemp<- paramt[i,2] - expectedspeed[i,] + 1/(2*(paramL[i,1]^2)) expectedtime<-as.matrix(rbind(expectedtime,expectedtimetemp)) standerrormtemp<-matrix(data=NA,nrow=1,ncol=1) standerrorm<-as.matrix(rbind(standerrorm,standerrormtemp)) standerrorm[i,]<-(paramL[i,1]*(times[i,]-expectedtime[i,]))^2 ltmtemp<-matrix(data=NA,nrow=1,ncol=1) ltm<-as.matrix(rbind(ltm,ltmtemp)) ltm[i,]<- standerrorm[i,] + ltm[i-1] if(ltm[i,] > qchisq(p = p, df = i, lower.tail = FALSE)) { flag<-1 }else { flag<-0 } } id<-as.data.frame(rownames(answers)) params<-as.data.frame(ParametriComplete[,1:2]) params<-params[id$`rownames(answers)`,] params<-as.matrix(params) params<-cbind(params,c=0) answers<-t(answers) est <- mleEst(resp = answers, params = params, mod = "brm")$theta var<-(mleEst(resp = answers, params = params, mod = "brm")$sem)^2 answers<-t(answers) estimates[j,]<-est if (flag == cheaters[n,1]) { correct<-1 } else { correct<-0 } if (flagvel == cheaters[n,1]) { correctvel<-1 } else { correctvel<-0 } classifications[j,]<-correct classificationsvel[j,]<-correctvel itemselj[id$`rownames(answers)`,j]<-1 partialinterimpfit[j,]<-ltm[35,1] } distortions<-estimates-personp[n,1] colnames(distortions)<- "distortions" distortionClassification<- as.data.frame(cbind(distortions,classifications)) distortionCorrect<-filter(distortionClassification,classification==1) distortionINCorrect<-filter(distortionClassification,classification==0) distortionsQuad<-(estimates-personp[n,1])^2 distortionQuadClassification<- as.data.frame(cbind(distortionsQuad,classifications)) distortionQuadCorrect<-filter(distortionQuadClassification,classification==1) distortionQuadINCorrect<-filter(distortionQuadClassification,classification==0) estimatesdistortion<- as.data.frame(cbind(estimates,classifications)) estimatesCorrect<-filter(estimatesdistortion,classification==1) estimatesINCorrect<-filter(estimatesdistortion,classification==0) distortion<-mean(distortions) distortionQuad<-mean(distortionsQuad) estimate<-mean(estimates) bias[n,]<-distortion biasCorrect[n,]<-mean(distortionCorrect$distortions) biasINCorrect[n,]<-mean(distortionINCorrect$distortions) RMSE[n,]<-distortionQuad RMSECorrect[n,]<-mean(distortionQuadCorrect$estimate) RMSEINCorrect[n,]<-mean(distortionQuadINCorrect$estimate) Estimates[n,]<-estimate EstimatesCorrect[n,]<-mean(estimatesCorrect$estimate) EstimatesINCorrect[n,]<-mean(estimatesINCorrect$estimate) classification<-mean(classifications) accuracy[n,]<-classification classificationvel<-mean(classificationsvel) accuracyvel[n,]<-classificationvel itemseln[,n]<-rowMeans(itemselj) interimpfit[n,]<-mean(partialinterimpfit) } bias<-as.matrix(cbind(bias,cheaters)) colnames(bias)<-c("bias","cheater") bias<-as.data.frame(bias) biasCheater<-filter(bias, cheater == 1) biasNoncheater<-filter(bias, cheater == 0) biasmean<-mean(bias[,1]) biasmeanCheater<-mean(biasCheater[,1]) biasmeanHonest<-mean(biasNoncheater[,1]) biasCorrect<-as.matrix((cbind(biasCorrect,cheaters))) colnames(biasCorrect)<-c("bias","cheater") biasCorrect<-as.data.frame(biasCorrect) biasCorrectCheater<-filter(biasCorrect, cheater ==1) biasCorrectHonest<-filter(biasCorrect, cheater ==0) biasINCorrect<-as.matrix((cbind(biasINCorrect,cheaters))) colnames(biasINCorrect)<-c("bias","cheater") biasINCorrect<-as.data.frame(biasINCorrect) biasINCorrect<-na.omit(biasINCorrect) biasINCorrectCheater<-filter(biasINCorrect, cheater ==1) biasINCorrectHonest<-filter(biasINCorrect, cheater ==0) biasmeanINCorrectCheater<-mean(biasINCorrectCheater$bias) biasmeanINCorrectHonest<-mean(biasINCorrectHonest$bias) biasmeanCorrectCheater<-mean(biasCorrectCheater$bias) biasmeanCorrectHonest<-mean(biasCorrectHonest$bias) accuracy<-as.matrix(cbind(accuracy,cheaters)) colnames(accuracy)<-c("accuracy","cheater") accuracy<-as.data.frame(accuracy) accuracyCheater<-filter(accuracy,cheater==1) accuracyNoncheater<-filter(accuracy, cheater==0) accuracymean<-mean(accuracy[,1]) accuracymeanCheater<-mean(accuracyCheater[,1]) accuracymeanHonest<-mean(accuracyNoncheater[,1]) accuracyvel<-as.matrix(cbind(accuracyvel,cheaters))#Calculation of accuracy with respect to the modification only. #Specifically, at the point of the fifth item, we assess how many cheaters and non-cheaters the method has #correctly identified using ONLY the estimated response speed colnames(accuracyvel)<-c("accuracyvel","cheater") accuracyvel<-as.data.frame(accuracyvel) accuracyvelCheater<-filter(accuracyvel,cheater==1) accuracyvelNoncheater<-filter(accuracyvel, cheater==0) accuracyvelmean<-mean(accuracyvel[,1]) accuracyvelmeanCheater<-mean(accuracyvelCheater[,1]) accuracyvelmeanHonest<-mean(accuracyvelNoncheater[,1]) itemsel<-matrix(data=NA,nrow=340,ncol=1) row.names(itemsel)<-IDtotale$ID itemsel[,1]<-rowMeans(itemseln) confusion <- matrix(NA, nrow = 2, ncol = 2) colnames(confusion) <- c("Fail to Reject", "Reject") rownames(confusion) <- c("H0 True", "H0 False") confusion[1,1]<-accuracymeanHonest confusion[1,2]<-(1 - accuracymeanHonest) confusion[2,1]<- (1 - accuracymeanCheater) confusion[2,2]<- accuracymeanCheater #For the additional M-CHIPS simulations (those in the Appendix), you simply need to change a few functions in the “Setting” section. Specifically:---- ##For positive correlation, set the correlation as follows:---- #sample_covariance_matrix <- matrix(c(0.5, 0.15,0.15 , 0.1), ncol = 2) ##For a higher mean ability for cheaters, set the code string as follows:---- #library(MASS) #sample_size <- N #sample_meanvector <- c(0, 0) #sample_covariance_matrix <- matrix(c(0.5, -0.15,-0.15 , 0.1),ncol = 2) #set.seed(1234) #sample_distribution <- mvrnorm(n = sample_size,mu = sample_meanvector, Sigma = sample_covariance_matrix) #personp<-as.data.frame(sample_distribution) #colnames(personp)<-c("Ability","Speed") #personp<-cbind(personp,cheaters) #personp<-filter(personp, cheaters==0) #personp<-subset(personp, select = -cheaters ) #sample_meanvector_cheater<- c(-1, 0) #sample_size_cheater<-N*perccheater #set.seed(12345) #sample_distribution_cheater <- as.data.frame(mvrnorm(n = sample_size_cheater,mu = sample_meanvector_cheater, Sigma = sample_covariance_matrix)) #colnames(sample_distribution_cheater)<-c("Ability","Speed") #personp<-rbind(personp,sample_distribution_cheater) #honest<-matrix(data=0,nrow=N*(1- perccheater),ncol=1) #cheaters_prov<-matrix(data=1,nrow=N*(perccheater),ncol=1) #cheaters<-rbind(honest,cheaters_prov) #itemseln<-matrix(data=0,nrow=340,ncol=N) #row.names(itemseln)<-IDtotale$ID ##For different alpha levels for the statistical test, modify p (p<-0.05 or p<-0.01 or p<-0.1).---- ##The only simulation that substantially changes the code is the one with variable-length tests. Below, we provide the full code.---- #Variable test length---- ##Setting---- library(ShadowCAT) library(catIrt) library(dplyr) library(readxl) Parametri <- read_excel("Parametri.xlsx") Parametri<-as.data.frame(Parametri) library(readxl) ID <- read_excel("ID.xlsx") library(readxl) PhiL <- read_excel("PhiL .xlsx") library(readxl) errorvar <- read_excel("errorvar.xlsx") library(readxl) IDtotale <- read_excel("IDtotale.xlsx") row.names(errorvar)<-ID$ID errorvar2<-errorvar+0.0000001 errorvarcomplete<-as.matrix(rbind(errorvar,errorvar2)) row.names(errorvarcomplete)<-IDtotale$ID row.names(Parametri)<-ID$ID Alpha<-as.matrix(Parametri$alpha) row.names(Alpha)<-rownames(Parametri) Beta<-as.matrix(Parametri$beta) row.names(Beta)<-rownames(Parametri) PhiL<-as.matrix(PhiL) row.names(PhiL)<-ID$ID Parametri2<-Parametri+0.000001 ParametriComplete<-as.matrix(rbind(Parametri,Parametri2)) row.names(ParametriComplete)<-IDtotale$ID AlphaComplete<-as.matrix(ParametriComplete[,1]) row.names(AlphaComplete)<-rownames(ParametriComplete) BetaComplete<-as.matrix(ParametriComplete[,2]) row.names(BetaComplete)<-rownames(ParametriComplete) parametri<-as.matrix(cbind(ParametriComplete[,1],ParametriComplete[,2],c=0)) colnames(parametri)<-c("a","b","c") row.names(parametri)<-rownames(ParametriComplete) parametritime<-as.matrix(cbind(ParametriComplete[,3],ParametriComplete[,4])) colnames(parametritime)<-c("phi","lamda") row.names(parametritime)<-rownames(ParametriComplete) PhiL2<-PhiL+0.000001 PhiLComplete<-as.matrix(rbind(PhiL,PhiL2)) row.names(PhiLComplete)<-IDtotale$ID model <- "3PLM" start_items <- list(type = 'random', n = 5) min_n= 25 max_n<-45 stop_test <- list(min_n = min_n, max_n = max_n, target = 0.1)#This time the stopping rule is non fixed. We tested 3 target valuers: 0.15,0.10,0.05 estimator <- "maximum_aposteriori" information_summary <- "posterior_determinant" prior_form <- "normal" prior_parameters <- list(mu = 0, Sigma = diag(1)) characteristics <- data.frame(Dummy=rep("Yes",340)) characteristics[171:340,1]<-"No" row.names(characteristics)<-IDtotale$ID constraints <- list(list(name = 'Dummy/Yes', op = '=', target = max_n)) constraints_and_characteristics <- list(characteristics = characteristics, constraints = constraints) N=100 bias<-matrix(data=NA,nrow=N,ncol=1) biasCorrect<-matrix(data=NA,nrow=N,ncol=1) biasINCorrect<-matrix(data=NA,nrow=N,ncol=1) RMSE<-matrix(data=NA,nrow=N,ncol=1) RMSECorrect<-matrix(data=NA,nrow=N,ncol=1) RMSEINCorrect<-matrix(data=NA,nrow=N,ncol=1) Estimates<-matrix(data=NA,nrow=N,ncol=1) EstimatesCorrect<-matrix(data=NA,nrow=N,ncol=1) EstimatesINCorrect<-matrix(data=NA,nrow=N,ncol=1) accuracy<-matrix(data=NA,nrow=N,ncol=1) accuracyvel<-matrix(data=NA,nrow=N,ncol=1) perccheater<-0.2 percprek<-0.5 fretta<-4 tresholdvel<-0.693 p<-0.05 cheaters<-matrix(data=0,nrow=N,ncol=1) set.seed(1234) cheaters[,1][sample(nrow(cheaters),N*perccheater)]<-1 interimpfit<-matrix(data=0,nrow=N,ncol=1) lunghezza<-matrix(data=0,nrow=N,ncol=1) library(MASS) sample_size <- N sample_meanvector <- c(0, 0) sample_covariance_matrix <- matrix(c(0.5, -0.15,-0.15 , 0.1), ncol = 2) set.seed(1234) sample_distribution <- mvrnorm(n = sample_size, mu = sample_meanvector, Sigma = sample_covariance_matrix) personp<-as.data.frame(sample_distribution) colnames(personp)<-c("Ability","Speed") itemseln<-matrix(data=0,nrow=340,ncol=N) row.names(itemseln)<-IDtotale$ID for (n in 1:N) { ##Starting the simulation---- J<-100 estimates<-matrix(data=NA,nrow=J,ncol=1) colnames(estimates) <- "estimate" classifications<-matrix(data=NA,nrow=J,ncol=1) colnames(classifications) <- "classification" classificationsvel<-matrix(data=NA,nrow=J,ncol=1) colnames(classificationsvel) <- "classificationvel" partialinterimpfit<-matrix(data=NA,nrow=J,ncol=1) lunghezzaJ<-matrix(data=NA,nrow=J,ncol=1) preknowledge<-matrix(data=0,nrow=340,ncol=1) row.names(preknowledge)<-IDtotale$ID if (cheaters[n,] == 0) { preknowledge<-matrix(data=0,nrow=340,ncol=1) row.names(preknowledge)<-IDtotale$ID } else { preknowledge1<-matrix(data=0,nrow=170,ncol=1) set.seed(1234*n) preknowledge1[,1][sample(nrow(preknowledge1),170*percprek)]<-1 preknowledge2<-matrix(data=0,nrow=170,ncol=1) preknowledge<-as.matrix(rbind(preknowledge1,preknowledge2)) row.names(preknowledge)<-IDtotale$ID } itemselj<-matrix(data=0,nrow=340,ncol=J) row.names(itemselj)<-IDtotale$ID for (j in 1:J) { set.seed(1234*j*n) call<- my_shadowcat(answers = NULL, estimate = 0, variance = 1, model = model, alpha = Alpha, beta = Beta, start_items = start_items, stop_test = stop_test, guessing = NULL, estimator = estimator, information_summary = information_summary, prior_form = prior_form, prior_parameters = prior_parameters) param<-t(as.matrix(parametri[call$key_new_item[1],])) rownames(param)<-call$key_new_item[1] paramt<-t(as.matrix(parametritime[call$key_new_item[1],])) rownames(paramt)<-call$key_new_item[1] paramL<-t(as.matrix(PhiLComplete[call$key_new_item[1],])) rownames(paramL)<-call$key_new_item[1] prek<-t(as.matrix(preknowledge[call$key_new_item[1],])) rownames(prek)<-call$key_new_item[1] error<-t(as.matrix(errorvarcomplete[call$key_new_item[1],])) rownames(error)<-call$key_new_item[1] set.seed(1234) Y<-simIrt(theta = personp[n,1], params = param, mod = "brm")[1] if (prek==0) { answers<-as.data.frame(Y) rownames(answers)<-call$key_new_item colnames(answers) <- "resp" } else { answers<-as.data.frame(1) rownames(answers)<-call$key_new_item colnames(answers) <- "resp" } for (k in 1:4) { set.seed(1234*j*n) call<- my_shadowcat(answers = answers, estimate = call$estimate, variance = call$variance, model = model, alpha = Alpha, beta = Beta, start_items = start_items, stop_test = stop_test, guessing = NULL, estimator = estimator, information_summary = information_summary, prior_form = prior_form, prior_parameters = prior_parameters) paramtemp<-t(as.matrix(parametri[call$key_new_item[1],])) rownames(paramtemp)<-call$key_new_item[1] param<-as.matrix(rbind(param,paramtemp)) paramtempt<-t(as.matrix(parametritime[call$key_new_item[1],])) rownames(paramtempt)<-call$key_new_item[1] paramt<-as.matrix(rbind(paramt,paramtempt)) paramtempL<-t(as.matrix(PhiLComplete[call$key_new_item[1],])) rownames(paramtempL)<-call$key_new_item[1] paramL<-as.matrix(rbind(paramL,paramtempL)) prektemp<-t(as.matrix(preknowledge[call$key_new_item[1],])) rownames(prektemp)<-call$key_new_item[1] prek<-as.matrix(rbind(prek,prektemp)) errortemp<-t(as.matrix(errorvarcomplete[call$key_new_item[1],])) rownames(errortemp)<-call$key_new_item[1] error<-as.matrix(rbind(error,errortemp)) set.seed(1234) Y<-simIrt(theta = personp[n,1], params = param, mod = "brm")[1] index<-1+k if (prektemp==0) { anstemp<- as.data.frame(Y$resp[,index]) rownames(anstemp) <- call$key_new_item colnames(anstemp) <- "resp" } else { anstemp<- as.data.frame(1) rownames(anstemp) <- call$key_new_item colnames(anstemp) <- "resp" } answers<-as.matrix(rbind(answers,anstemp)) } times<-matrix(data=NA,nrow=5,ncol=1) if (cheaters[n,] == 0) { for (t in 1:5) { set.seed(1234*n*j*t) times[t,]<- paramt[t,2] - paramt[t,1]*personp[n,2] + rnorm(1,mean=0,sd= (sqrt(error[t,1]))) } } else { for (t in 1:5) { if (prek[t,]== 0) { set.seed(1234*n*j*t) times[t,]<- paramt[t,2] - paramt[t,1]*personp[n,2] + rnorm(1,mean=0,sd= (sqrt(error[t,1]))) } else { set.seed(1234*n*j*t) lntreal<- paramt[t,2] - paramt[t,1]*personp[n,2] + rnorm(1,mean=0,sd= (sqrt(error[t,1]))) treal<-exp(lntreal) tfake<-treal/fretta lntfake<-log(tfake) times[t,]<- lntfake } } } diffm<-matrix(data=NA,nrow=5,ncol=1) for (m in 1:5) { diffm[m,]<- (paramL[m,1]^2)*(paramt[m,2] - times[m,1]) } sumdiffm<-matrix(data=NA,nrow=5,ncol=1) sumdiffm[1,]<-diffm[1,] for (m in 2:5) { sumdiffm[m,]<- diffm[m,]+sumdiffm[m-1,] } sumphi2L<-matrix(data=NA,nrow=5,ncol=1) sumphi2L[1,]<-paramL[1,1]^2 for (m in 2:5) { sumphi2L[m,]<- paramL[m,1]^2+sumphi2L[m-1,] } expectedspeed<-matrix(data=NA,nrow=5,ncol=1) for (m in 1:5) { expectedspeed[m,]<- sumdiffm[m,]/sumphi2L[m,] } expectedtime<-matrix(data=NA,nrow=5,ncol=1) for (m in 1:5) { expectedtime[m,]<- paramt[m,2] - expectedspeed[m,] + 1/(2*(paramL[m,1]^2)) } standerrorm<-matrix(data=NA,nrow=5,ncol=1) standerrorm[1,]<-(paramL[1,1]*(times[1,]-expectedtime[1,]))^2 for (m in 2:5) { standerrorm[m,]<-(paramL[m,1]*(times[m,]-expectedtime[m,]))^2 } ltm<-matrix(data=NA,nrow=5,ncol=1) ltm[1,]<-standerrorm[1,] for (m in 2:5) { ltm[m,]<- standerrorm[m,] + ltm[m-1] } if(expectedspeed[5,] > tresholdvel) { flagvel<-1 }else { flagvel<-0 } for (i in 6:9) { if (flagvel==0) { characteristics[1:170,1]<-"Yes" characteristics[171:340,1]<-"No" }else { characteristics[1:170,1]<-"No" characteristics[171:340,1]<-"Yes" } characteristics[rownames(answers),1]<-"Yes" constraints_and_characteristics <- list(characteristics = characteristics, constraints = constraints) set.seed(1234*j*n) call<- my_shadowcat(answers = answers, estimate = call$estimate, variance = call$variance, model = model, alpha = AlphaComplete, beta = BetaComplete, start_items = start_items, stop_test = stop_test, guessing = NULL, estimator = estimator, information_summary = information_summary, prior_form = prior_form, prior_parameters = prior_parameters, constraints_and_characts = constraints_and_characteristics) paramtemp<-t(as.matrix(parametri[call$key_new_item[1],])) rownames(paramtemp)<-call$key_new_item[1] param<-as.matrix(rbind(param,paramtemp)) paramtempt<-t(as.matrix(parametritime[call$key_new_item[1],])) rownames(paramtempt)<-call$key_new_item[1] paramt<-as.matrix(rbind(paramt,paramtempt)) paramtempL<-t(as.matrix(PhiLComplete[call$key_new_item[1],])) rownames(paramtempL)<-call$key_new_item[1] paramL<-as.matrix(rbind(paramL,paramtempL)) prektemp<-t(as.matrix(preknowledge[call$key_new_item[1],])) rownames(prektemp)<-call$key_new_item[1] prek<-as.matrix(rbind(prek,prektemp)) errortemp<-t(as.matrix(errorvarcomplete[call$key_new_item[1],])) rownames(errortemp)<-call$key_new_item[1] error<-as.matrix(rbind(error,errortemp)) set.seed(1234*n*j) Y<-simIrt(theta = personp[n,1], params = param, mod = "brm")[1] index<-i if (prektemp==0) { anstemp<- as.data.frame(Y$resp[,index]) rownames(anstemp) <- call$key_new_item colnames(anstemp) <- "resp" } else { anstemp<- as.data.frame(1) rownames(anstemp) <- call$key_new_item colnames(anstemp) <- "resp" } answers<-as.matrix(rbind(answers,anstemp)) timestemp<-matrix(data=NA,nrow=1,ncol=1) if (cheaters[n,] == 0) { set.seed(1234*n*j*i) timestemp[1,1]<- paramt[i,2] - paramt[i,1]*personp[n,2] + rnorm(1,mean=0,sd= (sqrt(error[i,1]))) } else { if (prek[i,]== 0) { set.seed(1234*n*j*i) timestemp[1,1]<- paramt[i,2] - paramt[i,1]*personp[n,2] + rnorm(1,mean=0,sd= (sqrt(error[i,1]))) } else { set.seed(1234*n*j*i) lntreal<- paramt[i,2] - paramt[i,1]*personp[n,2] + rnorm(1,mean=0,sd= (sqrt(error[i,1]))) treal<-exp(lntreal) tfake<-treal/fretta lntfake<-log(tfake) timestemp[1,1]<- lntfake } } times<-as.matrix(rbind(times,timestemp)) diffmtemp<-(paramL[i,1]^2)*(paramt[i,2] - times[i,1]) diffm<-as.matrix(rbind(diffm,diffmtemp)) sumdiffmtemp<-matrix(data=NA,nrow=1,ncol=1) sumdiffm<-as.matrix(rbind(sumdiffm,sumdiffmtemp)) sumdiffm[i,]<- diffm[i,1]+sumdiffm[i-1,1] sumphi2Ltemp<-matrix(data=NA,nrow=1,ncol=1) sumphi2L<-as.matrix(rbind(sumphi2L,sumphi2Ltemp)) sumphi2L[i,]<- paramL[i,1]^2+sumphi2L[i-1,] expectedspeedtemp<-sumdiffm[i,]/sumphi2L[i,] expectedspeed<-as.matrix(rbind(expectedspeed,expectedspeedtemp)) expectedtimetemp<- paramt[i,2] - expectedspeed[i,] + 1/(2*(paramL[i,1]^2)) expectedtime<-as.matrix(rbind(expectedtime,expectedtimetemp)) standerrormtemp<-matrix(data=NA,nrow=1,ncol=1) standerrorm<-as.matrix(rbind(standerrorm,standerrormtemp)) standerrorm[i,]<-(paramL[i,1]*(times[i,]-expectedtime[i,]))^2 ltmtemp<-matrix(data=NA,nrow=1,ncol=1) ltm<-as.matrix(rbind(ltm,ltmtemp)) ltm[i,]<- standerrorm[i,] + ltm[i-1] } if(ltm[i,] > qchisq(p = p, df = i, lower.tail = FALSE)) { flag<-1 }else { flag<-0 } for (i in 10:170) {#This time we hypothesize a total test length equal to the complete database. Of course the algorithm will interrupt previously, reached the target value if (flag==0) { characteristics[1:170,1]<-"Yes" characteristics[171:340,1]<-"No" }else { characteristics[1:170,1]<-"No" characteristics[171:340,1]<-"Yes" } characteristics[rownames(answers),1]<-"Yes" constraints_and_characteristics <- list(characteristics = characteristics, constraints = constraints) set.seed(1234*j*n) call<- my_shadowcat(answers = answers, estimate = call$estimate, variance = call$variance, model = model, alpha = AlphaComplete, beta = BetaComplete, start_items = start_items, stop_test = stop_test, guessing = NULL, estimator = estimator, information_summary = information_summary, prior_form = prior_form, prior_parameters = prior_parameters, constraints_and_characts = constraints_and_characteristics) Continue<-as.character(call$continue_test) if (Continue == FALSE) { break } else { paramtemp<-t(as.matrix(parametri[call$key_new_item[1],])) rownames(paramtemp)<-call$key_new_item[1] param<-as.matrix(rbind(param,paramtemp)) paramtempt<-t(as.matrix(parametritime[call$key_new_item[1],])) rownames(paramtempt)<-call$key_new_item[1] paramt<-as.matrix(rbind(paramt,paramtempt)) paramtempL<-t(as.matrix(PhiLComplete[call$key_new_item[1],])) rownames(paramtempL)<-call$key_new_item[1] paramL<-as.matrix(rbind(paramL,paramtempL)) prektemp<-t(as.matrix(preknowledge[call$key_new_item[1],])) rownames(prektemp)<-call$key_new_item[1] prek<-as.matrix(rbind(prek,prektemp)) errortemp<-t(as.matrix(errorvarcomplete[call$key_new_item[1],])) rownames(errortemp)<-call$key_new_item[1] error<-as.matrix(rbind(error,errortemp)) set.seed(1234*n*j) Y<-simIrt(theta = personp[n,1], params = param, mod = "brm")[1] index<-i if (prektemp==0) { anstemp<- as.data.frame(Y$resp[,index]) rownames(anstemp) <- call$key_new_item colnames(anstemp) <- "resp" } else { anstemp<- as.data.frame(1) rownames(anstemp) <- call$key_new_item colnames(anstemp) <- "resp" } answers<-as.matrix(rbind(answers,anstemp)) timestemp<-matrix(data=NA,nrow=1,ncol=1) if (cheaters[n,] == 0) { set.seed(1234*n*j*i) timestemp[1,1]<- paramt[i,2] - paramt[i,1]*personp[n,2] + rnorm(1,mean=0,sd= (sqrt(error[i,1]))) } else { if (prek[i,]== 0) { set.seed(1234*n*j*i) timestemp[1,1]<- paramt[i,2] - paramt[i,1]*personp[n,2] + rnorm(1,mean=0,sd= (sqrt(error[i,1]))) } else { set.seed(1234*n*j*i) lntreal<- paramt[i,2] - paramt[i,1]*personp[n,2] + rnorm(1,mean=0,sd= (sqrt(error[i,1]))) treal<-exp(lntreal) tfake<-treal/fretta lntfake<-log(tfake) timestemp[1,1]<- lntfake } } times<-as.matrix(rbind(times,timestemp)) diffmtemp<-(paramL[i,1]^2)*(paramt[i,2] - times[i,1]) diffm<-as.matrix(rbind(diffm,diffmtemp)) sumdiffmtemp<-matrix(data=NA,nrow=1,ncol=1) sumdiffm<-as.matrix(rbind(sumdiffm,sumdiffmtemp)) sumdiffm[i,]<- diffm[i,1]+sumdiffm[i-1,1] sumphi2Ltemp<-matrix(data=NA,nrow=1,ncol=1) sumphi2L<-as.matrix(rbind(sumphi2L,sumphi2Ltemp)) sumphi2L[i,]<- paramL[i,1]^2+sumphi2L[i-1,] expectedspeedtemp<-sumdiffm[i,]/sumphi2L[i,] expectedspeed<-as.matrix(rbind(expectedspeed,expectedspeedtemp)) expectedtimetemp<- paramt[i,2] - expectedspeed[i,] + 1/(2*(paramL[i,1]^2)) expectedtime<-as.matrix(rbind(expectedtime,expectedtimetemp)) standerrormtemp<-matrix(data=NA,nrow=1,ncol=1) standerrorm<-as.matrix(rbind(standerrorm,standerrormtemp)) standerrorm[i,]<-(paramL[i,1]*(times[i,]-expectedtime[i,]))^2 ltmtemp<-matrix(data=NA,nrow=1,ncol=1) ltm<-as.matrix(rbind(ltm,ltmtemp)) ltm[i,]<- standerrorm[i,] + ltm[i-1] if(ltm[i,] > qchisq(p = p, df = i, lower.tail = FALSE)) { flag<-1 }else { flag<-0 } } } id<-as.data.frame(rownames(answers)) params<-as.data.frame(ParametriComplete[,1:2]) params<-params[id$`rownames(answers)`,] params<-as.matrix(params) params<-cbind(params,c=0) answers<-t(answers) est <- mleEst(resp = answers, params = params, mod = "brm")$theta var<-(mleEst(resp = answers, params = params, mod = "brm")$sem)^2 answers<-t(answers) estimates[j,]<-est if (flag == cheaters[n,1]) { correct<-1 } else { correct<-0 } if (flagvel == cheaters[n,1]) { correctvel<-1 } else { correctvel<-0 } classifications[j,]<-correct classificationsvel[j,]<-correctvel itemselj[id$`rownames(answers)`,j]<-1 partialinterimpfit[j,]<-ltm[index,1] lunghezzaJ[j,]<-index } distortions<-estimates-personp[n,1] colnames(distortions)<- "distortions" distortionClassification<- as.data.frame(cbind(distortions,classifications)) distortionCorrect<-filter(distortionClassification,classification==1) distortionINCorrect<-filter(distortionClassification,classification==0) distortionsQuad<-(estimates-personp[n,1])^2 distortionQuadClassification<- as.data.frame(cbind(distortionsQuad,classifications)) distortionQuadCorrect<-filter(distortionQuadClassification,classification==1) distortionQuadINCorrect<-filter(distortionQuadClassification,classification==0) estimatesdistortion<- as.data.frame(cbind(estimates,classifications)) estimatesCorrect<-filter(estimatesdistortion,classification==1) estimatesINCorrect<-filter(estimatesdistortion,classification==0) distortion<-mean(distortions) distortionQuad<-mean(distortionsQuad) estimate<-mean(estimates) bias[n,]<-distortion biasCorrect[n,]<-mean(distortionCorrect$distortions) biasINCorrect[n,]<-mean(distortionINCorrect$distortions) RMSE[n,]<-distortionQuad RMSECorrect[n,]<-mean(distortionQuadCorrect$estimate) RMSEINCorrect[n,]<-mean(distortionQuadINCorrect$estimate) Estimates[n,]<-estimate EstimatesCorrect[n,]<-mean(estimatesCorrect$estimate) EstimatesINCorrect[n,]<-mean(estimatesINCorrect$estimate) classification<-mean(classifications) accuracy[n,]<-classification classificationvel<-mean(classificationsvel) accuracyvel[n,]<-classificationvel itemseln[,n]<-rowMeans(itemselj) interimpfit[n,]<-mean(partialinterimpfit) meanlunghezzaJ<-mean(lunghezzaJ[,1]) lunghezza[n,]<-meanlunghezzaJ } bias<-as.matrix(cbind(bias,cheaters)) colnames(bias)<-c("bias","cheater") bias<-as.data.frame(bias) biasCheater<-filter(bias, cheater == 1) biasNoncheater<-filter(bias, cheater == 0) biasmean<-mean(bias[,1]) biasmeanCheater<-mean(biasCheater[,1]) biasmeanHonest<-mean(biasNoncheater[,1]) biasCorrect<-as.matrix((cbind(biasCorrect,cheaters))) colnames(biasCorrect)<-c("bias","cheater") biasCorrect<-as.data.frame(biasCorrect) biasCorrect<-na.omit(biasCorrect) biasCorrectCheater<-filter(biasCorrect, cheater ==1) biasCorrectHonest<-filter(biasCorrect, cheater ==0) biasINCorrect<-as.matrix((cbind(biasINCorrect,cheaters))) colnames(biasINCorrect)<-c("bias","cheater") biasINCorrect<-as.data.frame(biasINCorrect) biasINCorrect<-na.omit(biasINCorrect) biasINCorrectCheater<-filter(biasINCorrect, cheater ==1) biasINCorrectHonest<-filter(biasINCorrect, cheater ==0) biasmeanINCorrectCheater<-mean(biasINCorrectCheater$bias) biasmeanINCorrectHonest<-mean(biasINCorrectHonest$bias) biasmeanCorrectCheater<-mean(biasCorrectCheater$bias) biasmeanCorrectHonest<-mean(biasCorrectHonest$bias) accuracy<-as.matrix(cbind(accuracy,cheaters)) colnames(accuracy)<-c("accuracy","cheater") accuracy<-as.data.frame(accuracy) accuracyCheater<-filter(accuracy,cheater==1) accuracyNoncheater<-filter(accuracy, cheater==0) accuracymean<-mean(accuracy[,1]) accuracymeanCheater<-mean(accuracyCheater[,1]) accuracymeanHonest<-mean(accuracyNoncheater[,1]) accuracyvel<-as.matrix(cbind(accuracyvel,cheaters)) colnames(accuracyvel)<-c("accuracyvel","cheater") accuracyvel<-as.data.frame(accuracyvel) accuracyvelCheater<-filter(accuracyvel,cheater==1) accuracyvelNoncheater<-filter(accuracyvel, cheater==0) accuracyvelmean<-mean(accuracyvel[,1]) accuracyvelmeanCheater<-mean(accuracyvelCheater[,1]) accuracyvelmeanHonest<-mean(accuracyvelNoncheater[,1]) RMSE<-as.matrix(cbind(RMSE,cheaters)) colnames(RMSE)<-c("RMSE","cheater") RMSE<-as.data.frame(RMSE) RMSECheater<-filter(RMSE,cheater == 1) RMSEHonest<-filter(RMSE, cheater == 0) meanRMSE<-mean(RMSE$RMSE) meanRMSECheater<-mean(RMSECheater$RMSE) meanRMSEHonest<-mean(RMSEHonest$RMSE) RMSECorrect<-as.matrix(cbind(RMSECorrect,cheaters)) colnames(RMSECorrect)<-c("RMSE","cheater") RMSECorrect<-as.data.frame(RMSECorrect) RMSECorrectCheater<-filter(RMSECorrect, cheater ==1) meanRMSECorrectCheater<-mean(RMSECorrectCheater$RMSE) RMSEINCorrect<-as.matrix(cbind(RMSEINCorrect,cheaters)) colnames(RMSEINCorrect)<-c("RMSE","cheater") RMSEINCorrect<-as.data.frame(RMSEINCorrect) RMSEINCorrectCheater<-filter(RMSEINCorrect, cheater ==1) meanRMSEINCorrectCheater<-mean(RMSEINCorrectCheater$RMSE) itemsel<-matrix(data=NA,nrow=340,ncol=1) row.names(itemsel)<-IDtotale$ID itemsel[,1]<-rowMeans(itemseln) confusion <- matrix(NA, nrow = 2, ncol = 2) colnames(confusion) <- c("Fail to Reject", "Reject") rownames(confusion) <- c("H0 True", "H0 False") confusion[1,1]<-accuracymeanHonest confusion[1,2]<-(1 - accuracymeanHonest) confusion[2,1]<- (1 - accuracymeanCheater) confusion[2,2]<- accuracymeanCheater #The following code strings are used to create the table that provides information about the length of the simulations in terms of the number of items administered. lunghezza<-as.matrix(cbind(lunghezza,cheaters)) colnames(lunghezza)<-c("lunghezza","cheater") lunghezza<-as.data.frame(lunghezza) lunghezzaCheater<-filter(lunghezza, cheater == 1) lunghezzaHonest<-filter(lunghezza, cheater == 0) lunghezzamean<-mean(lunghezza$lunghezza) lunghezzameanCheater<-mean(lunghezzaCheater$lunghezza) lunghezzameanHonest<-mean(lunghezzaHonest$lunghezza) lunghezzamin<-min(lunghezza$lunghezza) lunghezzamax<-max(lunghezza$lunghezza) lunghezzamedianCheater<-median(lunghezzaCheater$lunghezza) lunghezzamedian<-median(lunghezza$lunghezza) lunghezzamedianHonest<-median(lunghezzaHonest$lunghezza)