Questionnaire grading function

grade_questionnaire.R

grade_questionnaire <- function(dtf, n.items, item.ind = NULL, scale.names, scale.labels = NULL, start = 1:length(scale.names), end = n.items, jump, rev.ind = NULL, rev.fn = NULL, total = FALSE, total.name = NULL, allowed.values = NULL, pre.process.fn = NULL, na.rm = FALSE, ...){

  d <- subset(dtf, ...)                 # create subset if any

  nc <- ncol(d)                         # number of columns
  ## number of columns sanity check
  if (nc != n.items)
    stop(sprintf("Incorrect number of items! %d items required, while %d were provided!", n.items, nc))

  ## check scale labels
  if (!is.null(scale.labels))
    stopifnot(length(scale.labels) != length(scale.names))

  ## check allowed values
  if (!is.null(allowed.values))
    d <- lapply(d, function(x) ifelse(x %in% allowed.values, x, NA))

  ## check inverted items
  if (!is.null(rev.ind) & !is.null(rev))
    d[rev.ind] <- lapply(d[rev.ind], rev.fn)

  ## pre process function (usually for recoding)
  if (!is.null(pre.process.fn))
    d <- lapply(d, pre.process.fn)


  ## check item indices
  if (is.null(item.ind))
    ind <- mapply(seq, from = start, to = end, by = jump, SIMPLIFY = FALSE)
  else
    ind <- item.ind
  
  ## assign list names if any
  if (is.null(names(item.ind)))
    names(ind) <- scale.names

  d <- as.data.frame(d)

  res <- as.data.frame(lapply(ind, function(i) rowSums(d[i], na.rm = na.rm)))

  ## calculate total score if set
  if (total) {
    res <- cbind(res, total = rowSums(res, na.rm = na.rm))
    colnames(res)[ncol(res)] <- ifelse(is.null(total.name), paste("total", deparse(substitute(dtf)), sep = "."), as.character(total.name[1]))
  }

  return(res)
  
}