R/scoreFast.r

In psych: Procedures for Psychological, Psychometric, and Personality Research

#created 7/12/16 
#just score items without a lot of stats
#basically scoreItems with all  the stats removed\
#Parallelized July 28, 2018 and report the number of responses/scale
#added the "mollycoddle" feature March 19, 2019 to help the clueless user
"scoreFast"  <-
 function (keys,items,totals=FALSE,ilabels=NULL, missing=TRUE, impute="none",delete=TRUE,  min=NULL,max=NULL,count.responses=FALSE,digits=2) {
 
 smallFunction <- function(scale,keys) {
      if(is.null(keys)) return(NULL)
          	pos.item <- items[,which(keys[,scale] > 0)]
            neg.item <- items[,which(keys[,scale] < 0)]
          	neg.item <- max + min - neg.item
           	sub.item <- cbind(pos.item,neg.item)
           	if(count.responses) rs <- rowSums(!is.na(sub.item))
   if(totals) { scores <- rowSums(sub.item,na.rm=TRUE)} else {scores <- rowMeans(sub.item,na.rm=TRUE) } 
    if(count.responses) {return(c(scores,rs))} else {return(scores) }
  }
  
   cl <- match.call()
   if(is.data.frame(keys)) stop("I think you reversed keys and items.  I am stopping")
   raw.data <- TRUE
   if(impute == FALSE)  impute <- "none"
   if(is.list(keys)) {select <- sub("-","",unlist(keys))
      select <- select[!duplicated(select)]
      select <- select[!is.na(select)]
      #check for bad input   -- the Mollycoddle option 
if(any( !(select %in% colnames(items)) )) {
 cat("\nVariable names are incorrect. Offending items are ", select[which(!(select %in% colnames(items)))],"\n")
 stop("Improper input.  See above. ")}
       } else {
       

       
       
       
      keys <- keys2list(keys)
        select <- selectFromKeyslist(colnames(items),keys)
      select <- select[!duplicated(select)]
      select <- select[!is.na(select)]}    #added 11/23/18
      items <- items[,select,drop=FALSE]
      keynames <- colnames(keys)
      keys <- make.keys(items,keys)   #added 9/9/16 
   keys <- as.matrix(keys)   #just in case they were not matrices to start with
    n.keys <- dim(keys)[2]
    n.items <- dim(keys)[1]
     abskeys <- abs(keys)
     keynames <- colnames(keys)
   num.item <- diag(t(abskeys) %*% abskeys) #how many items in each scale
  num.ob.item <- num.item   #will be adjusted in case of impute = FALSE
    if (!missing) items <-  na.omit(items) 
    n.subjects <- dim(items)[1]
    
   items <- as.matrix(items)
    
   # response.freq <- response.frequencies(items)
    item.var <- apply(items,2,sd,na.rm=TRUE)
       bad <- which((item.var==0)|is.na(item.var))
       if((length(bad) > 0) && delete) {
       for (baddy in 1:length(bad)) {warning( "Item= ",colnames(items)[bad][baddy]  , " had no variance and was deleted from the data and the keys.")}
       items <- items[,-bad]
        keys <- as.matrix(keys[-bad,])
       
        n.items <- n.items - length(bad) 
        abskeys <- abs(keys)
        colnames(keys) <- keynames
      
        }
    item.means <- colMeans(items,na.rm=TRUE)
    if (is.null(min)) {min <- min(items,na.rm=TRUE)}
    if (is.null(max)) {max <- max(items,na.rm=TRUE)}
    # miss.rep <- rowSums(is.na(items))

     miss.rep <- (is.na(items) +0) %*% abs(keys)
    
   
    num.item <- diag(t(abskeys) %*% abskeys) #how many items in each scale
    num.ob.item <- num.item   #will be adjusted in case of impute = FALSE
   if(impute !="none") {
        miss <- which(is.na(items),arr.ind=TRUE)
        if(impute=="mean") {
       		item.means <- colMeans(items,na.rm=TRUE)   #replace missing values with means
       		items[miss]<- item.means[miss[,2]]} else { 
       		item.med   <- apply(items,2,median,na.rm=TRUE) #replace missing with medians
        	items[miss]<- item.med[miss[,2]]}   #this only works if items is a matrix
        	 scores <- items %*%  keys  #this actually does all the work but doesn't handle missing values
        
        }  else { #handle the case of missing data without imputation
           scores <- matrix(NaN,ncol=n.keys,nrow=n.subjects)

   scoresList <- mcmapply(smallFunction,c(1:n.keys),MoreArgs=list(keys=keys))  #the parallelized function
    
    }      
    
    if (is.null(ilabels)) {
    	if (totals) {#ilabels<- paste("S",1:n.keys,sep="")} else {
    	             #ilabels <- paste("A",1:n.keys,sep="")} }
  ilabels<- paste(keynames,"S",sep="-")} else {
    	             ilabels <- paste(keynames,"A",sep="-")} }
                    
 if(count.responses) { scores <- scoresList[1:n.subjects,,drop=FALSE]   #added drop  11/14/20
   responses <- scoresList[(n.subjects+1):nrow(scoresList),,drop=FALSE]
   colnames(scores) <- ilabels
   colnames(responses) <- ilabels
    results <- list(scores=scores,responses = responses)} else {
    scores <- scoresList
     colnames(scores) <- ilabels
     results <- scores}
   #class(results) <- c("psych", "score.items")
    return(results)
 }

#created July 27, 2018
"scoreVeryFast" <- function(keys,items,totals=FALSE, min=NULL,max=NULL,count.responses=FALSE) {  #just scores by addition, no imputation, nothing fancy
if(is.data.frame(keys)) stop("I think you reversed keys and items.  I am stopping")
#use this for parallelism 
smallFunction <- function(scale,keys) {
          	pos.item <- items[,which(keys[,scale] > 0)]
            neg.item <- items[,which(keys[,scale] < 0)]
          	neg.item <- max + min - neg.item
           	sub.item <- cbind(pos.item,neg.item)
           if(count.responses) rs <- rowSums(!is.na(sub.item))
   if(totals) { scores <- rowSums(sub.item,na.rm=TRUE)} else {scores <- rowMeans(sub.item,na.rm=TRUE) } 
    if(count.responses) {return(c(scores,rs))} else {return(scores) }
  }
  
 if(is.list(keys)) {select <- sub("-","",unlist(keys))
   select <- select[!duplicated(select)]
   if(any( !(select %in% colnames(items)) )) {
 cat("\nVariable names are incorrect. Offending items are ", select[which(!(select %in% colnames(items)))],"\n")
 stop("Improper input.  See above. ")}
 } else {
      keys <- keys2list(keys)
     select <- selectFromKeyslist(colnames(items),keys)
      select <- select[!duplicated(select)]}
      items <- items[,select,drop=FALSE]
      n.subjects <- NROW(items)
      keys <- make.keys(items,keys)   #added 9/9/16 
   keys <- as.matrix(keys)   #just in case they were not matrices to start with
    n.keys <- dim(keys)[2]
    n.items <- dim(keys)[1]
     abskeys <- abs(keys)
     keynames <- colnames(keys)
    if(is.null(keynames)) {if (totals) {keynames<- paste("S",1:n.keys,sep="")} else {
    	             keynames <- paste("A",1:n.keys,sep="")} }
    	             
   num.item <- diag(t(abskeys) %*% abskeys) #how many items in each scale


    n.subjects <- dim(items)[1]
    
   items <- as.matrix(items)
   scores <- matrix(NaN,ncol=n.keys,nrow=n.subjects)
  
    if (is.null(min)) {min <- min(items,na.rm=TRUE)}
    if (is.null(max)) {max <- max(items,na.rm=TRUE)}

     #use mapply for debugging, mcmapply for parallel processing
   #items are global and not passed
    scoresList <- mcmapply(smallFunction,c(1:n.keys),MoreArgs=list(keys=keys))  #the parallelized function
   
    if(count.responses) { scores <- scoresList[1:n.subjects,]
    responses <- scoresList[(n.subjects+1):nrow(scoresList),]
    
   colnames(scores) <- keynames
   colnames(responses) <- keynames
    results <- list(scores=scores,responses = responses)} else {
    
     scores <- scoresList
     colnames(scores) <- keynames
     results <- scores}
  
    return(results)
   }