R/indicator.R

In IndexNumR: Index Number Calculation

# IndexNumR: a package for index number computation
# Copyright (C) 2018 Graham J. White (g.white@unswalumni.com)
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License
# as published by the Free Software Foundation; either version 2
# of the License, or (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, see <http://www.gnu.org/licenses/>.


#' indLaspeyres_t
#'
#' @param p1 numeric vector of prices in period 1
#' @param p0 numeric vector of prices in period 0
#' @param q0 numeric vector of quantities in period 0
#' @keywords internal
#' @noRd
indLaspeyres_t <- function(p0, p1, q0){
  sum(q0*(p1 - p0))
}

#' indPaasche_t
#'
#' @param p1 numeric vector of prices in period 1
#' @param p0 numeric vector of prices in period 0
#' @param q1 numeric vector of quantities in period 1
#' @keywords internal
#' @noRd
indPaasche_t <- function(p0, p1, q1){
  sum(q1*(p1 - p0))
}

#' indBennet_t
#'
#' @param p1 numeric vector of prices in period 1
#' @param p0 numeric vector of prices in period 0
#' @param q0 numeric vector of quantities in period 0
#' @param q1 numeric vector of quantities in period 1
#' @keywords internal
#' @noRd
indBennet_t <- function(p0, p1, q0, q1){
  sum(0.5*(q0 + q1)*(p1 - p0))
}

#' indMontgomery_t
#'
#' @param p1 numeric vector of prices in period 1
#' @param p0 numeric vector of prices in period 0
#' @param q0 numeric vector of quantities in period 0
#' @param q1 numeric vector of quantities in period 1
#' @keywords internal
#' @noRd
indMontgomery_t <- function(p0, p1, q0, q1){
  sum(((p1*q1 - p0*q0)/(log(p1*q1)-log(p0*q0)))*log(p1/p0))
}

#' Calculate a price indicator
#'
#' @description
#' This calculates a price indicator. This is calculated using the
#' differences approach to index number theory, where the change
#' in prices and quantities from one period to the next is additive.
#' Therefore, the change in total value is the sum of the change
#' in prices and the change in quantities. Such a value decomposition
#' can be obtained using \code{valueDecomposition}.
#'
#' See the vignette for more information on the calculations.
#'
#' \code{vignette(topic = "indexnumr", package = "IndexNumR")}
#'
#' @param x data frame with input data
#' @param pvar character string for the name of the price column
#' @param qvar character string for the name of the quantity column
#' @param pervar character string for the name of the time period variable
#' @param prodID character string for the name of the product ID column
#' @param method character string for the indicator method. Valid options
#' are "laspeyres", "paasche", "bennet", or "montgomery".
#' @param sample whether to use a matched sample (sample = "matched")
#' @return an nx1 matrix containing the indicator
#' @export
#' @examples
#' # compute a price indicator using the Montgomery method
#' priceIndicator(CES_sigma_2, pvar = "prices", qvar = "quantities",
#' prodID = "prodID", pervar = "time", method = "montgomery")
priceIndicator <- function(x, pvar, qvar, pervar, prodID, method,
                           sample = "matched"){

  validMethods <- c("laspeyres", "paasche", "bennet", "montgomery")
  if(!(method %in% validMethods)){
    stop("Invalid method chosen")
  }

  # check valid column names are given
  colNameCheck <- checkNames(x, c(pvar, qvar, pervar, prodID))
  if(colNameCheck$result == FALSE){
    stop(colNameCheck$message)
  }

  # check column types
  x <- checkTypes(x, pvar, qvar, pervar)

  # check that the time period variable is continuous
  timeCheck <- isContinuous(x[[pervar]])
  if(timeCheck$result == FALSE){
    stop(paste("The time period variable is not continuous.",
               "Missing periods:", timeCheck$missing))
  }

  # sort the dataset by time period and product ID
  x <- x[order(x[[pervar]], x[[prodID]]),]

  # initialise some things
  n <- max(x[[pervar]],na.rm = TRUE)
  plist <- matrix(NA, nrow = n, ncol = 1)
  naElements <- character()

  # for each time period
  for(i in 2:n){

    xt0 <- x[x[[pervar]]==i-1,]
    xt1 <- x[x[[pervar]]==i,]

    # if matching requested then remove unmatched items
    if(sample=="matched"){
      xt1 <- xt1[xt1[[prodID]] %in% unique(xt0[[prodID]]),]
      xt0 <- xt0[xt0[[prodID]] %in% unique(xt1[[prodID]]),]
    }

    # set the price index element to NA if there are no
    # matches
    if(nrow(xt1)==0){
      plist[i,1] <- NA
      naElements <- paste0(naElements, i, sep = ",")
    }
    else{
      # set p and q
      p0 <- xt0[[pvar]]
      p1 <- xt1[[pvar]]
      q0 <- xt0[[qvar]]
      q1 <- xt1[[qvar]]

      # compute the index
      switch(tolower(method),
             laspeyres = {plist[i,1] <- indLaspeyres_t(p0,p1,q0)},
             paasche = {plist[i,1] <- indPaasche_t(p0,p1,q1)},
             bennet = {plist[i,1] <- indBennet_t(p0,p1,q0,q1)},
             montgomery = {plist[i,1] <- indMontgomery_t(p0,p1,q0,q1)})
    }
  }

  if(length(naElements)>0){
    warning(paste0("The following elements of the index were set to NA because there were no matched products in the two comparison periods: ", naElements))
  }

  return(plist)

}

#' Compute a quantity indicator
#'
#' @description
#' This calculates a quantity indicator. This is calculated using the
#' differences approach to index number theory, where the change
#' in prices and quantities from one period to the next is additive.
#' Therefore, the change in total value is the sum of the change
#' in prices and the change in quantities. Such a value decomposition
#' can be obtained using \code{valueDecomposition}.
#'
#' See the vignette for more information on the calculations.
#'
#' \code{vignette(topic = "indexnumr", package = "IndexNumR")}
#'
#' @param x data frame with input data
#' @param pvar character string for the name of the price column
#' @param qvar character string for the name of the quantity column
#' @param pervar character string for the name of the time period variable
#' @param prodID character string for the name of the product ID column
#' @param method character string for the quantity indicator method. Valid options
#' are "laspeyres", "paasche", "bennet", or "montgomery".
#' @param sample whether to use a matched sample (sample = "matched")
#' @return an nx1 matrix containing the indicator
#' @export
#' @examples
#' # compute a quantity indicator using the Bennet method
#' quantityIndicator(CES_sigma_2, pvar = "prices", qvar = "quantities",
#' prodID = "prodID", pervar = "time", method = "bennet")
quantityIndicator <- function(x, pvar, qvar, pervar, prodID, method,
                            sample = "matched"){

  # call priceIndicator and switch prices/quantites
  priceIndicator(x, pvar = qvar, qvar = pvar, pervar, prodID, method,
                 sample)

}

#' valueDecomposition
#'
#' Perform a decomposition of value change using price
#' and quantity indicators. This is an additive decomposition
#' so that change due to price plus change due to quantity
#' equals the total value change.
#'
#' @param x data frame with input data
#' @param pvar character string for the name of the price column
#' @param qvar character string for the name of the quantity column
#' @param pervar character string for the name of the time period variable
#' @param prodID character string for the name of the product ID column
#' @param priceMethod character string for the price indicator method. Valid options
#' are "laspeyres", "paasche", "bennet", or "montgomery". This parameter also
#' determines the method used for the quantity indicator. If a laspeyres price
#' indicator is chosen, then a paasche quantity indicator is used.
#' If a paasche price indicator is used then a laspeyres quantity indicator
#' is used. For bennet and montgomery indicators, the same method is
#' used for both the price and quantity indicators.
#' @param sample whether to use a matched sample (sample = "matched")
#' @return a dataframe containing the price indicator, quantity indicator
#' the value change and the value level.
#' @export
#' @examples
#' # decompose the value changes in the CES_sigma_2 dataset using the Bennet method
#' valueDecomposition(CES_sigma_2, pvar = "prices", qvar = "quantities",
#' prodID = "prodID", pervar = "time", priceMethod = "bennet")
valueDecomposition <- function(x, pvar, qvar, pervar, prodID, priceMethod,
                                  sample = "matched"){

  # initialise some things
  n <- max(x[[pervar]])
  result <- matrix(NA, nrow = n, ncol = 4)


  p <- priceIndicator(x, pvar, qvar, pervar, prodID, priceMethod,
                      sample)

  switch(priceMethod,
         laspeyres = {quantityMethod <- "paasche"},
         paasche = {quantityMethod <- "laspeyres"},
         bennet = {quantityMethod <- "bennet"},
         montgomery = {quantityMethod <- "montgomery"})

  v <- quantityIndicator(x, pvar, qvar, pervar, prodID, quantityMethod,
                       sample)

  if(sample == "matched"){

    nextMatched <- values(x, pvar, qvar, pervar, prodID, sample = "matched",
                          matchPeriod = "following")
    previousMatched <- values(x, pvar, qvar, pervar, prodID, sample = "matched",
                              matchPeriod = "previous")

    for(i in 2:n){
      # price
      result[i,1] <- p[i,1]
      #quantity
      result[i,2] <- v[i,1]
      # value change
      result[i,3] <- previousMatched[i,1] - nextMatched[i-1,1]
      # value level
      result[i,4] <- previousMatched[i,1]
    }

  }
  else {

    value <- values(x, pvar, qvar, pervar, prodID, sample = "unmatched")

    for(i in 2:n){
      # price
      result[i,1] <- p[i,1]
      # quantity
      result[i,2] <- v[i,1]
      # value change
      result[i,3] <- value[i,1] - value[i-1,1]
      # value level
      result[i,4] <- value[i,1]
    }
  }

  result <- as.data.frame(result)
  colnames(result) <- c("price", "quantity", "changes", "values")

  return(result)

}