R/ratp_range_tp.R

In NicolasJBM/manacc: Functions to simulate exercises in management accounting, and templates for these questions

#' Create exercise about taking or leaving special orders
#' @param vol        Numeric. Volume.
#' @param p          Numeric. Price.
#' @param uvcp       Numeric. Unit variable cost of production.
#' @param uvcs       Numeric. Unit variable cost of sales.
#' @param ufc        Numeric. Unit fixed costs.
#' @param enough_cap Logical. TRUE if the special order fits in available capacity.
#' @param force_buy  Logical. TRUE if the buyer is not allowed to deal outside.
#' @return List. base, solution, wrong_nei, wrong_min_itp, wrong_max_itp
#' @importFrom dplyr case_when
#' @export


ratp_range_tp <- function(vol = 1000,
                          p = 10,
                          uvcp = 5,
                          uvcs = 2,
                          ufc = 1.5,
                          enough_cap = FALSE,
                          force_buy = FALSE) {
  
  
  it_vol <- ceiling(vol * sample(seq(from = 0.01, to = 0.2, by = 0.01),1))
  it_uvcp <- manacc::wiggle(uvcp, delta = 0.1)
  it_uvcs <- manacc::wiggle(uvcs, delta = 0.5, dir = -1)
  ext_p <- manacc::wiggle(p, delta = 0.2)
  ext_uvcs <- manacc::wiggle(uvcs, delta = 0.2)
  ext_bid <- manacc::wiggle(it_uvcp+it_uvcs+ufc)
  
  cap <- dplyr::case_when(
    enough_cap == FALSE ~ vol + floor(it_vol * sample(seq(from = 0.6, to = 0.9, by = 0.01),1)),
    TRUE ~ vol + ceiling(it_vol * sample(seq(from = 1.1, to = 1.20, by = 0.01),1))
  )
  lost <- max(0, vol + it_vol - cap)
  
  min_itp <- ceiling(100*(it_vol * (it_uvcp+it_uvcs) + lost * (p-uvcp-uvcs)) / it_vol)/100
  com_marg <- ext_p - ext_uvcs
  if (force_buy) max_itp <- com_marg else max_itp <- min(com_marg, ext_bid)
  
  
  if (it_uvcp > uvcp){
    comment_uvcp <- "Alterations of the product to adapt it to this new market make it slightly more expensive to produce"
  } else {
    comment_uvcp <- "Alterations of the product to adapt it to this new market make it slightly less expensive to produce"
  }
  
  if (lost > 0){
    comment_lost <- "In this case, the capacity is insufficient to satisfy both external and internal sales. It is therefore necessary to account for the contribution margin on lost sales when computing the minimum acceptable transfer price"
  } else {
    comment_lost <- "In this case, the capacity is sufficient to satisfy both external and internal sales. Therefore, there is no additional opportunity cost when computing the minimum acceptable transfer price"
  }
  
  
  if (force_buy){
    comment_bid <- "Here, the internal purchase is forced, therefore the price offered by the external supplier is irrelevant. The maximum acceptable transfer price is thus the commercial margin of the internal buyer"
  } else {
    if ((com_marg) > ext_bid){
      comment_bid <- "Here, the price proposed by the external supplier is inferior to the commercial margin of the internal buyer who is allowed to deal oustide. The price proposed by the external supplier is therefore the maximum acceptable transfer price"
    } else {
      comment_bid <- "Here, the price proposed by the external supplier is superior to the commercial margin of the internal buyer. The commercial margin of the internal buyer is therefore the maximum acceptable transfer price"
    }
  }
  
  
  if (min_itp <= max_itp){
    comment_possible <- "The minimum acceptable price is inferior to the maximum acceptable price. Therefore, there is a range of acceptable transfer prices"
  } else {
    comment_possible <- "The minimum acceptable price is greater than the maximum acceptable price. Therefore, there is no acceptable transfer price"
  }
  
  
  base <- data.frame(
    type = c("external1","internal","external2"),
    vol = c(vol,it_vol,it_vol),
    p = c(p,NA,ext_p),
    uvcp = c(uvcp,it_uvcp,ext_bid),
    uvcs = c(uvcs,it_uvcs,ext_uvcs),
    ufc = c(ufc,NA,NA),
    cap = c(cap,NA,NA)
  )
  
  solution <- c(
    lost = lost,
    com_marg = com_marg,
    min_itp = min_itp,
    max_itp = max_itp
  )
  
  comments <- c(
    uvcp = comment_uvcp,
    lost = comment_lost,
    bid = comment_bid,
    possible = comment_possible
  )
  
  wrong_min_itp <- c(
    wminitp1 = ceiling(100*(it_vol * (it_uvcp+it_uvcs)) / it_vol)/100,
    wminitp2 = ceiling(100*(it_vol * (it_uvcp) + lost * (p-uvcp-uvcs)) / it_vol)/100,
    wminitp3 = ceiling(100*(it_vol * (it_uvcp+ext_uvcs) + lost * (p-uvcp-uvcs)) / it_vol)/100,
    wminitp4 = ceiling(100*(it_vol * (uvcp+uvcs) + lost * (p-uvcp-uvcs)) / it_vol)/100,
    wminitp5 = ceiling(100*(it_vol * (uvcp+uvcs)) / it_vol)/100,
    wminitp6 = ceiling(100*(it_vol * (it_uvcp+it_uvcs) + lost * (ext_p-it_uvcp+it_uvcs)) / it_vol)/100
  )
  wrong_min_itp <- unique(setdiff(wrong_min_itp, min_itp))
  
  wrong_max_itp <- c(
    wmaxitp1 = setdiff(c(com_marg, ext_bid), min_itp),
    wmaxitp2 = ext_p,
    wmaxitp3 = ext_p - uvcs,
    wmaxitp4 = com_marg - ufc,
    wmaxitp5 = ext_p - ext_bid,
    wmaxitp6 = com_marg - ext_bid,
    wmaxitp7 = ext_p + ext_uvcs
  )
  wrong_max_itp <- unique(setdiff(wrong_max_itp, max_itp))
  
  results <- list(
    base = base,
    solution = solution,
    comments = comments,
    wrong_min_itp = wrong_min_itp,
    wrong_max_itp = wrong_max_itp
  )
  
  return(results)
}