R/model_income_tax.R

Defines functions model_income_tax

Documented in model_income_tax

#' Modelled Income Tax
#' @description The income tax payable if tax settings are changed. 
#' @param sample_file A sample file having at least as many variables as the 2012-13 sample file.
#' @param baseline_fy If a parameter is not selected, the parameter's value in this tax year is used.
#' @param elasticity_of_taxable_income Either \code{NULL} (the default), or a numeric vector the same length of \code{sample_file} (or length-1) providing the elasticity of taxable income for each observation in \code{sample_file}; 
#' \deqn{\frac{\Delta z / z}{\Delta \tau / (1 - \tau)}} 
#' where \eqn{z} is taxable income and \eqn{\tau} is tax payable.
#' 
#' For example, if, for a given taxpayer,
#' the tax settings would otherwise result in a 2\% decrease of disposable income
#' under the tax settings to be modelled, and \code{elasticity_of_taxable_income} is set to 0.1,
#' the \code{Taxable_Income} is reduced by 0.2\% before the tax rates are applied.
#' 
#' If \code{NULL}, an elasticity of 0 is used. 
#' @param n_dependants The number of dependants for each entry in \code{sample_file}.
#' @param ordinary_tax_thresholds A numeric vector specifying the lower bounds of the brackets for "ordinary tax" as defined by the Regulations.
#' The first element should be zero if there is a tax-free threshold.
#' @param ordinary_tax_rates The marginal rates of ordinary tax. The first element should be zero if there is a tax-free threshold. 
#' Since the temporary budget repair levy was imposed on a discrete tax bracket when it applied, it is not included in this function.

#' @param medicare_levy_taper The taper that applies between the \code{_lower} and \code{_upper} thresholds.
#' @param medicare_levy_rate The ordinary rate of the Medicare levy for taxable incomes above \code{medicare_levy_upper_threshold}.

#' @param medicare_levy_lower_threshold Minimum taxable income at which the Medicare levy will be applied.
#' @param medicare_levy_upper_threshold Minimum taxable income at which the Medicare levy will be applied at the full Medicare levy rate (2\% in 2015-16). Between this threshold and the \code{medicare_levy_lower_threshold}, a tapered rate applies, starting from zero and climbing to \code{medicare_levy_rate}. 

#' @param medicare_levy_lower_family_threshold,medicare_levy_upper_family_threshold The equivalent values for families.
#' @param medicare_levy_lower_sapto_threshold,medicare_levy_upper_sapto_threshold The equivalent values for SAPTO-eligible individuals (not families).
#' @param medicare_levy_lower_family_sapto_threshold,medicare_levy_upper_family_sapto_threshold The equivalent values for SAPTO-eligible individuals in a family.
#' @param medicare_levy_lower_up_for_each_child The amount to add to the \code{_family_threshold}s for each dependant child.
#' @param lito_max_offset The maximum offset available for low incomes.
#' @param lito_taper The taper to apply beyond \code{lito_min_bracket}.
#' @param lito_min_bracket The taxable income at which the value of the offset starts to reduce (from \code{lito_max_offset}).
#' @param sapto_eligible Whether or not each taxpayer in \code{sample_file} is eligible for \code{SAPTO}. 
#' If \code{NULL}, the default, then eligibility is determined by \code{age_range} in \code{sample_file};
#' \emph{i.e.}, if \code{age_range <= 1} then the taxpayer is assumed to be eligible for SAPTO.
#' @param sapto_max_offset The maximum offset available through SAPTO. 
#' @param sapto_lower_threshold The threshold at which SAPTO begins to reduce (from \code{sapto_max_offset}).
#' @param sapto_taper The taper rate beyond \code{sapto_lower_threshold}.
#' @param calc_baseline_tax (logical, default: \code{TRUE}) Should the income tax in \code{baseline_fy} be included as a column in the result?
#' @param return. What should the function return? One of \code{tax} or \code{sample_file}. 
#' If \code{tax}, the tax payable under the settings; if \code{sample_file}, the \code{sample_file},
#' but with variables \code{tax} and possibly \code{new_taxable_income}. 
#' 
#' @export



model_income_tax <- function(sample_file,
                             baseline_fy,
                             n_dependants = 0L,
                             elasticity_of_taxable_income = NULL,
                             
                             ordinary_tax_thresholds = NULL,
                             ordinary_tax_rates = NULL,
                             
                             
                             medicare_levy_taper = NULL, 
                             medicare_levy_rate = NULL,
                             medicare_levy_lower_threshold = NULL,
                             medicare_levy_upper_threshold = NULL,
                             
                             medicare_levy_lower_sapto_threshold = NULL,
                             medicare_levy_upper_sapto_threshold = NULL,
                             
                             medicare_levy_lower_family_threshold = NULL,
                             medicare_levy_upper_family_threshold = NULL,
                             
                             medicare_levy_lower_family_sapto_threshold = NULL,
                             medicare_levy_upper_family_sapto_threshold = NULL,
                             medicare_levy_lower_up_for_each_child = NULL,
                             
                             
                             lito_max_offset = NULL,
                             lito_taper = NULL,
                             lito_min_bracket = NULL,
                             
                             sapto_eligible = NULL,
                             sapto_max_offset = NULL,
                             sapto_lower_threshold = NULL,
                             sapto_taper = NULL, 
                             calc_baseline_tax = TRUE,
                             return. = c("sample_file", "tax")) {
  arguments <- ls()
  argument_vals <- as.list(environment())
  return. <- match.arg(return.)
  
  `%|||%` <- function(lhs, rhs) {
    if (is.null(lhs)) {
      rep_len(rhs, max.length)
    } else {
      rep_len(lhs, max.length)
    }
  }
  
  stopifnot(is.data.table(sample_file))
  .dots.ATO <- sample_file
  sample_file_noms <- copy(names(sample_file))
  
  s1213_noms <-
    c("Ind", "Gender",
      # "age_range",
      "Occ_code", "Partner_status", 
      "Region", "Lodgment_method", "PHI_Ind", "Sw_amt", "Alow_ben_amt", 
      "ETP_txbl_amt", "Grs_int_amt", "Aust_govt_pnsn_allw_amt", "Unfranked_Div_amt", 
      "Frk_Div_amt", "Dividends_franking_cr_amt", "Net_rent_amt", "Gross_rent_amt", 
      "Other_rent_ded_amt", "Rent_int_ded_amt", "Rent_cap_wks_amt", 
      "Net_farm_management_amt", "Net_PP_BI_amt", "Net_NPP_BI_amt", 
      "Total_PP_BI_amt", "Total_NPP_BI_amt", "Total_PP_BE_amt", "Total_NPP_BE_amt", 
      "Net_CG_amt", "Tot_CY_CG_amt", "Net_PT_PP_dsn", "Net_PT_NPP_dsn", 
      "Taxed_othr_pnsn_amt", "Untaxed_othr_pnsn_amt", "Other_foreign_inc_amt", 
      "Other_inc_amt", "Tot_inc_amt", "WRE_car_amt", "WRE_trvl_amt", 
      "WRE_uniform_amt", "WRE_self_amt", "WRE_other_amt", "Div_Ded_amt", 
      "Intrst_Ded_amt", "Gift_amt", "Non_emp_spr_amt", "Cost_tax_affairs_amt", 
      "Other_Ded_amt", "Tot_ded_amt", "PP_loss_claimed", "NPP_loss_claimed", 
      "Rep_frng_ben_amt", "Med_Exp_TO_amt", "Asbl_forgn_source_incm_amt", 
      # "Spouse_adjusted_taxable_inc",
      "Net_fincl_invstmt_lss_amt", "Rptbl_Empr_spr_cont_amt", 
      "Cr_PAYG_ITI_amt", "TFN_amts_wheld_gr_intst_amt", "TFN_amts_wheld_divs_amt", 
      "Hrs_to_prepare_BPI_cnt", "Taxable_Income", "Help_debt")
  
  if (!all(s1213_noms %chin% sample_file_noms)) {
    absent_cols <- setdiff(s1213_noms, sample_file_noms)
    stop("`sample_file` lacked the following required columns:\n\t",
         paste0(absent_cols, collapse = "\n\t"), ".\n")
  }
  
  income <- sample_file[["Taxable_Income"]]
  
  # Indicate baseline tax
  if (calc_baseline_tax && identical(return., "sample_file")) {
    sample_file[, "baseline_tax" := income_tax(income,
                                               fy.year = baseline_fy,
                                               .dots.ATO = sample_file,
                                               n_dependants = n_dependants)]
  }
  
  max.length <- length(income)
  prohibit_vector_recycling(income, n_dependants, baseline_fy)
  
  old_tax <- income_tax(income,
                        fy.year = baseline_fy,
                        .dots.ATO = copy(.dots.ATO),
                        n_dependants = n_dependants)
  
  if (is.null(sapto_eligible)) {
    if ("age_range" %chin% names(sample_file)) {
      sapto_eligible <- .subset2(sample_file, "age_range") <= 1L
    } else {
      warning("Assuming everyone is ineligible for SAPTO.")
      sapto_eligible <- logical(max.length)
    }
  } else {
    if (!is.logical(sapto_eligible)) {
      stop("`sapto_eligible` was not a logical vector.")
    }
    if (length(sapto_eligible) != 1L && length(sapto_eligible) != max.length) {
      stop("`sapto_eligible` was length ", length(sapto_eligible), ". ",
           "Ensure `sapto_eligible` has length ",
           max.length, "(i.e. nrow(sample_file)) or length one.")
    }
  }
  
  ordering <- NULL
  
  input <-
    data.table(income = income,
               fy_year = baseline_fy, 
               SaptoEligible = sapto_eligible) %>%
    .[, "ordering" := .I] %>%
    setkeyv(c("fy_year", "income"))
  
  # Check base tax
  if (!is.null(ordinary_tax_thresholds) || !is.null(ordinary_tax_rates)) {
    tax_table2_fy <- tax_table2[fy_year == baseline_fy]
    
    Thresholds <- ordinary_tax_thresholds %||% tax_table2_fy[["lower_bracket"]]
    Rates <-  ordinary_tax_rates %||% tax_table2_fy[["marginal_rate"]]
    
    if (length(Thresholds) != length(Rates)) {
      stop("`ordinary_tax_thresholds` and `ordinary_tax_rates` have different lengths. ",
           "Specify numeric vectors of equal length (or NULL).")
    }
    
    base_tax. <-
      IncomeTax(income,
                thresholds = Thresholds,
                rates = Rates)
  } else {
    tax_at <- lower_bracket <- marginal_rate <- NULL
    
    base_tax. <- 
      tax_table2[input, roll = Inf] %>%
      .[, .(ordering, tax = tax_at + (income - lower_bracket) * marginal_rate)] %>%
      setorderv("ordering") %>%
      .subset2("tax")
    
    temp_budget_repair_levy. <-
      and(input[["fy_year"]] %chin% c("2014-15", "2015-16", "2016-17"),
          income > 180e3) * 
      (0.02 * (income - 180e3))
    
    base_tax. <- base_tax. + temp_budget_repair_levy. 
  }
  
  
  
  # If .dots.ATO  is NULL, for loops over zero-length vector
  for (j in which(vapply(.dots.ATO, FUN = is.double, logical(1)))){
    set(.dots.ATO, j = j, value = as.integer(.dots.ATO[[j]]))
  }
  
  if (is.null(.dots.ATO) ||
      "Spouse_adjusted_taxable_inc" %notin% names(.dots.ATO)) {
    the_spouse_income <- integer(max.length)
  } else {
    the_spouse_income <- .dots.ATO[["Spouse_adjusted_taxable_inc"]]
    the_spouse_income[is.na(the_spouse_income)] <- 0L
  }
  
  
  # Check medicare levy
  medicare_args <- mget(grep("^medicare_levy", arguments, perl = TRUE, value = TRUE))
  
  if (all(vapply(medicare_args, is.null, FALSE))) {
    medicare_levy. <- 
      medicare_levy(income, 
                    Spouse_income = the_spouse_income,
                    fy.year = baseline_fy, 
                    sapto.eligible = sapto_eligible, 
                    family_status = {
                      FS <- rep_len("individual", max.length)
                      FS[the_spouse_income > 0] <- "family"
                      FS
                    }, 
                    n_dependants = n_dependants, 
                    .checks = FALSE)
    
  } else {
    medicare_tbl_fy <- 
      medicare_tbl[input, on = c("fy_year", "sapto==SaptoEligible")] %>%
      setorderv("ordering")
    
    # When a parameter is selected it must satisfy the 
    # conditions of the low-income area
    
    #    |                   .
    #    |              .
    # rb |         .
    #    |       /
    #    |      /
    #    |-----/
    #    0   a  b
    # 
    # t(b - a) = rb
    #
    
    # Here, we test whether or not the conditions are so satisfied; 
    # if not, we fix one of the parameters that is not specified to
    # satisfy the relation, with a warning and a prayer to change
    # the relevant the parameter.
    
    
    # Individuals
    ma <- medicare_levy_lower_threshold %|||% medicare_tbl_fy[["lower_threshold"]]
    mb <- medicare_levy_upper_threshold %|||% medicare_tbl_fy[["upper_threshold"]]
    mt <- medicare_levy_taper %|||% medicare_tbl_fy[["taper"]]
    mr <- medicare_levy_rate  %|||% medicare_tbl_fy[["rate"]]
    
    # Individuals - SAPTO
    # N.B. medicare_tbl_fy[["lower/upper_threshold"]] since the join above correctly identifies which ones
    msa <- medicare_levy_lower_sapto_threshold %|||% medicare_tbl_fy[["lower_threshold"]]
    msb <- medicare_levy_upper_sapto_threshold %|||% medicare_tbl_fy[["upper_threshold"]]
    
    ma <- as.integer(ma)
    msa <- as.integer(msa)
    mb <- as.integer(mb - 1)
    msb <- as.integer(msb - 1)
    
    
    # Families
    mfa <- medicare_levy_lower_family_threshold %|||% medicare_tbl_fy[["lower_family_threshold"]]
    mfb <- medicare_levy_upper_family_threshold %|||% medicare_tbl_fy[["upper_family_threshold"]]
    
    # Families - SAPTO
    mfsa <- medicare_levy_lower_family_sapto_threshold %|||% medicare_tbl_fy[["lower_family_threshold"]]
    mfsb <- medicare_levy_upper_family_sapto_threshold %|||% medicare_tbl_fy[["upper_family_threshold"]]
    
    mfa <- as.integer(mfa)
    mfb <- as.integer(mfb - 1)
    mfsa <- as.integer(mfsa)
    mfsb <- as.integer(mfsb - 1)
    
    
    medicare_parameter_roots <- 
      if_else(sapto_eligible,
              if_else(the_spouse_income > 0,
                      abs(mt * (mfsb - mfsa) - mr * mfsb),
                      abs(mt * (msb - msa) - mr * msb)),
              if_else(the_spouse_income > 0,
                      abs(mt * (mfb - mfa) - mr * mfb),
                      abs(mt * (mb - ma) - mr * mb)))
    
    if (any(medicare_parameter_roots > 1)) {
      # model is misspecified in respect of offsets etc
      
      warning_if_misspecified <- function(the_arg) {
        se <- sapto_eligible
        f. <- the_spouse_income > 0
        nor <- function(x, y) and(!x, !y)
        val <- switch(the_arg, 
                      "medicare_levy_upper_threshold" = mb[nor(se, f.)], 
                      "medicare_levy_lower_threshold" = ma[nor(se, f.)], 
                      "medicare_levy_upper_sapto_threshold" = msb[se & !f.], 
                      "medicare_levy_lower_sapto_threshold" = msa[se & !f.], 
                      "medicare_levy_upper_family_threshold" = mfb[!se & f.], 
                      "medicare_levy_lower_family_threshold" = mfa[!se & f.], 
                      "medicare_levy_upper_family_sapto_threshold" = mfsb[se & f.], 
                      "medicare_levy_lower_family_sapto_threshold" = mfsa[se & f.], 
                      "medicare_levy_taper" = mt,
                      "medicare_levy_rate" = mr)
        
        if (uniqueN(val) == 1L) {
          warning("`", the_arg, "` was not specified, ",
                  "but its default value would be inconsistent with the parameters that were specified.\n", 
                  "Its value has been set to:\n\t",
                  the_arg, " = ", round(val[1], digits = if (val[1] < 1) 2 else 0),
                  call. = FALSE)
        } else {
          warning("`", the_arg, "` was not specified, ",
                  "but its default values would be inconsistent with the parameters that were specified.\n",
                  "Its values have been set to: ",
                  "\n\t", paste0(utils::head(unique(round(val), 5)), 
                                 "...", 
                                 utils::tail(unique(round(val), 5)),
                                 collapse = "\n\t"),
                  "\n\t\t (First and last five shown.)",
                  call. = FALSE)
        }
      }
      
      # Could be a problem with the individual parameter changes, or 
      # with the family ones. Do one at a time.
      if (any(medicare_parameter_roots[the_spouse_income == 0L] > 1)) {
        if (any(medicare_parameter_roots[and(the_spouse_income == 0L,
                                             !sapto_eligible)] > 1)) {
          # Individual thresholds
          if (is.null(medicare_levy_upper_threshold)) {
            mb <- mt * ma / (mt - mr)
            warning_if_misspecified("medicare_levy_upper_threshold")
            
          } else {
            
            if (is.null(medicare_levy_lower_threshold)) {
              ma <- mb * (mt - mr) / mt
              warning_if_misspecified("medicare_levy_lower_threshold")
              
            } else {
              
              if (is.null(medicare_levy_taper)) {
                mt <- mr * mb / (mb - ma)
                warning_if_misspecified("medicare_levy_taper")
                
              } else {
                
                if (is.null(medicare_levy_rate)) {
                  mr <- mt * (mb - ma) / mb
                  warning_if_misspecified("medicare_levy_rate")
                  # alternative not reachable
                } else stop("ERR # e59ed9845068f337d6653a7cc00401e1dbeeda7d. ",
                            "Please contact `grattan` package maintainer.") 
              }
            }
          }
        }
        
        if (any(medicare_parameter_roots[and(the_spouse_income == 0L,
                                             sapto_eligible)] > 1)) {
          # SAPTO non-families
          if (is.null(medicare_levy_upper_sapto_threshold)) {
            msb <- mt * msa / (mt - mr)
            warning_if_misspecified("medicare_levy_upper_sapto_threshold")
            
          } else {
            
            if (is.null(medicare_levy_lower_sapto_threshold)) {
              msa <- msb * (mt - mr) / mt
              warning_if_misspecified("medicare_levy_lower_sapto_threshold")
              
            } else {
              medicare_levy_taper_stop <- 
                round(mr * msb / (msb - msa), 3)
              
              stop("Medicare levy parameter mismatch could not be safely resolved.\n\n",
                   "`medicare_levy_upper_sapto_threshold` and ",
                   "`medicare_levy_lower_sapto_threshold` were both supplied, ",
                   "but imply a Medicare taper rate of\n\t",
                   if (uniqueN(medicare_levy_taper_stop) == 1L) {
                     unique(medicare_levy_taper_stop)
                   } else {
                     paste0(paste0(utils::head(unique(medicare_levy_taper_stop)),
                                   collapse = "\n\t"),
                            " (first 6 shown)")
                   },
                   "\t (to 3 decimal places)\n",
                   "Either supply Medicare levy parameters compatible with this taper rate, ",
                   "or change `medicare_levy_taper` (which may force other parameters to", 
                   " change too).")
            }
          }
        }
      }
      
      if (any(medicare_parameter_roots[the_spouse_income > 0L] > 1)) {
        # Family thresholds only
        if (any(medicare_parameter_roots[and(the_spouse_income > 0L,
                                             !sapto_eligible)] > 1)) {
          if (is.null(medicare_levy_upper_family_threshold)) {
            mfb <- mt * mfa / (mt - mr)
            warning_if_misspecified("medicare_levy_upper_family_threshold")
            
          } else {
            
            if (is.null(medicare_levy_lower_family_threshold)) {
              mfa <- mfb * (mt - mr) / mt
              warning_if_misspecified("medicare_levy_lower_family_threshold")
              
            } else {
              medicare_levy_taper_stop <- 
                round(mr * mfb / (mfb - mfa), 3)
              stop("Medicare levy parameter mismatch could not be safely resolved.\n\n",
                   "`medicare_levy_upper_family_threshold` and ",
                   "`medicare_levy_lower_family_threshold` were both supplied, ",
                   "but imply a Medicare taper rate of\n\t",
                   if (uniqueN(medicare_levy_taper_stop) == 1L) {
                     unique(medicare_levy_taper_stop)
                   } else {
                     paste0(paste0(utils::head(unique(medicare_levy_taper_stop)),
                                   collapse = "\n\t"),
                            " (first 6 shown)")
                   }, "\t (to 3 decimal places)\n",
                   "Either supply Medicare levy parameters compatible with this taper rate, ",
                   "or change `medicare_levy_taper` (which may force other parameters to", 
                   " change too).")
            }
          }
        }
        
        # Family - SAPTO
        if (any(medicare_parameter_roots[and(the_spouse_income > 0L,
                                             sapto_eligible)] > 1)) {
          if (is.null(medicare_levy_upper_family_sapto_threshold)) {
            mfsb <- mt * mfsa / (mt - mr)
            warning_if_misspecified("medicare_levy_upper_family_sapto_threshold")
            
          } else {
            
            if (is.null(medicare_levy_lower_family_sapto_threshold)) {
              mfsa <- mfsb * (mt - mr) / mt
              warning_if_misspecified("medicare_levy_lower_family_sapto_threshold")
              
            } else {
              medicare_levy_taper_stop <- round(mr * mfsb / (mfsb - mfa), 3)[sapto_eligible]
              
              stop("Medicare levy parameter mismatch could not be safely resolved.\n\n",
                   "`medicare_levy_upper_family_sapto_threshold` and ",
                   "`medicare_levy_lower_family_sapto_threshold` were both supplied, ",
                   "but imply a Medicare taper rate of\n\t",
                   if (uniqueN(medicare_levy_taper_stop) == 1L) {
                     unique(medicare_levy_taper_stop)
                   } else {
                     paste0(paste0(utils::head(unique(medicare_levy_taper_stop)),
                                   collapse = "\n\t"),
                            " (first 6 shown)")
                   }, "\t (to 3 decimal places)\n",
                   "Either supply Medicare levy parameters compatible with this taper rate, ",
                   "or change `medicare_levy_taper` (which may force other parameters to", 
                   " change too).")
            }
          }
          
        }
      }
    }
    
    if (any(sapto_eligible)) {
      ma[sapto_eligible] <- msa[sapto_eligible]
      mb[sapto_eligible] <- msb[sapto_eligible]
      mfa[sapto_eligible] <- mfsa[sapto_eligible]
      mfb[sapto_eligible] <- mfsb[sapto_eligible]
    }
    
    medicare_levy. <-
      MedicareLevy(income = income,
                   
                   lowerThreshold = ma,
                   upperThreshold = mb,
                   
                   SpouseIncome = the_spouse_income,
                   isFamily = the_spouse_income > 0,
                   NDependants = if (length(n_dependants) == 1) rep_len(n_dependants, max.length) else n_dependants,
                   
                   lowerFamilyThreshold = mfa,
                   upperFamilyThreshold = mfb,
                   lowerUpForEachChild  = medicare_levy_lower_up_for_each_child %|||% medicare_tbl_fy[["lower_up_for_each_child"]], 
                   
                   rate = mr,
                   taper = mt)
  }
  
  lito_args <- mget(grep("^lito_", arguments, perl = TRUE, value = TRUE))
  
  if (all(vapply(lito_args, is.null, FALSE))) {
    setkeyv(input, "fy_year")
    lito. <- .lito(input)
  } else {
    lito_fy <- lito_tbl[fy_year == baseline_fy]
    lito. <- lito(income,
                  max_lito = lito_max_offset %||% lito_fy[["max_offset"]],
                  lito_taper = lito_taper %||% lito_fy[["lito_taper"]],
                  min_bracket = lito_taper %||% lito_fy[["min_bracket"]])
  }
  
  
  
  sapto. <- double(max.length)
  if (any(sapto_eligible)) {
    sapto_args <- mget(grep("^sapto_(?!eligible)", arguments, perl = TRUE, value = TRUE))
    
    if (all(vapply(sapto_args, is.null, FALSE))) {
      
      rebate_income_over_eligible <-
        rebate_income(Taxable_Income = income[sapto_eligible],
                      Rptbl_Empr_spr_cont_amt = .dots.ATO[sapto_eligible][["Rptbl_Empr_spr_cont_amt"]],
                      Net_fincl_invstmt_lss_amt = .dots.ATO[sapto_eligible][["Net_fincl_invstmt_lss_amt"]],
                      Net_rent_amt = .dots.ATO[sapto_eligible][["Net_rent_amt"]],
                      Rep_frng_ben_amt = .dots.ATO[sapto_eligible][["Rep_frng_ben_amt"]])
      
      sapto.[sapto_eligible] <-
        sapto(rebate_income = rebate_income_over_eligible, 
              fy.year = if (length(baseline_fy) > 1) baseline_fy[sapto_eligible] else baseline_fy,
              Spouse_income = the_spouse_income[sapto_eligible],
              family_status = {
                FS_sapto <- rep_len("single", max.length)
                FS_sapto[the_spouse_income > 0] <- "married"
                FS_sapto[sapto_eligible]
              },
              sapto.eligible = TRUE)
    } else {
      sapto_tbl_fy <- sapto_tbl[fy_year == baseline_fy]
      sapto_married_fy <- sapto_tbl_fy[family_status == "married"]
      sapto_single_fy <- sapto_tbl_fy[family_status == "single"]
      sapto_married <- sapto_eligible & the_spouse_income > 0L
      sapto_single  <- sapto_eligible & the_spouse_income == 0L
      
      rebate_income_married_eligible <-
        rebate_income(Taxable_Income = income[sapto_married],
                      Rptbl_Empr_spr_cont_amt =   .dots.ATO[sapto_married][["Rptbl_Empr_spr_cont_amt"]],
                      Net_fincl_invstmt_lss_amt = .dots.ATO[sapto_married][["Net_fincl_invstmt_lss_amt"]],
                      Net_rent_amt =              .dots.ATO[sapto_married][["Net_rent_amt"]],
                      Rep_frng_ben_amt =          .dots.ATO[sapto_married][["Rep_frng_ben_amt"]])
      
      rebate_income_single_eligible <-
        rebate_income(Taxable_Income = income[sapto_single],
                      Rptbl_Empr_spr_cont_amt =   .dots.ATO[sapto_single][["Rptbl_Empr_spr_cont_amt"]],
                      Net_fincl_invstmt_lss_amt = .dots.ATO[sapto_single][["Net_fincl_invstmt_lss_amt"]],
                      Net_rent_amt =              .dots.ATO[sapto_single][["Net_rent_amt"]],
                      Rep_frng_ben_amt =          .dots.ATO[sapto_single][["Rep_frng_ben_amt"]])
      
      sapto.[sapto_married] <- 
        sapto_rcpp(RebateIncome   = rebate_income_married_eligible,
                   MaxOffset      =      sapto_max_offset[sapto_married] %|||% sapto_married_fy[["max_offset"]],
                   LowerThreshold = sapto_lower_threshold[sapto_married] %|||% sapto_married_fy[["lower_threshold"]],
                   TaperRate      =           sapto_taper[sapto_married] %|||% sapto_married_fy[["taper_rate"]],
                   SaptoEligible  = TRUE,
                   IsMarried      = TRUE,
                   SpouseIncome   = the_spouse_income[sapto_married])
      
      sapto.[sapto_single] <- 
        sapto_rcpp(RebateIncome   = rebate_income_single_eligible,
                   MaxOffset      =      sapto_max_offset[sapto_single] %|||% sapto_single_fy[["max_offset"]],
                   LowerThreshold = sapto_lower_threshold[sapto_single] %|||% sapto_single_fy[["lower_threshold"]],
                   TaperRate      =           sapto_taper[sapto_single] %|||% sapto_single_fy[["taper_rate"]],
                   SaptoEligible  = TRUE,
                   IsMarried      = FALSE,
                   SpouseIncome   = the_spouse_income[sapto_single])
    }
  }
  
  new_tax <-
  {
    if (baseline_fy == "2011-12") {
      flood_levy. <- 0.005 * {pmaxC(income - 50e3, 0) + pmaxC(income - 100e3, 0)}
    } else {
      flood_levy. <- 0
    }
    
    # http://classic.austlii.edu.au/au/legis/cth/consol_act/itaa1997240/s4.10.html
    S4.10_basic_income_tax_liability <- pmaxC(base_tax. - lito. - sapto., 0)
    
    # SBTO can only be calculated off .dots.ATO
    
    sbto. <-
      small_business_tax_offset(taxable_income = income,
                                basic_income_tax_liability = S4.10_basic_income_tax_liability,
                                .dots.ATO = .dots.ATO,
                                fy_year = baseline_fy)
    
    pmaxC(S4.10_basic_income_tax_liability - sbto., 0) +
      medicare_levy. +
      flood_levy.
  }
  # new_tax2 <<- new_tax
  
  # Elasticity of Taxable Income
  ## 
  if (!is.null(elasticity_of_taxable_income)) {
    D_tax <- new_tax - old_tax
    # Change in net income
    new_taxable_income <-
      income * (1 - elasticity_of_taxable_income * D_tax / (income - old_tax)) %>%
      coalesce(0)
    
    sample_file[, new_taxable_income := new_taxable_income]
    
    if (anyNA(new_taxable_income) || identical(as.double(new_taxable_income), as.double(income))) stop("NAs: ", sum(is.na(new_taxable_income)), call. = FALSE)
    
    new_argument_vals <-
      argument_vals %>%
      .[names(argument_vals) %notin% c("arguments",
                                       "elasticity_of_taxable_income",
                                       "sample_file",
                                       "calc_baseline_tax",
                                       "return.")]
    
    new_sample_file <- copy(sample_file)
    new_sample_file[, "Taxable_Income" := as.double(new_taxable_income)]
    
    .model_income_tax <- function(...) {
      model_income_tax(sample_file = new_sample_file,
                       elasticity_of_taxable_income = NULL,
                       return. = "tax",
                       calc_baseline_tax = FALSE,
                       ...)
    }
    
    new_tax <- do.call(.model_income_tax, new_argument_vals)
  }
  
  switch(return.,
         "tax" = new_tax,
         "sample_file" = sample_file[, new_tax := as.double(new_tax)])
}

Try the grattan package in your browser

Any scripts or data that you put into this service are public.

grattan documentation built on Feb. 22, 2018, 5:01 p.m.