R/server.R

Defines functions server

server <- function(input, output, session) {    
    
    session$onSessionEnded(function() {
        if(!.MCE$design@stop_now){
            message('WARNING: mirtCAT GUI session unexpectedly terminated early')
            .MCE$person$terminated_sucessfully <- FALSE
        } else .MCE$person$terminated_sucessfully <- TRUE
        stopApp()
    })
    
    output$Main <- renderUI({
        dynamicUi()
    })
    
    dynamicUi <- reactive({
        
        click <- input$Next
        
        if(length(.MCE$shinyGUI$password)){
            if(click == 0L){
                if(nrow(.MCE$shinyGUI$password) > 1L)
                    return(list(textInput('UsErNaMe', label = "Login Name:"),
                                passwordInput('PaSsWoRd', 'Password:')))
                else return(passwordInput('PaSsWoRd', 'Password:'))
            } else if(click == 1L){
                .MCE$verified <- verifyPassword(input, .MCE$shinyGUI$password)
            }
            click <- click - 1L
        }
        
        if(!.MCE$verified)
            return(h3('Incorrect Login Name/Password. Please restart the application and try again.'))
        
        if(.MCE$resume_file && click < 1L){
            return(list(h5("Click the action button to continue with your session.")))
        } else {
            #skip first page? Demographics, etc
            if(!length(.MCE$shinyGUI$firstpage)) click <- click + 1L
            if(click == 0L)
                return(.MCE$shinyGUI$firstpage)
            
            #skip demographics page?
            if(!length(.MCE$shinyGUI$demographics)) click <- click + 1L
            if(click == 1L)
                return(.MCE$shinyGUI$demographics)
            
            #store demographic results
            if(click == 2L){
                tmp <- list()
                for(tag in .MCE$shinyGUI$demographic_inputIDs)
                    tmp[[length(tmp) + 1L]] <- input[[tag]]
                names(tmp) <- .MCE$shinyGUI$demographic_inputIDs
                .MCE$person$field("demographics", as.data.frame(tmp))
                if(!is.null(.MCE$last_demographics))
                    .MCE$person$demographics <- .MCE$last_demographics
                if(.MCE$shinyGUI$temp_file != '')
                    saveRDS(.MCE$person, .MCE$shinyGUI$temp_file)
            }
            
            if(.MCE$shinyGUI$begin_message == "") click <- click + 1L
            if(click == 2L)
                return(list(h5(.MCE$shinyGUI$begin_message)))
        } #end normal start
        
        if(is.null(.MCE$start_time))
            .MCE$start_time <- proc.time()[3L]
        
        if(.MCE$resume_file){
            .MCE$resume_file <- FALSE
            item <- max(which(!is.na(.MCE$person$items_answered)))
            stemOutput <- stemContent(item)
            return(list(stemOutput,.MCE$shinyGUI$df$Rendered_Question[[item]], 
                        .MCE$shinyGUI$questions[[item]]))
        }
        
        itemclick <- sum(!is.na(.MCE$person$items_answered))
        
        if(FALSE){
            cat('\nclick = ', click)
            cat('\titemclick = ', itemclick)
        }
        
        # run survey
        outmessage <- HTML(paste0("<p style='color:red;'> <em>", .MCE$shinyGUI$response_msg, "</em> </p>"))
        if(click > 2L && !.MCE$design@stop_now && !.MCE$STOP){
            if(itemclick >= 1L){
                pick <- .MCE$person$items_answered[itemclick]
                name <- .MCE$test@itemnames[pick]
                ip <- unname(input[[name]])
                if(.MCE$shinyGUI$df$Type[pick] %in% c('select', 'rankselect') && .MCE$shinyGUI$forced_choice && ip == "")
                    ip <- NULL
                if(.MCE$invalid_count > 0L)
                    ip <- input[[paste0(.MCE$invalid_count, '.TeMpInTeRnAl',name)]]
                if(!is.null(ip) && .MCE$prevClick != click && .MCE$shinyGUI$df$Type[pick] == "rankselect"){
                    nopts <- length(.MCE$test@item_options[[pick]]) - 1L
                    for(opt in 2L:nopts){
                        if(.MCE$invalid_count > 0L) ip <- c(ip, input[[paste0(.MCE$invalid_count, '.TeMpInTeRnAl',name,"_", opt)]])
                        else ip <- c(ip, input[[paste0(name, "_", opt)]])
                    }
                    if(length(ip) != length(unique(ip))){
                        outmessage <- HTML("<p style='color:red;'><em>Please provide unique rankings for each response.</em></p>")
                        ip <- NULL
                    } 
                }
                if(.MCE$shinyGUI$forced_choice && .MCE$shinyGUI$df$Type[pick] %in% c('text', 'textArea'))
                    if(ip == "") ip <- NULL
                if(!is.null(ip) && .MCE$prevClick != click){
                    ip <- as.character(ip)
                    nanswers <- length(ip)
                    .MCE$person$raw_responses[pick] <- paste0(ip, collapse = '; ')
                    if(!is.null(.MCE$test@item_options[[pick]])){
                        if(nanswers > 1L)
                            .MCE$person$responses[pick] <- sum(.MCE$test@item_options[[pick]] %in% ip)
                        else .MCE$person$responses[pick] <- which(.MCE$test@item_options[[pick]] %in% ip) - 1L
                    }
                    if(.MCE$test@item_class[pick] != 'nestlogit'){
                        if(is.function(.MCE$test@AnswerFuns[[pick]])){
                            .MCE$person$responses[pick] <- as.integer(.MCE$test@AnswerFuns[[pick]](ip))
                        } else if(!is.na(.MCE$test@item_answers[[pick]])){
                            if(nanswers > 1L)
                                .MCE$person$responses[pick] <- as.integer(sum(ip %in% .MCE$test@item_answers[[pick]]))
                            else .MCE$person$responses[pick] <- as.integer(ip %in% .MCE$test@item_answers[[pick]])
                        } 
                    }
                    if(!is.null(.MCE$shinyGUI$df$Mastery)){
                        mastery <- as.logical(.MCE$shinyGUI$df$Mastery[pick])
                        if(mastery && .MCE$person$responses[pick] == 0L){
                            outmessage <- HTML("<p style='color:red;'><em>The answer provided was incorrect. Please select an alternative.</em></p>")
                            .MCE$shift_back <- .MCE$shift_back + 1L
                            .MCE$invalid_count <- .MCE$invalid_count + 1L
                            tmp <- lapply(.MCE$shinyGUI$df, function(x, pick) x[pick], pick=pick)
                            tmp <- buildShinyElements(questions=tmp, customTypes=.MCE$shinyGUI$customTypes, 
                                                      itemnames=paste0(.MCE$invalid_count, '.TeMpInTeRnAl', name),
                                                      choiceNames=.MCE$shinyGUI$choiceNames[pick],
                                                      choiceValues=.MCE$shinyGUI$choiceValues[pick],
                                                      default = ip)
                            stemOutput <- stemContent(pick)
                            .MCE$prevClick <- click
                            return(list(stemOutput, 
                                        .MCE$shinyGUI$df$Rendered_Question[[pick]], 
                                        tmp$questions, outmessage))
                        }
                    }
                    
                    .MCE$person$item_time[pick] <- proc.time()[3L] - .MCE$start_time
                    .MCE$start_time <- NULL
                    
                    #update Thetas
                    .MCE$design@Update.thetas(design=.MCE$design, person=.MCE$person, test=.MCE$test)
                    .MCE$person$Update.info_mats(design=.MCE$design, test=.MCE$test)
                    if(.MCE$shinyGUI$temp_file != '')
                        saveRDS(.MCE$person, .MCE$shinyGUI$temp_file)
                    .MCE$design <- Update.stop_now(.MCE$design, person=.MCE$person)
                } else {
                    if(.MCE$shinyGUI$time_before_answer >= (proc.time()[3L] - .MCE$start_time) || 
                       (.MCE$shinyGUI$forced_choice && .MCE$shinyGUI$df$Type[pick] != 'none')){
                        if(.MCE$shinyGUI$time_before_answer >= (proc.time()[3L] - .MCE$start_time))
                            outmessage <- NULL
                        .MCE$shift_back <- .MCE$shift_back + 1L
                        .MCE$invalid_count <- .MCE$invalid_count + 1L
                        tmp <- lapply(.MCE$shinyGUI$df, function(x, pick) x[pick], pick=pick)
                        tmp <- buildShinyElements(questions=tmp, customTypes=.MCE$shinyGUI$customTypes, 
                                                  itemnames=paste0(.MCE$invalid_count, '.TeMpInTeRnAl', name),
                                                  choiceNames=.MCE$shinyGUI$choiceNames[pick],
                                                  choiceValues=.MCE$shinyGUI$choiceValues[pick],
                                                  default = ip)
                        stemOutput <- stemContent(pick)
                        .MCE$prevClick <- click
                        return(list(stemOutput, 
                                    .MCE$shinyGUI$df$Rendered_Question[[pick]], 
                                    tmp$questions, outmessage))
                    } else {
                        .MCE$person$item_time[pick] <- proc.time()[3L] - .MCE$start_time
                        .MCE$start_time <- NULL
                        #update Thetas (same as above)
                        .MCE$design@Update.thetas(design=.MCE$design, person=.MCE$person, test=.MCE$test)
                        .MCE$person$Update.info_mats(design=.MCE$design, test=.MCE$test)
                        if(.MCE$shinyGUI$temp_file != '')
                            saveRDS(.MCE$person, .MCE$shinyGUI$temp_file)
                        .MCE$design <- Update.stop_now(.MCE$design, person=.MCE$person)
                        .MCE$person$valid_item[pick] <- FALSE
                    }
                }
            } 
            
            .MCE$invalid_count <- 0
            .MCE$design <- Next.stage(.MCE$design, person=.MCE$person, test=.MCE$test, item=itemclick)
            
            if(!.MCE$design@stop_now){
                item <- if(all(is.na(.MCE$person$items_answered))) .MCE$design@start_item
                    else findNextCATItem(person=.MCE$person, test=.MCE$test, 
                                        design=.MCE$design, start=FALSE)
                .MCE$item <- item
                if(!is.null(attr(item, 'design'))) .MCE$design <- attr(item, 'design')
                if(is.na(item)){
                    .MCE$design@stop_now <- TRUE
                } else {
                    if(is.null(.MCE$start_time))
                        .MCE$start_time <- proc.time()[3L]
                    .MCE$person$items_answered[itemclick+1L] <- as.integer(item)
                    if(.MCE$shinyGUI$temp_file != '')
                        saveRDS(.MCE$person, .MCE$shinyGUI$temp_file)
                    stemOutput <- stemContent(item)
                    .MCE$prevClick <- click
                    if(!is.na(.MCE$shinyGUI$timer[item]))
                        invalidateLater(.MCE$shinyGUI$timer[item] * 1000)
                    return(list(stemOutput, 
                                .MCE$shinyGUI$df$Rendered_Question[[item]], 
                                .MCE$shinyGUI$questions[[item]]))
                }
            }
        }
        
        #last page
        if(!.MCE$STOP){
            .MCE$STOP <- TRUE
            if(!is.null(.MCE$final_fun)){
                ret <- mirtCAT_post_internal(person=.MCE$person, design=.MCE$design,
                                             has_answers=.MCE$test@has_answers, GUI=TRUE)
                .MCE$final_fun(person = ret)
            }
            if(.MCE$shinyGUI$temp_file != '')
                file.remove(.MCE$shinyGUI$temp_file)
            removeUI(selector = "div:has(> #Next)", immediate = TRUE)
            return(.MCE$shinyGUI$lastpage(person=.MCE$person))
        }
        
    })
}
philchalmers/mirtCAT documentation built on Sept. 10, 2018, 3:18 p.m.