## ----include = FALSE----------------------------------------------------------
knitr::opts_chunk$set(collapse = TRUE, comment = "#>")

## -----------------------------------------------------------------------------
library(personnelSelectionUtility)

## -----------------------------------------------------------------------------
Rxx <- matrix(c(
  1.00, .31, .03, .37,
  .31, 1.00, .13, .16,
  .03, .13, 1.00, .51,
  .37, .16, .51, 1.00
), 4, 4, byrow = TRUE)
validities <- c(.37, .35, .16, .23)

## -----------------------------------------------------------------------------
comp <- compensatory_selection(
  predictor_cor      = Rxx,
  validities         = validities,
  weights            = rep(1, 4),
  selection_ratio    = .20,
  n_applicants       = 500,
  cost_per_applicant = 1000,
  sdy                = 60000
)
comp

## -----------------------------------------------------------------------------
R <- rbind(cbind(Rxx, validities), c(validities, 1))

hurdle <- multiple_hurdle_selection_staged(
  stage_predictors       = list(c(1, 3, 4), 2),
  stage_selection_ratios = c(.25, .80),
  R                      = R,
  n_sim                  = 5000,
  seed                   = 123,
  n_applicants           = 500,
  cost_per_stage         = c(100, 900),
  sdy                    = 60000
)
hurdle

## -----------------------------------------------------------------------------
comparison <- compare_selection_systems_staged(
  predictor_cor                  = Rxx,
  validities                     = validities,
  compensatory_weights           = rep(1, 4),
  compensatory_selection_ratio   = .20,
  stage_predictors               = list(c(1, 3, 4), 2),
  stage_selection_ratios         = c(.25, .80),
  n_sim                          = 5000,
  seed                           = 123,
  n_applicants                   = 500,
  compensatory_cost_per_applicant = 1000,
  hurdle_cost_per_stage          = c(100, 900),
  sdy                            = 60000
)
comparison

## -----------------------------------------------------------------------------
c(
  expected_z_difference  = comparison$expected_criterion_z_difference,
  net_utility_difference = comparison$net_utility_difference
)

## -----------------------------------------------------------------------------
sdy_values <- c(20000, 40000, 60000)
hurdle_stage2_cost <- c(200, 500, 900)

out <- expand.grid(sdy = sdy_values, interview_cost = hurdle_stage2_cost)
out$net_utility_difference <- NA_real_

for (i in seq_len(nrow(out))) {
  cmp <- compare_selection_systems_staged(
    predictor_cor                  = Rxx,
    validities                     = validities,
    compensatory_selection_ratio   = .20,
    stage_predictors               = list(c(1, 3, 4), 2),
    stage_selection_ratios         = c(.25, .80),
    n_sim                          = 3000,
    seed                           = 100 + i,
    n_applicants                   = 500,
    compensatory_cost_per_applicant = 1000,
    hurdle_cost_per_stage          = c(100, out$interview_cost[i]),
    sdy                            = out$sdy[i]
  )
  out$net_utility_difference[i] <- cmp$net_utility_difference
}

out

## -----------------------------------------------------------------------------
# First compute the expected standardised score among offered candidates:
z_offered <- selected_mean_z(.20)

# Adverse selection (correlated mode): top candidates are more likely to decline,
# captured by a negative correlation between standardised quality and acceptance.
offer_rejection_adjustment(
  expected_z_offered     = z_offered,
  mode                   = "correlated",
  acceptance_rate        = .70,
  rho_quality_acceptance = -0.20,
  n_offered              = 100
)

## -----------------------------------------------------------------------------
# adverse_impact_ratio() takes individual-level selection outcomes and group labels;
# it computes the selection rate per group and the four-fifths ratio relative to
# the group with the highest rate.
selected <- c(1, 1, 0, 1, 0, 1, 0, 1, 0,
              1, 0, 0, 1, 0, 0, 0, 1, 0)
group    <- c(rep("Reference", 9), rep("Focal", 9))
adverse_impact_ratio(selected, group)

## -----------------------------------------------------------------------------
# pareto_frontier() is a general Pareto-membership indicator: given a matrix of
# objectives (rows = alternatives, columns = objectives to maximise), it returns
# a logical vector flagging the non-dominated alternatives. The validity-diversity
# trade-off in selection systems is one application; below we evaluate six candidate
# weighting schemes on composite validity and four-fifths fairness.
candidates <- data.frame(
  scheme   = c("CA only", "CA + interview",
               "Equal weights", "Validity weights",
               "Pareto-optimal #1", "Pareto-optimal #2"),
  validity = c(.51, .55, .50, .56, .53, .54),
  fairness = c(.62, .68, .73, .65, .76, .80)
)
candidates$pareto <- pareto_frontier(
  objectives = candidates[, c("validity", "fairness")],
  maximize   = TRUE
)
candidates

## -----------------------------------------------------------------------------
# Two candidate selection systems evaluated on three attributes (task,
# contextual, CWB avoidance), with values on a common 0-100 scale:
values <- matrix(c(
  80, 60, 90,
  70, 75, 70
), nrow = 2, byrow = TRUE,
   dimnames = list(c("System A", "System B"),
                   c("task", "contextual", "cwb_avoidance")))

multiattribute_utility(
  values  = values,
  weights = c(.50, .30, .20)
)

## -----------------------------------------------------------------------------
# The mean-variance risk-adjusted score subtracts a penalty proportional to the
# variance of utility. Because monetary utilities are often in the millions, the
# risk_aversion parameter is typically very small (e.g., 1e-6 to 1e-5). The
# example below uses the compensatory net utility computed earlier.
risk_adjusted_utility(
  expected_utility = comparison$compensatory$net_utility,
  utility_sd       = abs(comparison$compensatory$net_utility) * .30,
  risk_aversion    = 1e-6
)