R/hads.R

In nrkoehler/qscorer: Procedures for Scoring Health-related Questionnaires

#' @title {Scoring the Hospital Anxiety and Depression Scale (HADS)}
#' @description {The HADS is a fourteen item instrument with 7 items relate to anxiety
#' and 7 relate to depression.
#' Zigmond and Snaith created this outcome measure specifically to avoid reliance
#' on aspects of these conditions that are also common somatic symptoms of illness,
#' for example fatigue and insomnia or hypersomnia. This, it was hoped,
#' would create a tool for the detection of anxiety and depression in people
#' with physical health problems. (see Wikipedia)}
#' @details
#' \itemize{
#' \item \code{Number of items:} {14}
#' \item \code{Item range:} {0 to 3}
#' \item \code{Reverse items:} {7, 10}
#' \item \code{Score range:} {0 - 21 for sub-scores; 0 - 42 for global score}
#' \item \code{Cut-off-values:} {\eqn{\le} 7 = "no case"; 8 to 10 =  "suspicious case"; \eqn{\ge} 11 = "definite case" (for both sub-scores)}
#' \item \code{Treatment of missing values:} \dQuote{Both sub scores are calculated if no more than one item is missing.
#' Missing values are replaced with the average score of the completed items.}
#' }
#' @references
#' Zigmond, Snaith (1983) (\url{https://doi.org/10.1111/j.1600-0447.1983.tb09716.x})
#'
#' Snaith (2003) (\url{https://dx.doi.org/10.1186\%2F1477-7525-1-29})
#' @return The function returns 7 variables:
#' \itemize{
#'  \item \code{nvalid.hads.anx:} {Number of valid values of HADS Anxiety items (MAX=7)}
#'  \item \code{nvalid.hads.dep:} {Number of valid values of HADS Depression items (MAX=7)}
#'  \item \code{score.hads.anx:} {HADS Anxiety score}
#'  \item \code{cutoff.hads.anx:} {HADS Anxiety, categorical}
#'  \item \code{score.hads.dep:} {HADS Depression score}
#'  \item \code{cutoff.hads.dep:} {HADS Depression, categorical}
#'  \item \code{score.hads.glo:} {HADS Global score}
#' }
#' @examples
#' \dontrun{
#' library(dplyr)
#' items.hads <- paste0("hads_", seq(1, 14, 1))
#' scoring_hads(mydata, items = items.hads, reverse = c(7, 10))
#' }
#' @param data a \code{\link{data.frame}} containing the HADS items
#' orderd from 1 to 14
#' @param items A character vector with the HADS item names ordered from 1 to 14,
#' or a numeric vector indicating the column numbers of the HADS items in \code{data}.
#' @param keep Logical, whether to keep the single items and  whether to return variables containing
#' the number of non-missing items on each scale for each respondent. The default is TRUE.
#' @param nvalid A numeric value indicating the number of non-missing items required for score
#' calculations. The default is 6.
#' @param digits Integer of length one: value to round to. No rounding by default.
#' @param reverse items to be scored reversely. These items can be specified either by name or by index. Default: 7, 10
#' @export
scoring_hads <- function(data, items = 1:14, keep = TRUE, nvalid = 6,
                         digits = NULL, reverse = c(7, 10)) {
  library(dplyr, warn.conflicts = FALSE)
  if (min(data[, items], na.rm = T) < 0) {
    stop("Minimum possible value for HADS items is 0")
  } else if (max(data[, items], na.rm = T) > 3) {
    stop("Maximum possible value for HADS items is 3")
  }
  # check for number of specified items
  if (length(items) != 14) {
    stop("Number of items must be 14!")
  }
  items <- items
  items.rev <- items[reverse]
  items.anx <- items[seq(1, 13, 2)]
  items.dep <- items[seq(2, 14, 2)]
  data <- data %>%
    mutate_at(vars(items.rev), list(~ 3 - .)) %>%
    mutate(
      nvalid.hads.anx = rowSums(!is.na(select(., items.anx))),
      nvalid.hads.dep = rowSums(!is.na(select(., items.dep))),
      mean.anx.temp = rowSums(select(., items.anx), na.rm = TRUE) / nvalid.hads.anx,
      mean.dep.temp = rowSums(select(., items.dep), na.rm = TRUE) / nvalid.hads.dep
    ) %>%
    mutate_at(
      vars(items.anx),
      list(~ifelse(is.na(.), mean.anx.temp, .))
    ) %>%
    mutate_at(
      vars(items.dep),
      list(~ifelse(is.na(.), mean.dep.temp, .))
    ) %>%
    mutate(
      # Anxiety
      score.temp = rowSums(select(., items.anx), na.rm = TRUE),
      score.hads.anx = ifelse(nvalid.hads.anx >= nvalid, score.temp, NA),
      cutoff.hads.anx = case_when(
        score.hads.anx >= 11 ~ "Definite case",
        score.hads.anx >= 8 ~ "Suspicious case",
        score.hads.anx < 8 ~ "No case",
        TRUE ~ as.character(NA)
      ),
      cutoff.hads.anx = factor(cutoff.hads.anx, levels = c("No case", "Suspicious case", "Definite case")),
      # Depression
      score.temp = rowSums(select(., items.dep), na.rm = TRUE),
      score.hads.dep = ifelse(nvalid.hads.dep >= nvalid, score.temp, NA),
      cutoff.hads.dep = case_when(
        score.hads.dep >= 11 ~ "Definite case",
        score.hads.dep >= 8 ~ "Suspicious case",
        score.hads.dep < 8 ~ "No case",
        TRUE ~ as.character(NA)
      ),
      cutoff.hads.dep = factor(cutoff.hads.dep, levels = c("No case", "Suspicious case", "Definite case")),
      score.hads.glo = score.hads.anx + score.hads.dep,
    ) %>%
    select(-ends_with("temp"))
  # Keep single items and nvalid variables
  if (keep == FALSE) {
    data <- data %>% select(-items, -nvalid.hads.anx, -nvalid.hads.dep)
  } else {
    data <- data
  }
  # Rounding
  if (is.numeric(digits) == TRUE) {
    data <- data %>% mutate_at(vars(starts_with('score')), list(~ round(., digits)))
  } else {
    data <- data
  }
  data
}
NULL