#' 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(...)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.