R/roundWeights.R

In inca: Integer Calibration

#' @title
#' Function for Rounding Weights
#'
#' @description
#' This function performs an optimal rounding of the provided real weights, 
#' in order to reduce a specific objective function 
#' 
#' @param weights A numerical vector of real weights to be rounded 
#' @param formula A formula to express a linear system for hitting the \code{targets}
#' @param targets A numerical vector of point-targets to hit
#' @param objective A character specifying the objective function used for calibration. By default, it is \code{"L1"}. See details for more information
#' @param tgtBnds A two-column matrix containing the bounds for the point-targets
#' @param lower A numerical vector or value defining the lower bounds of the weights
#' @param upper A numerical vector or value defining the upper bounds of the weights
#' @param sparse A logical value denoting if the linear system is sparse or not. By default, it is \code{FALSE}
#' @param scale A numerical vector of positive values 
#' @param data A \code{data.frame} or \code{matrix} object containing the data to be used for calibration
#'
#' @details 
#' The optimal rounding can be performed by considering one of the following objective functions:
#' \describe{
#'   \item{\code{"L1"}}{for the summation of absolute errors}
#'   \item{\code{"aL1"}}{for the asymmetric summation of absolute errors}
#'   \item{\code{"rL1"}}{for the summation of absolute relative errors}
#'   \item{\code{"LB1"}}{for the summation of absolute errors if outside the boundaries}
#'   \item{\code{"rB1"}}{for the summation of absolute relative errors if outside the boundaries}
#'   \item{\code{"L2"}}{for the summation of square errors}
#'   \item{\code{"aL2"}}{for the asymmetric summation of square errors}
#'   \item{\code{"rL2"}}{for the summation of square relative errors}
#'   \item{\code{"LB2"}}{for the summation of square errors if outside the boundaries}
#'   \item{\code{"rB2"}}{for the summation of square relative errors if outside the boundaries}
#'   \item{\code{"LC"}}{for the summation of the logcosh errors}
#'   \item{\code{"aLC"}}{for the asymmetric summation of the logcosh errors}
#'   \item{\code{"rLC"}}{for the summation of the logcosh relative errors}
#'   \item{\code{"SE"}}{for the summation of the exponential absolute errors}
#'   \item{\code{"aSE"}}{for the asymmetric summation of the exponential absolute errors}
#'   \item{\code{"rSE"}}{for the summation of the exponential absolute relative errors}
#' }
#' 
#' A two-column matrix must be provided to \code{tgtBnds} when \code{objective = "aL1"}, \code{objective = "LB1"}, \code{objective = "rB1"},
#' \code{objective = "aL2"}, \code{objective = "LB2"}, \code{objective = "rB2"}, \code{objective = "aLC"}, and \code{objective = "aSE"}.
#' 
#' The argument \code{scale} must be specified with a vector of positive real numbers when \code{objective = "rL1"},
#' \code{objective = "rL2"}, \code{objective = "rLC"}, or \code{objective = "rSE"}.
#' 
#' @return 
#' A vector of integer weights to be the input of the calibration algorithm
#' 
#' @examples
#' library(inca)
#' set.seed(0)
#' w <- rpois(10, 4)
#' data <- matrix(rbinom(1000, 1, .3) * rpois(1000, 4), 100, 10)
#' y <- data %*% w
#' w <- runif(10, 0, 7.5)
#' rw <- roundWeights(w, ~. + 0, y, lower = 1, upper = 7, sparse = TRUE, data = data)
#' barplot(table(rw), main = "Rounded weigths")
#'
#' @export

"roundWeights" <- function(weights, formula, targets, objective = c("L1", "aL1", "rL1", "LB1", "rB1",
                                                "L2", "aL2", "rL2", "LB2", "rB2", "LC", "aLC", "rLC",
                                                "SE", "aSE", "rSE"),
                           tgtBnds = NULL, lower = -Inf, upper = Inf, scale = NULL, sparse = FALSE,
                           data) {
  if (is.null(tgtBnds)) {
    if (objective[1] %in% c("LB1", "aL1", "rB1", "LB2", "aL2", "rB2", "aLC", "aSE"))
      stop("\"tgtBnds\" must be specified when \"objective\" is either ",
           paste("\"LB1\",", "\"aL1\",", "\"rB1\",", "\"LB2\",", "\"aL2\",", "\"rB2\",", "\"aLC\",", "or \"aSE\""))
    tgtBnds <- cbind(rep_len(-Inf, length(targets)),
                     rep_len( Inf, length(targets)))
  }
  else { 
    tgtBnds <- as.matrix(tgtBnds)
    if (ncol(tgtBnds) != 2) 
      stop("\"tgtBnds\" must be a data.frame or a matrix object with two columns")
  }
  if(is.null(scale)) {
    if (objective[1] %in% c("rL1", "rL2", "rLC", "rSE"))
      warning("The argument \"scale\" should be specified when \"objective\" is either ", 
              paste("\"rL1\",", "\"rL2\",", "\"rLC\",", "or \"rSE\"\n"),
              "In this case, \"scale\" will be set as a vector of values equal to one by default")
    scale <- rep_len(1, length(targets))
  }
  mylower <- pmax(ceiling(lower), rep_len(-Inf, length(weights)))
  myupper <- pmin(floor(upper), rep_len(Inf, length(weights)))
  wts <- adjWeights(weights, lower = mylower, upper = myupper)
  if(sparse) {
    A <- Matrix::sparse.model.matrix(formula, data = as.data.frame(data))
    wts <- .Call('sparse_round', PACKAGE = 'inca', A, targets, wts, tgtBnds, scale, objective[1L])
  }
  else {
    A <- model.matrix(formula, data = as.data.frame(data))
    wts <- .Call('dense_round', PACKAGE = 'inca', A, targets, wts, tgtBnds, scale, objective[1L])
  }
  return(as.vector(wts))
}