Add validation functions? about raker HOT 3 OPEN

int_validate <- function(constraints, ind_agg) {

  correlation <- cor(as.numeric(constraints), as.numeric(ind_agg))

  max_abs_diff <- max(abs(ind_agg - constraints))

  tae <- tae(constraints, ind_agg)

  sae <- tae(constraints, ind_agg) / sum(constraints)

  cor_vec <- rep(0, dim(constraints)[1])
  for (i in 1:dim(constraints)[1]) {
    cor_vec[i] <- cor(as.numeric(constraints[i, ]), as.numeric(ind_agg[i, ]))
  }
  # cor_vec <- summary(cor_vec)

  tae_vec <- rep(0, nrow(constraints))
  sae_vec <- rep(0, nrow(constraints))
  for (i in 1:nrow(constraints)) {
    tae_vec[i] <- tae(constraints[i, ], ind_agg[i, ])
    sae_vec[i] <- tae_vec[i] / sum(constraints[i, ])
  }

  worst_zone <- which.max(tae_vec)
  # worst_zone <- tae_vec[worst_zone] / sum(tae_vec))

  out <- list(
    "correlation"  = correlation,
    "max_abs_diff" = max_abs_diff,
    "tae"          = tae,
    "sae"          = sae,
    "cor_vec"      = cor_vec,
    "tae_vec"      = tae_vec,
    "sae_vec"      = sae_vec,
    "worst_zone"   = worst_zone
  )

  out

}

ext_validate <- function(llid_val, constraint, simdf, code_geo) {

  llid_val <- llid_val %>%
    select(GEOGRAPHY_CODE, C_DISABILITY_NAME, OBS_VALUE) %>%
    spread(C_DISABILITY_NAME, OBS_VALUE)

  llid_val$llid <- rowSums(llid_val[, 2:3])

  colnames(llid_val) <- c("code", "little", "lot",
                          "llid_no_census", "llid_census")
  llid_val <- select(llid_val, -little, -lot)

  context("Check llid_val object")
  test_that("Population of llid_val matches constraint", {
    expect_equal(sum(llid_val[, 2:3]),
      sum(constraint[, grep("age_[[:digit:]]", colnames(constraint))]))
  })

  # Add sim_llid to zone_simdf_oa
  llid_sim <- simdf %>%
    select(c_llid, zone) %>%
    count(zone, c_llid) %>%
    spread(c_llid, n)

  colnames(llid_sim) <- c("zone", "llid_no_sim", "llid_sim")
  llid_sim$code <- NA
  llid_sim$code <- codes[[as.character(code_geo)]]

  # merge on codes (not rbind) because prison OAs removed!
  llid_val <- left_join(llid_val, llid_sim, by = "code")

  llid_val

}

calc_perr <- function(llid_val) {

  total <- rowSums(llid_val[, c("llid_no_census", "llid_census")])
  perr  <- llid_val$llid_census - llid_val$llid_sim
  perr  <- abs(perr)
  perr  <- perr / total
  perr  <- perr * 100

  perr

}