#' Diagnose identification of the latent census table
#'
#' @param object A fitted `inter_sae` object.
#' @param tol Numerical rank tolerance.
#' @return An object of class `inter_identifiability`.
#' @export
check_identifiability <- function(object, tol = 1e-9) {
  if (!inherits(object, "inter_sae")) {
    stop("`object` must be a fitted `inter_sae` object.", call. = FALSE)
  }
  system <- .inter_constraint_system(object$population$grid, object$margins)
  rank <- qr(system$A, tol = tol)$rank
  cells <- ncol(system$A)
  result <- structure(
    list(
      cells = cells,
      constraints = nrow(system$A),
      rank = rank,
      nullity = cells - rank,
      table_identified = cells == rank,
      structural_zeros = if (is.null(object$margins$structural_zeros)) 0L else
        nrow(object$margins$structural_zeros),
      tolerance = tol
    ),
    class = "inter_identifiability"
  )
  result
}

#' @export
print.inter_identifiability <- function(x, ...) {
  cat("Identification diagnostic\n")
  cat("  Feasible cells: ", x$cells, "\n", sep = "")
  cat("  Independent margin constraints: ", x$rank, "\n", sep = "")
  cat("  Unidentified dimensions: ", x$nullity, "\n", sep = "")
  cat("  Full table identified: ", if (x$table_identified) "yes" else "no",
      "\n", sep = "")
  invisible(x)
}

.inter_lp <- function(direction, objective, mat, dir, rhs) {
  solution <- lpSolve::lp(
    direction = direction,
    objective.in = objective,
    const.mat = mat,
    const.dir = dir,
    const.rhs = rhs,
    all.int = FALSE,
    all.bin = FALSE,
    transpose.constraints = TRUE
  )
  if (solution$status != 0L) {
    stop("The requested identification problem is infeasible or unbounded (lpSolve status ",
         solution$status, ").", call. = FALSE)
  }
  solution$objval
}

.inter_domain_label <- function(domain) {
  if (is.null(domain) || !length(domain)) return("All")
  paste(paste0(names(domain), "=", vapply(domain, function(x) {
    paste(as.character(x), collapse = "|")
  }, character(1))), collapse = ", ")
}

#' Compute census-margin identification bounds
#'
#' @param object A fitted `inter_sae` object.
#' @param domain Optional named list defining one target domain.
#' @param gamma Association sensitivity parameter. `Inf` uses only the census
#'   margins; finite values constrain each latent cell to lie between its fitted
#'   population divided by `gamma` and multiplied by `gamma`.
#' @param statistic Bound a domain `mean`/proportion or a predicted `total`.
#' @return An object of class `inter_bounds`.
#' @export
identification_bounds <- function(object, domain = NULL, gamma = Inf,
                                  statistic = c("mean", "total")) {
  if (!inherits(object, "inter_sae")) {
    stop("`object` must be a fitted `inter_sae` object.", call. = FALSE)
  }
  if (!requireNamespace("lpSolve", quietly = TRUE)) {
    stop("Package `lpSolve` is required for identification bounds.",
         call. = FALSE)
  }
  statistic <- match.arg(statistic)
  if (!is.numeric(gamma) || length(gamma) != 1L || is.na(gamma) || gamma < 1) {
    stop("`gamma` must be one number greater than or equal to 1, or `Inf`.",
         call. = FALSE)
  }
  grid <- object$population$grid
  mask <- .inter_match_rows(grid, domain)
  if (!any(mask)) {
    stop("The requested domain contains no feasible population cells.",
         call. = FALSE)
  }
  predicted <- grid$.prediction
  reference <- grid$.population
  p <- as.numeric(mask) * predicted
  q <- as.numeric(mask)
  baseline <- if (statistic == "mean") {
    sum(reference * p) / sum(reference * q)
  } else {
    sum(reference * p)
  }
  if (isTRUE(all.equal(gamma, 1))) {
    return(structure(
      list(lower = baseline, estimate = baseline, upper = baseline,
           gamma = gamma, statistic = statistic,
           domain = domain, domain_label = .inter_domain_label(domain)),
      class = "inter_bounds"
    ))
  }

  system <- .inter_constraint_system(grid, object$margins)
  A <- system$A
  b <- system$b
  nonempty <- rowSums(abs(A)) > 0 | abs(b) > 0
  A <- A[nonempty, , drop = FALSE]
  b <- b[nonempty]
  cells <- nrow(grid)

  if (statistic == "mean") {
    equality <- rbind(cbind(A, -b), c(q, 0))
    directions <- rep.int("=", nrow(equality))
    right_hand_side <- c(rep.int(0, nrow(A)), 1)
    constraints <- equality
    if (is.finite(gamma)) {
      upper <- reference * gamma
      lower <- reference / gamma
      upper_constraints <- cbind(diag(cells), -upper)
      lower_constraints <- cbind(-diag(cells), lower)
      constraints <- rbind(constraints, upper_constraints, lower_constraints)
      directions <- c(directions, rep.int("<=", 2L * cells))
      right_hand_side <- c(right_hand_side, rep.int(0, 2L * cells))
    }
    objective <- c(p, 0)
  } else {
    constraints <- A
    directions <- rep.int("=", nrow(A))
    right_hand_side <- b
    if (is.finite(gamma)) {
      upper <- reference * gamma
      lower <- reference / gamma
      constraints <- rbind(constraints, diag(cells), -diag(cells))
      directions <- c(directions, rep.int("<=", cells), rep.int("<=", cells))
      right_hand_side <- c(right_hand_side, upper, -lower)
    }
    objective <- p
  }
  lower_bound <- .inter_lp("min", objective, constraints, directions,
                           right_hand_side)
  upper_bound <- .inter_lp("max", objective, constraints, directions,
                           right_hand_side)

  structure(
    list(
      lower = lower_bound,
      estimate = baseline,
      upper = upper_bound,
      gamma = gamma,
      statistic = statistic,
      domain = domain,
      domain_label = .inter_domain_label(domain)
    ),
    class = "inter_bounds"
  )
}

#' @export
print.inter_bounds <- function(x, ...) {
  cat("Identification bounds\n")
  cat("  Domain: ", x$domain_label, "\n", sep = "")
  cat("  Statistic: ", x$statistic, "\n", sep = "")
  cat("  Gamma: ", format(x$gamma), "\n", sep = "")
  cat("  Lower / estimate / upper: ",
      paste(format(c(x$lower, x$estimate, x$upper), digits = 6),
            collapse = " / "), "\n", sep = "")
  invisible(x)
}

#' Evaluate association sensitivity across gamma values
#'
#' @param object A fitted `inter_sae` object.
#' @param gamma Numeric vector of sensitivity values.
#' @param domain Optional named list defining one target domain.
#' @param statistic Either `mean` or `total`.
#' @return A data frame of sensitivity bounds.
#' @export
inter_sensitivity <- function(object, gamma = c(1, 1.25, 1.5, 2, Inf),
                              domain = NULL,
                              statistic = c("mean", "total")) {
  statistic <- match.arg(statistic)
  if (!is.numeric(gamma) || !length(gamma) || any(is.na(gamma)) ||
      any(gamma < 1)) {
    stop("Every `gamma` value must be at least 1.", call. = FALSE)
  }
  values <- lapply(gamma, function(current) {
    identification_bounds(object, domain = domain, gamma = current,
                          statistic = statistic)
  })
  data.frame(
    gamma = gamma,
    lower = vapply(values, `[[`, numeric(1), "lower"),
    estimate = vapply(values, `[[`, numeric(1), "estimate"),
    upper = vapply(values, `[[`, numeric(1), "upper"),
    domain = .inter_domain_label(domain),
    statistic = statistic,
    stringsAsFactors = FALSE
  )
}
