R/nps.R

In brendan-r/NPS: Convenience Functions and Tests for Working With the Net Promoter Score (NPS)

#' Calculate a Net Promoter Score
#'
#' This function calculates a Net Promoter Score from a vector of
#' \emph{Recommend} scores, ideally \code{\link{numeric}} ones. An attempt will
#' be made to coerce \code{\link{factor}}, or \code{\link{character}} data.
#' \code{NA} values, either in the data, or generated by type coercion, are
#' automatically omitted from the calculation. No warning is given in the former
#' case. Net Promoter Scores generated are on a [-1,1] scale; you may want to
#' multiply them by 100 (and perhaps round them!) prior to presentation.
#'
#' @param x A vector of \emph{Recommend} scores
#' @param breaks A \code{vector} of length three, giving integer Likert scale
#'   break-points for Net Promoter categories. Best practice is to set the
#'   values you'd like to use at the start of a session, with
#'   \code{options(nps.breaks = c(0, 6, 8, 10))} (for the usual setting of 0-6
#'   being \emph{Detractors}, 7-8 being \emph{Passives} and 9-10 being
#'   \emph{Promoters}, also the package default), or whichever values you would
#'   like. However, a vector may be supplied directly.
#' @param na.rm a logical value indicating whether \code{NA} values should be
#'   stripped before the computation proceeds.
#'
#' @return a Net Promoter Score.
#' @aliases nps
#' @export
#' @seealso \code{\link{npc}}
#' @author Brendan Rocks \email{foss@@brendanrocks.com}
#' @examples
#' # This will generate 1000 dummy Likelihood to Recommend reponses
#' x <- sample(
#'   0:10, 1000, replace = TRUE,
#'   prob = c(0.02, 0.01, 0.01, 0.01, 0.01, 0.03, 0.03, 0.09, 0.22, 0.22, 0.35)
#' )
#'
#' # Here are the proportions of respondents giving each Likelihood to
#' # Recommend response
#' prop.table(table(x))
#'
#' # Here's a histrogram of the scores
#' hist(
#'   x, breaks = -1:10,
#'   col = c(rep("red", 7), rep("yellow", 2), rep("green", 2))
#' )
#'
#' # Here's a barplot. It's very similar, though for categorical responses
#' # it's often slightly easier to interpret.
#' barplot(
#'  prop.table(table(x)),
#'  col = c(rep("red", 7), rep("yellow", 2), rep("green", 2))
#' )
#'
#' # Here's the NPS
#' nps(x)
#'
#' # You can round it if you like
#' round(nps(x)) ; round(nps(x), 1)
nps <- function(x, breaks = getOption("nps.breaks"), na.rm = FALSE){
  # Break the raw scores into categories
  categories <- npc(x, breaks)

  # Throw an NA if you're supposed to
  if (any(is.na(categories)) & !na.rm) {
    return(NA)
  }

  as.numeric(nps_(table(categories)))
}

#' @name nps
#' @export
nps_ <- function(x) {
  nps_format((x[3] - x[1]) / sum(x))
}

#' Create Net Promoter Categories from Likelihood to Recommend Scores
#'
#' This function produces Net Promoter Categories for \code{\link{numeric}} or
#' \code{\link{integer}} \emph{Recommend} data
#'
#' @inheritParams nps
#' @return Net Promoter categories
#' @export
#' @seealso \code{\link{nps}}
#' @author Brendan Rocks \email{foss@@brendanrocks.com}
#' @examples
#' # The command below will generate Net Promoter categories for each point
#' # on a standard 0:10 Likelihood to Recommend scale
#' npc(0:10)
#'
#'  # Here's how scores and categories map out. Notice that scores which are
#'  # 'off the scale' drop out as missing/invalid
#' data.frame(score = -2:12, category = npc(-2:12))
#'
#' # When you have lots of data, summaries are useful
#' x <- sample(
#'   0:10, 1000, replace = TRUE,
#'   prob = c(0.02, 0.01, 0.01, 0.01, 0.01, 0.03, 0.03, 0.09, 0.22, 0.22, 0.35)
#' )
#'
#' # A Histrogram of the Likelihood to Recommend scores we just generated
#' hist(x, breaks=-1:10)
#'
#' # A look at the by nps category using summary
#' summary(npc(x))
#'
#' # As above
#' table(npc(x))
#'
#' # As a crosstabulation
#' table(x, npc(x))
#'
#' nps(x)
npc <- function(x, breaks = getOption("nps.breaks")) {

  # Warn if non-integer values have been supplied
  if (any(x %% 1 != 0)) {
    warning("Non-integer values supplied in x.")
  }

  # Warn if any values supplied are outside the range of breaks supplied
  if (any(x < min(breaks) | x > max(breaks))) {
    warning("One more more values in x are outside of range of the scale ",
            "described in 'breaks' (",
            paste0(range(getOption("nps.breaks")), collapse = " to "),
            "). They have been coerced to NA.")
  }


  # Check if any of the supplied values are outside of the range of the breaks
  # provided

  cut(x, breaks, include.lowest = TRUE,
      labels = c("Detractor", "Passive", "Promoter"))
}


#' Calculate the variance of a Net Promoter Score
#'
#' This function calculates the Net Promoter Score variance, taking a
#' \code{\link{vector}} of raw \emph{Recommend} data
#'
#' @inheritParams nps
#' @param ... Passed to non-depricated functions
#' @return \code{\link{numeric}}. The variance of the distribution, ranging from
#'   0 to 1.
#' @export
#' @seealso \code{\link{nps_var_}}, a version which works on counts or
#'   proportions of responses
#' @author Brendan Rocks \email{foss@@brendanrocks.com}
nps_var <- function(x, breaks = getOption("nps.breaks"), na.rm = FALSE) {
  # Break the raw scores into categories
  categories <- npc(x, breaks)

  # Throw an NA if you're supposed to
  if (any(is.na(categories)) & !na.rm) {
    return(NA)
  }

  # Calculate the variance from the aggregates
  nps_var_(table(categories))
}

#' @name nps_var
#' @export
nps_var_ <- function(x, na.rm = FALSE) {
  props <- as.numeric(prop.table(x))
  nps_format((props[3] + props[1]) - (props[3] - props[1]) ^ 2)
}


#' Calculate the standard error of a Net Promoter Score
#'
#' This function calculates the standard error (see below) of a Net Promoter
#' Score, taking a \code{\link{vector}} of raw \emph{Recommend} data
#'
#' @inheritParams nps_var
#' @return \code{\link{numeric}}. The variance of the distribution, ranging from
#'   0 to 1.
#' @export
#' @seealso \code{\link{nps_var}} for the variance of a Net Promoter Score.
#' @author Brendan Rocks \email{foss@@brendanrocks.com}
nps_se <- function(x, breaks = getOption("nps.breaks"), na.rm = FALSE) {
  # Break the raw scores into categories
  categories <- npc(x, breaks)

  # Throw an NA if you're supposed to
  if (any(is.na(categories)) & !na.rm) {
    return(NA)
  }

  nps_se_(table(categories))
}

#' @name nps_se
#' @export
nps_se_ <- function(x, na.rm = FALSE) {
  # Working with the multiply by 100 thing is too much of a headache during with
  # standard errors. Set to FALSE here, turn it back on before exiting
  nps.100.user_setting <- getOption("nps.100")
  options("nps.100" = FALSE)
  on.exit(options("nps.100" = nps.100.user_setting))

  nps.var <- nps_var_(x)

  # Re-set the user's preference for NPS units
  options("nps.100" = nps.100.user_setting)
  nps_format(sqrt(nps.var / sum(x)))
}

# Depricated aliases -----------------------------------------------------------

#' @name nps_var
#' @export
nps.var <- function(...) {
  nps2_name_check()
  nps_var(...)
}

#' @name nps_se
#' @export
nps.se <- function(...) {
  nps2_name_check()
  nps_se(...)
}

#' @name nps_var
#' @export
npvar <- function(...) {
  nps2_name_check()
  nps_var_(...)
}

#' @name nps_test
#' @export
nps.test <- function(...) {
  nps2_name_check()
  nps_test(...)
}