R/makeTree.R

In erossiter/catSurv: Computerized Adaptive Testing for Survey Research

#' Make Tree of Possible Question Combinations
#'
#' Pre-calculates a complete branching scheme of all possible questions-answer combinations and stores it as a list of lists or a flattened table of values.
#'
#' @param catObj An object of class \code{Cat}
#' @param flat A logical indicating whether to return tree as as a list of lists or a table
#'
#'
#' @details The function takes a \code{Cat} object and generates a tree of all possible question-answer combinations, conditional on previous answers in the branching scheme and the current \eqn{\theta} estimates for the branch.
#' The tree is stored as a list of lists, iteratively generated by filling in a possible answer, calculating the next question via \code{selectItem}, filling in a possible answer for that question, and so forth.
#' 
#' The length of each complete branching scheme within the tree is dictated by the \code{lengthThreshold} slot within the \code{Cat} object.
#' 
#' @return The function \code{makeTree} returns either a list or a table.  If the argument \code{flat} is \code{FALSE}, the default value, the function returns a list of lists.
#' 
#' If the argument \code{flat} is \code{TRUE}, the function takes the list of lists and configures it into a flattened table where the columns represent the battery items and the rows represent the possible answer profiles.
#' 
#' @note This function is computationally expensive.  If there are \eqn{k} response options and the researcher wants a complete branching scheme to include \eqn{n} items, \eqn{k^{n-1}} complete branching schemes will be calculated.  Setting \eqn{n} is done via the \code{lengthThreshold} slot in the \code{Cat} object.  See \strong{Examples}.
#' 
#' This function is to allow users to access the internal functions of the package. During item selection, all calculations are done in compiled \code{C++} code.
#' 
#' 
#' @seealso \code{\link{Cat-class}}, \code{\link{checkStopRules}}, \code{\link{selectItem}}
#' 
#' 
#' @examples
#' ## Loading ltm Cat object
#' data(ltm_cat)
#' 
#' ## Setting complete branches to include 3 items
#' setLengthThreshold(ltm_cat) <- 3
#' 
#' ## Object returned is list of lists
#' ltm_list <- makeTree(ltm_cat)
#' 
#' ## Object returned is table
#' ltm_table <- makeTree(ltm_cat, flat = TRUE)
#' 
#' 
#' 
#' 
#' @author Haley Acevedo, Ryden Butler, Josh W. Cutler, Matt Malis, Jacob M. Montgomery, Tom Wilkinson, Erin Rossiter, Min Hee Seo, Alex Weil 
#' 
#' @rdname makeTree
#' 
#' @export
makeTree <- function(catObj){
  UseMethod("makeTree", catObj)
}

makeTree <- function(catObj, flat = FALSE){
    qlist<-names(catObj@discrimination) ## qlist is a vector of questions
    if(length(unique(qlist))!=length(qlist)){ ## If names of questions are not unique, 
        qlist<-sapply(1:length(qlist),function(x)paste("Q",x,sep=""))} ## assign question numbers
    ## nresp is a vector of the number of possible responses for each question
    nresp<-sapply(1:length(qlist),function(x)length(catObj@difficulty[[x]])+2)
    ## rlist is a matrix of possible responses for every question
    if(catObj@model=="ltm"|catObj@model=="tpm"){
        rlist<-sapply(1:length(qlist),function(x){c(-1:(nresp[x]-2), "Next")})}
    else{rlist<-sapply(1:length(qlist),function(x){c(-1, 1:(nresp[x]-1), "Next", rep(NA,max(nresp)-(nresp)[x]))})}
    ## Variables defined above are always fixed and not to be modified below
    
    recursiveTree<-function(catObj, output, currentq){  ## To be recursively called
        ## For this call, = for this response, what is the question to be answered?
        ## Assign that question as an element, "Next", for current output as a list.
        output<-list(Next=qlist[selectItem(catObj)$next_item])
        for (i in 1:nresp[[currentq]]){ ## Loop: for each possible response
            nextcat<-storeAnswer(catObj,currentq,as.numeric(rlist[i,currentq])) ## Predict next call
            ## i.e. if your answer to current question is 'i', how would your catObj look in next call?
            if(checkStopRules(nextcat) | (sum(is.na(nextcat@answers))==1) | (catObj@lengthThreshold==sum(!is.na(nextcat@answers))) ){
                ## If one of the conditions is TRUE, adaptive inventory should stop
                #output[[rlist[i,currentq]]]<-list(Next=qlist[selectItem(nextcat)$next_item])
            }
            else{ ## If not, move on to next question with 'nextcat',
                ## with the current response, 'i', as a list of current output, which will be the new output
                ## for the next call. For the next call, 'selectItem(nextcat)$next_item)' will be
                ## the question under consideration.
                output[[rlist[i,currentq]]]<-
                    recursiveTree(catObj=nextcat, output=output[[rlist[i,currentq]]],
                                  currentq=selectItem(nextcat)$next_item)
                
            }
        }
        return(output) ## Upon finishing all of the recursive calls, return output.
    }
    ## Now that we have the recursive function, start the process with inputs for makeTree()
    tree<-recursiveTree(catObj=catObj,output=list(),currentq=selectItem(catObj)$next_item)
    
    
    ## flatten the tree or leave it as list of lists
    if(flat == FALSE){
        out <- tree
    }else{
        flattenTree <- function(tree){
            flatTree <- unlist(tree)
            names(flatTree) <- gsub("Next", "", names(flatTree))
            flatTree <- flatTree[order(nchar(names(flatTree)))]
            
            if(catObj@model == "ltm" | catObj@model == "tpm"){
                ans_choices <- c("-", 0:(nresp[1] - 2))
            } else {
                ans_choices <- c("-", 1:(nresp[1] - 1))
            }
            
            orderedTree <- flatTree[1]
            for(i in ans_choices[1:length(ans_choices)]){
                answers <- rep(NA, (length(flatTree)-1)/length(ans_choices))
                answers <- flatTree[substring(names(flatTree), 1, 1) == i]
                orderedTree <- c(orderedTree, answers)
            }
            
            flatTree <- orderedTree
            
            response_list <- strsplit(names(flatTree), "[.]")
            output <- matrix(data = NA, nrow = length(flatTree), ncol = length(catObj@answers) + 1)
            colnames(output) <- c(qlist, "NextItem")
            
            for(i in 1:length(flatTree)){
                output[i,ncol(output)] <- flatTree[i]
                if(i > 1){ 
                    output[i, output[1, ncol(output)]] <- response_list[[i]][1]
                    if(length(response_list[[i]]) > 1){
                        for(j in 1:(length(response_list[[i]])-1)){
                            output[i, flatTree[which(sapply(1:length(response_list), function(f)
                                identical(response_list[[f]], response_list[[i]][1:j])))]]  <- response_list[[i]][j+1]
                        }
                    }
                }
            }
            output <- as.table(as.matrix(output))
            return(output)
        }
        out <- flattenTree(tree)
    }
    return(out)
}