ips.tools: Tools for IPS

#The IRT functions

#' @title IRT Data File Creator
#'
#' @description Formats Responses for IRT Calibration
#'
#' @details
#' Formats a CRM-downloaded Test Responses dataframe for use
#' in IRT item calibration.
#' Similarly to original SPSS script, creates concatenated names
#' for Items and People and sorts by this.
#' Reshapes responses from long to wide.
#'
#' @param responses The test responses dataframe (see import.responses)
#' @param write boolean (default = FALSE)- write to .txt file for Winsteps use
#' @param form The form code (only necessary if write = TRUE)
#' @return A response dataframe formatted to be the Winsteps data file
#' @examples irt.createdata(ResponseImport, TRUE, "AB2017A_01")
#' @family IRT Calibration
irt.createdata <- function(responses, write, form){
  #create column ItemNameConcat for sorting - scored + domain + item
  responses$ItemNameConcat <- NA
  responses$ItemNameConcat <- paste(ifelse(responses$ItemStatus=="Scored", "S", "X"), responses$DomainNumber, "_", responses$ItemName, sep="")
  #sort by candidate, attempt, and ItemNameConcat
  responses <- responses[order(responses$ClientCandidateId, responses$AttemptNumber, responses$ItemNameConcat),]
  #subset out only first attempt test-takers
  responses<-subset(responses, AttemptNumber==1)

  #new column ClientNameConcat = candidate id + attempt number (first only) + form id (space delineated with leading zeros)
  responses$ClientNameConcat <- NA
  responses$ClientNameConcat <- paste(sprintf("%06d", responses$ClientCandidateId), sprintf("%02d", responses$AttemptNumber), responses$Form, sep=" ")
  #temp dataframe w/ only client annd item id concats and item score
  responses <- subset(responses, select = c("ClientNameConcat", "ItemNameConcat", "ItemScore"))
  #moves temp dataframe from wide to long, rows = client cols = item
  responses <-reshape(responses, idvar = "ClientNameConcat", timevar= "ItemNameConcat", direction = "wide")
  #re-sort to ensure items in correct order
  responses <- responses[, order(names(responses))]
  #add trailing whitespace to ClientNameConcat
  responses$ClientNameConcat <- sprintf("%-45s", responses$ClientNameConcat)

  if (!missing(write)){
    if(write){
      #write dataframe to working directory, file name = form + _DATA.txt, no quotes, delineations, row/col names, etc.
      write.table(responses, paste(form, "_DATA.txt", sep = ""), sep="", quote = FALSE, row.names = FALSE, col.names = FALSE, na=" ")
    }
  }

  return(responses)
}


#' @title IRT Item Weight File Creator
#'
#' @description Formats Item Weights for IRT Calibration
#'
#' @details
#' Creates an Item Weight file for CRM Calibration.
#' If round = 1, take Winsteps Input- data (see irt.createdata),
#' weights based on Item Status.
#' If round = 2, takes Winsteps Output- IRT Item table,
#' and weights based on Item Status, Outfit MSQ, and Displacement.
#'
#' @param data The IRT item output
#' @param write boolean (default = FALSE)- write to .txt file for Winsteps use
#' @param form The form code (only necessary if write = TRUE)
#' @param round Is this the first (1) or second(2) calibration?
#' @param outfitflag a vector of the outfit flagging parameters
#' @param displacementflag a vector of the displacement parameters
#' @return An item Weights table
#' @examples irt.itemweight(CalibrationData, TRuE, "AB2017A_01", 1, outfitflag, displacementflag)
#' @family IRT Calibration
irt.itemweight <- function(data, write, form, round, outfitflag, displacementflag){
  if(missing(write)){
    write <- FALSE
  }

  if(round == 1){
    Items <- colnames(data[2:ncol(data)])
    Items <- substr(Items, 11, 20)
    itemWeight1 <- data.frame(ItemId = Items)
    itemWeight1$rowNum <- NA
    itemWeight1$rowNum <- 1:nrow(itemWeight1)
    itemWeight1$Weight <- NA
    itemWeight1$Weight <- ifelse(grepl("X", itemWeight1$ItemId), 0, 1)

    if(write){
      write.table(
        subset(itemWeight1, Weight == 0, select = c(rowNum, Weight)),
        file = paste(form, "_Item_Weight_", round, ".txt", sep = ""), quote = FALSE, row.names = FALSE, col.names = FALSE)

    }
    return(itemWeight)
  }

  if(round == 2){
    #weight items by outfit_msq
    data$WEIGHT <- with(data, ifelse(is.na(OUT.MSQ) | WEIGHT==0, 0,
                                                     ifelse(OUT.MSQ < outfitflag[1] | OUT.MSQ > outfitflag[2], 0, 1)))

    #weight items by displacement
    data$WEIGHT <- with(data, ifelse(is.na(DISPLACE) | WEIGHT==0, 0,
                                                     ifelse(abs(DISPLACE) > abs(displacementflag[1]), 0, 1)))

    data$WeightOutfit <- NA
    data$WeightOutfit <- with(data, ifelse(OUT.MSQ < outfitflag[1], "; item Outfit too low", ifelse(OUT.MSQ > outfitflag[2], "; item Outfit too high", NA)))
    data$WeightDisplace <- NA
    data$WeightDisplace <- with(data, ifelse(abs(DISPLACE) > abs(displacementflag[1]), "; item Displacement too high", NA))
    data$WeightReason <- paste(data$WeightOutfit, data$WeightDisplace, sep = " ")
    itemWeight <- subset(data, select = c(ENTRY, WEIGHT, WeightReason))

    if(write){
      write.table(
        subset(itemWeight, WEIGHT==0),
        file = paste(form, "_Item_Weight", round, ".txt", sep=""), quote = FALSE, row.names = FALSE, col.names = FALSE)
    }

    return(itemWeight)
  }
}


#' @title IRT Anchor File Creation
#'
#' @description Creates and Formats Anchors for IRT Calibration.
#'
#' @details
#' Takes a list of items being calibrated (using the concatenated
#' item name from irt.createdata), and a table of anchor items
#' (see imports.anchors).
#' Merges the two and outputs a list of anchor items-
#' they must be scored on the form, and have an IRT_b value present in
#' the anchor download.
#'
#'
#' @param items The list of items to calibrate in IRT calibration names, see irt.createdata)
#' @param anchors A table of Anchor Items (see imports.anchors)
#' @param round Is this the first (1) or second(2) calibration? (default = 1)
#' @param write boolean (default = FALSE)- write to .txt file for Winsteps use
#' @param form The form code (only necessary if write = TRUE)
#' @return An Anchor table
#' @examples irt.itemanchor(ItemList, AnchorImport, 1, TRUE, "AB2017A_01")
#' @family IRT Calibration
irt.itemanchor <- function(items, anchors, round, write, form){
  if(missing(round)) {round <- 1}
  if(round == 1){
    items <- subset(items, grepl("S", items))
    AnchorOutput <- data.frame(ItemId = substr(items, 11, 20))
    AnchorOutput$rowNum <- NA
    AnchorOutput$rowNum <- 1:nrow(AnchorOutput)

    AnchorOutput <- merge(AnchorOutput, anchors, by = "ItemId", all.x = true)

    AnchorOutput <- subset(AnchorOutput, AnchorOutput$IRT_b !="", select = c('rowNum', 'IRT_b'))

    if(!missing(write) & write){
      write.table(AnchorOutput, file = paste(form, "_Anchor_Items", round, ".txt", sep = ""), quote = FALSE, row.names = FALSE, col.names = FALSE)

    }

    return(AnchorOutput)
  }

  if(round == 2) {
    items$ItemId <- substr(items$NAME, 4, 9)
    items <- subset(items, grepl("S", items$NAME), select = c("ENTRY", "MEASURE"))
    if(!missing(write) & write){
      write.table(items, file = paste(form, "_Anchor_Items", round,".txt", sep = ""), quote = FALSE, row.names = FALSE, col.names = FALSE)

    }
    return(items)
  }
}

#' @title IRT Structure File Creation
#'
#' @description Creates and Formats Item Structures for IRT Calibration.
#'
#' @details
#' Takes a list of items being calibrated (using the concatenated
#' item name from irt.createdata), and a table of anchor items
#' (see imports.anchors).
#' Merges the two and outputs a list of anchor items-
#' they must be scored on the form, and have an IRT_b value present in
#' the anchor download.
#'
#'
#' @param items The list of items to calibrate in IRT calibration names, see irt.createdata)
#' @param anchors A table of Anchor Items (see imports.anchors)
#' @param write boolean (default = FALSE)- write to .txt file for Winsteps use
#' @param form The form code (only necessary if write = TRUE)
#' @return An item structure table
#' @examples irt.itemweight(ResponseImport, AnchorImport, 1, TRUE)
#' @family IRT Calibration
irt.itemstructure <- function(items, anchors, write, form){
  items <- subset(items, grepl("S", items))
  StructOutput <- data.frame(ItemId = substr(items, 11, 20))
  StructOutput$rowNum <- NA
  StructOutput$rowNum <- 1:nrow(StructOutput)

  StructOutput <- merge(StructOutput, anchors, by = "ItemId", all.x = true)

  StructOutput <- subset(StructOutput, StructOutput$d1 !="", select = c('rowNum', 'd1', 'd2', 'd3', 'd4'))

  if (nrow(StructOutput) != 0){
    StructOutput$Zero <- "0,.00"
    StructOutput$One <- with(StructOutput, paste("1", d1, sep = ","))
    StructOutput$Two <- with(StructOutput, paste("2", d2, sep = ","))
    StructOutput$Three <- with(StructOutput, paste("3", d3, sep = ","))
    StructOutput$Four <- with(StructOutput, paste("4", d4, sep = ","))

    StructOutput <- StructOutput[, c('rowNum', 'Zero', 'One', 'Two', 'Three', 'Four')]

    StructOutput <- reshape(StructOutput, direction = "long", idvar = "rowNum",  varying = list(2:6))

    StructOutput <- StructOutput[, c(1, 3)]

    structList <- data.frame(do.call('rbind', strsplit(StructOutput$Zero,',',fixed=TRUE)))

    StructOutput <- data.frame("order" = StructOutput$rowNum, "points" = structList[1], "value" = structList[2])

    #sort by order, points
    StructOutput <- StructOutput[order(StructOutput$order),]

    if(!missing(write)){
      if(write){
        write.table(StructOutput, file = paste(form, "_SAFile.txt", sep = ""), quote = FALSE, row.names = FALSE, col.names = FALSE, sep = "\t")

      }
    }

  }

  return(StructOutput)
}

#' @title IRT Control Card Creation
#'
#' @description Creates and Formats Control Card for IRT Calibration.
#'
#' @details
#' Takes a list of items being calibrated (using the concatenated
#' item name from irt.createdata), and a table of anchor items
#' (see imports.anchors).
#' Merges the two and outputs a list of anchor items-
#' they must be scored on the form, and have an IRT_b value present in
#' the anchor download.
#'
#' @param responses The test responses dataframe (see import.responses)
#' @param data The table used as the 'DATA' file for the IRT calibration (see irt.createdata)
#' @param struct The structure table as input for the IRT Calibration
#' @param items The list of items to calibrate in IRT calibration names, see tool.itemlist)
#' @param form The form code (only necessary if write = TRUE)
#' @param write boolean (default = FALSE)- write to .txt file for Winsteps use
#' @param round Is it the first or second calibration?
#' @return The winsteps Control Card
#' @examples irt.controlcard(ResponseImport, ResponseImportClientResults, StructOutput, ItemList, "AB2016A_01", 1, TRUE)
#' @family IRT Calibration
irt.controlcard <- function( responses, data, struct, items, form, round, write){
  title <- paste("title=", form, sep = "") #labels output w/ form name
  data <- paste("data=", form, "_DATA.txt", sep = "") #name of data file
  item1 <- "item1=46" #location (text-file column) of first item
  ni <- paste("ni=", ncol(data)-1, sep = "") #number of items
  name1 <- "name1=1" #location (text-file column) of first character of client name
  namelen<- "namelen=6" #length of client name
  csv <- "csv=Y" #outputs item/person stats as a csv
  hlines <- "hlines=Y" #header lines in output?

  # isgroups <- "isgroups=Item_Groups.txt" #item grouping file

  if(length(unique(responses$ItemType)) > 1 ){
    isgroups <- "isgroups=0" #item grouping file
  } else {isgroups <- "isgroups="}



  if(max(responses$ItemScore)>1){
    codes <- "codes="
    for (i in 0:max(responses$ItemScore)){  ###will need to change this people may not score 4
      codes <- paste(codes, i, sep = "")
    }
  }else {codes <- "codes=01"}  #list of acceptable item responses


  misscore<-"misscore=-1" #treat missing data as not administered
  totalscore<-"totalscore=Yes" #Include extreme responses in reported scores
  discrim<-"discrim=Yes" #report empirical item discriminations
  asymptote<-"asymptote=Yes" #report the values of the Upper and Lower asymptotes in the Item Tables and IFILE=
  ptbiserial<-"ptbiserial=yes" #report point-biserial
  pvalue<-"PVALUE = Yes" # report proportion-correct-values
  prcomp<-"PRCOMP = S" # Principal components analysis on standardized residuals
  udecimals<-"UDECIMALS = 5" # report out to the maximum number (4) of decimal places
  tables<-"TABLES = 101100011101010000010010" # Output select tables
  CClistStatic<-c(misscore, totalscore, discrim, asymptote,ptbiserial,pvalue,prcomp,udecimals,tables)

  # ifile <- paste("ifile=",form,"_Item_File.csv", sep = "")
  # pfile <- paste("pfile=",form,"_Person_File.csv", sep = "")
  # iafile<- paste("iafile=",form,"_Anchor_Items.txt", sep = "")
  ifile <- paste("ifile=", form, "_Item_File", round, ".csv", sep = "")
  pfile <- paste("pfile=", form, "_Person_File", round, ".csv", sep = "")
  iafile <- paste("iafile=", form,"_Anchor_Items", round, ".txt", sep = "")
  iwfile <- paste("iweight=", form,"_Item_Weight_", round, ".txt", sep = "")
  if (round > 1){
    pwfile <- paste("pweight=", form, "_Person_Weight.txt", sep="")
  }
  else {pwfile <- ""}
  safile <- ifelse(nrow(struct) == 0, "", paste("safile=", form, "_SAFile.txt", sep = ""))
  #safile <- paste("safile=", form, "_SAFile.txt", sep = "")

  #model<- "models=Item_Models.txt"
  model<- "models=R"

  controlCardText <- c("&INST", title, data, item1, ni, name1, namelen, csv, hlines,
                       codes, isgroups, ifile, pfile, iafile, iwfile, pwfile, safile, model, CClistStatic, "&END")

  controlCardText <- c(controlCardText, items, "END LABELS")

  if(!missing(write)){
    if(write){
      write(controlCardText, file = paste(form, "_Control_Card", round, ".txt", sep=""), sep="\n")
    }
  }
  return(controlCardText)
}


#' @title IRT Item Table Cleaner
#'
#' @description Formats the IRT item table for use with CTT IA.
#'
#' @details
#' Takes the IRT item table (Winsteps Output), renames the necessary columns,
#' and puts it in the standard order.
#'
#' @param itemTable The IRT item Table (Winsteps Output)
#' @return The IRT item table formatted for use wih CTT IA.
#' @examples irt.cleanupresults(IRTitemTable2)
#' @family IRT Calibration
irt.cleanupresults <- function(itemTable){

  itemTable$ItemId <- substr(itemTable$NAME, 4, 9)
  #
  reorderIRT<- c("ItemId","MEASURE","MODLSE","IN.MSQ","IN.ZSTD","OUT.MSQ","OUT.ZSTD","DISPLACE")
  #
  itemTable<- itemTable[, c(reorderIRT, setdiff(names(itemTable), reorderIRT))]
  setnames(itemTable, old = c("ItemId",'MEASURE','MODLSE','IN.MSQ','IN.ZSTD','OUT.MSQ','OUT.ZSTD','DISPLACE'), new = c('Item','irt_b','irt_b_se','infit_msq','infit_z','outfit_msq','outfit_z','displacement'))
  #
  itemTable$ExamFirstTime <- "First-Timers"
  #
  itemTable <- subset(itemTable, select = c('Item','irt_b','irt_b_se','infit_msq','infit_z','outfit_msq','outfit_z','displacement', 'ExamFirstTime'))
  ###we are missing irt_d1,irt_d2,irt_d3,irt_d4 I added some code that could add the threashold but we would have to modify above
  return(itemTable)
}

#' @title IRT Person Weight
#'
#' @description Creates a weight file for people based on
#' outfit and displacement flags.
#'
#' @details
#' Takes the IRT person table (Winsteps Output) and weights based on
#' outfit and displacement flags.
#'
#' @param data The IRT person table
#' @param write boolean (default = FALSE)- write to .txt file for Winsteps use
#' @param form The form code (only necessary if write = TRUE)
#' @param outfitflag a vector of the outfit flagging parameters
#' @param displacementflag a vector of the displacement parameters
#' @return The IRT item table formatted for use wih CTT IA.
#' @examples irt.cleanupresults(IRTitemTable2)
#' @family IRT Calibration
irt.personweight <- function(data, write, form, outfitflag, displacementflag){
  #weight people by outfit_msq
  data$WEIGHT <- with(data, ifelse(is.na(OUT.MSQ) | WEIGHT==0, 0,
                                                       ifelse(OUT.MSQ < outfitflag[1] | OUT.MSQ > outfitflag[2], 0, 1)))

  #weight people by displacement
  data$WEIGHT <- with(data, ifelse(is.na(DISPLACE) | WEIGHT==0, 0,
                                                       ifelse(abs(DISPLACE) > abs(displacementflag[1]), 0, 1)))

  data$WeightOutfit <- NA
  data$WeightOutfit <- with(data, ifelse(OUT.MSQ < outfitflag[1], "; person Outfit too low", ifelse(OUT.MSQ > outfitflag[2], "; person Outfit too high", NA)))
  data$WeightDisplace <- NA
  data$WeightDisplace <- with(data, ifelse(abs(DISPLACE) > abs(displacementflag[1]), "; person Displacement too high", NA))
  data$WeightReason <- paste(data$WeightOutfit, data$WeightDisplace, sep = " ")
  ###########################################

  personWeight <- subset(data, WEIGHT==0, select = c(ENTRY, WEIGHT, WeightReason))

  if(!missing(write)){
    if(write){
      write.table(personWeight, file = paste(form, "_Person_Weight.txt", sep=""), quote = FALSE, row.names = FALSE, col.names = FALSE)
    }
  }

  return(personWeight)

}