# ============================================================
#  classifiers.R
#  bayes_depth_classify()    — Section 3.6
#  logistic_depth_classify() — Section 3.7
#  gam_depth_classify()      — Sections 3.8-3.9
# ============================================================


# -----------------------------------------------------------------------
#  bayes_depth_classify
# -----------------------------------------------------------------------

#' Bayesian Kernel-Density Classifier on Signed Depth
#'
#' Classifies functional curves via Bayes' rule applied to the signed depths.
#' Class-conditional densities \eqn{f_g(\mathrm{sdp})} are estimated by
#' kernel density estimation; prior probabilities are estimated from class
#' frequencies or supplied by the user.
#'
#' The posterior probability that a new observation belongs to class \eqn{g}
#' is
#' \deqn{P(g \mid \mathrm{sdp}_0) =
#'   \frac{f_g(\mathrm{sdp}_0)\,\pi_g}
#'   {\sum_{g'} f_{g'}(\mathrm{sdp}_0)\,\pi_{g'}}.}
#'
#' @param X_train Numeric matrix (\eqn{n_{\mathrm{train}} \times M}).
#' @param y_train Integer vector of labels (0/1).
#' @param X_test Numeric matrix of test curves. If \code{NULL} the training
#'   set is used.
#' @param priors Named numeric vector with elements \code{"0"} and \code{"1"}
#'   giving prior probabilities. Defaults to empirical class proportions.
#' @param bw_method Bandwidth selection method passed to
#'   \code{\link[stats]{density}}: \code{"nrd0"} (default), \code{"nrd"},
#'   \code{"ucv"}, \code{"bcv"}, or \code{"SJ"}.
#' @param grid Numeric vector of length \eqn{M} (time grid).
#' @param type Depth variant.
#'
#' @return An object of class \code{"fd_bayes_fit"} with components:
#'   \describe{
#'     \item{predicted}{Predicted class labels.}
#'     \item{prob}{Matrix with columns \code{prob_0} and \code{prob_1}:
#'       posterior probabilities.}
#'     \item{log_odds}{Log-odds
#'       \eqn{\log(f_0\pi_0 / f_1\pi_1)}.}
#'     \item{sd_train}{The \code{"fd_signed_depth"} object for the training
#'       set.}
#'   }
#'
#' @examples
#' set.seed(11)
#' M <- 80; N <- 100
#' t  <- seq(0, 1, length.out = M)
#' X0 <- t(replicate(50, sin(2 * pi * t) + rnorm(M, sd = 0.4)))
#' X1 <- t(replicate(50, cos(2 * pi * t) + rnorm(M, sd = 0.4)))
#' X  <- rbind(X0, X1)
#' y  <- rep(0:1, each = 50)
#' fit <- bayes_depth_classify(X, y)
#' table(fit$predicted, y)
#'
#' @export
bayes_depth_classify <- function(X_train, y_train,
                                 X_test    = NULL,
                                 priors    = NULL,
                                 bw_method = "nrd0",
                                 grid      = NULL,
                                 type      = c("tukey", "simplicial")) {
  type    <- match.arg(type)
  y_train <- as.integer(y_train)
  M       <- ncol(X_train)
  if (is.null(grid)) grid <- seq(0, 1, length.out = M)
  sd_tr  <- signed_depth(X_train, grid = grid, type = type)
  sdp_tr <- sd_tr$sdp
  sdp_te <- if (is.null(X_test)) sdp_tr else
    .project_signed_depth(X_test, sd_tr)
  classes <- sort(unique(y_train))
  if (is.null(priors)) {
    priors <- vapply(classes, function(g) mean(y_train == g), numeric(1L))
    names(priors) <- as.character(classes)
  }
  kdes <- lapply(classes, function(g)
    stats::density(sdp_tr[y_train == g], bw = bw_method))
  names(kdes) <- as.character(classes)
  eval_kde <- function(kde_obj, x)
    stats::approx(kde_obj$x, kde_obj$y, xout = x, rule = 2)$y
  dens_mat <- sapply(as.character(classes), function(g)
    eval_kde(kdes[[g]], sdp_te) * priors[g])
  if (is.vector(dens_mat)) dens_mat <- matrix(dens_mat, nrow = 1)
  post_mat           <- sweep(dens_mat, 1, rowSums(dens_mat), "/")
  colnames(post_mat) <- paste0("prob_", classes)
  predicted          <- classes[apply(post_mat, 1, which.max)]
  log_odds           <- log((dens_mat[, "0"] + 1e-300) /
                            (dens_mat[, "1"] + 1e-300))
  structure(
    list(predicted = predicted, prob = post_mat,
         log_odds  = log_odds,  sd_train = sd_tr),
    class = "fd_bayes_fit"
  )
}

#' @param x A \code{"fd_bayes_fit"} object.
#' @param ... Ignored.
#' @return Invisibly returns \code{x}.
#' @rdname bayes_depth_classify
#' @export
print.fd_bayes_fit <- function(x, ...) {
  cat("Bayesian Depth Classifier\n")
  cat("  Training N:", x$sd_train$N, "\n")
  invisible(x)
}


# -----------------------------------------------------------------------
#  logistic_depth_classify
# -----------------------------------------------------------------------

#' Logistic Regression Classifier on Signed Depth
#'
#' Fits a logistic regression model with class label as response and signed
#' depth (and optionally signed distance to the mode) as covariates
#' (Section 3.7 of Perez Ruiz, 2020).
#'
#' Three model formulae are supported:
#' \describe{
#'   \item{\code{"sdp"}}{Model 1: signed depth only.}
#'   \item{\code{"sdp+mode"}}{Model 2: signed depth plus signed distance to
#'     mode.}
#'   \item{\code{"sdp*mode"}}{Model 3: Model 2 plus interaction term.}
#' }
#'
#' @param X_train Numeric matrix (\eqn{n_{\mathrm{train}} \times M}).
#' @param y_train Integer vector of labels (0/1).
#' @param X_test Numeric matrix. If \code{NULL} the training set is used.
#' @param model Character: \code{"sdp"} (default), \code{"sdp+mode"}, or
#'   \code{"sdp*mode"}.
#' @param n_pc Number of principal components for mode estimation. Default 10.
#' @param grid Numeric vector of length \eqn{M}.
#' @param type Depth variant.
#'
#' @return An object of class \code{"fd_logistic_fit"} with components:
#'   \describe{
#'     \item{predicted}{Predicted class labels.}
#'     \item{prob}{Matrix with columns \code{prob_0} and \code{prob_1}.}
#'     \item{glm_fit}{The fitted \code{\link[stats]{glm}} object.}
#'     \item{sd_train}{The \code{"fd_signed_depth"} object for the training
#'       set.}
#'     \item{model}{Character: model formula used.}
#'   }
#'
#' @examples
#' set.seed(13)
#' M <- 80; N <- 100
#' t  <- seq(0, 1, length.out = M)
#' X0 <- t(replicate(50, sin(2 * pi * t) + rnorm(M, sd = 0.4)))
#' X1 <- t(replicate(50, cos(2 * pi * t) + rnorm(M, sd = 0.4)))
#' X  <- rbind(X0, X1)
#' y  <- rep(0:1, each = 50)
#' fit <- logistic_depth_classify(X, y, model = "sdp")
#' summary(fit$glm_fit)
#'
#' @export
logistic_depth_classify <- function(X_train, y_train,
                                    X_test = NULL,
                                    model  = c("sdp", "sdp+mode", "sdp*mode"),
                                    n_pc   = 10L,
                                    grid   = NULL,
                                    type   = c("tukey", "simplicial")) {
  model   <- match.arg(model)
  type    <- match.arg(type)
  y_train <- as.integer(y_train)
  M       <- ncol(X_train)
  if (is.null(grid)) grid <- seq(0, 1, length.out = M)
  sd_tr  <- signed_depth(X_train, grid = grid, type = type)
  sdp_tr <- sd_tr$sdp
  df_tr  <- data.frame(y = y_train, sdp = sdp_tr)
  sdm_ref <- NULL
  if (model %in% c("sdp+mode", "sdp*mode")) {
    sdm_tr      <- .signed_dist_to_mode(X_train, n_pc = n_pc)
    sdm_ref     <- attr(sdm_tr, "ref_mode")
    df_tr$sdm   <- sdm_tr
  }
  gf <- switch(model,
    "sdp"      = stats::glm(y ~ sdp,       data = df_tr,
                            family = stats::binomial()),
    "sdp+mode" = stats::glm(y ~ sdp + sdm, data = df_tr,
                            family = stats::binomial()),
    "sdp*mode" = stats::glm(y ~ sdp * sdm, data = df_tr,
                            family = stats::binomial())
  )
  if (is.null(X_test)) {
    df_te <- df_tr[, setdiff(names(df_tr), "y"), drop = FALSE]
  } else {
    sdp_te <- .project_signed_depth(X_test, sd_tr)
    df_te  <- data.frame(sdp = sdp_te)
    if (model %in% c("sdp+mode", "sdp*mode"))
      df_te$sdm <- .signed_dist_to_mode(X_test, n_pc = n_pc,
                                        ref_mode = sdm_ref)
  }
  prob_1    <- stats::predict(gf, newdata = df_te, type = "response")
  predicted <- as.integer(prob_1 > 0.5)
  structure(
    list(predicted = predicted,
         prob      = cbind(prob_0 = 1 - prob_1, prob_1 = prob_1),
         glm_fit   = gf, sd_train = sd_tr, model = model),
    class = "fd_logistic_fit"
  )
}

#' @param x A \code{"fd_logistic_fit"} object.
#' @param ... Ignored.
#' @return Invisibly returns \code{x}.
#' @rdname logistic_depth_classify
#' @export
print.fd_logistic_fit <- function(x, ...) {
  cat("Logistic Depth Classifier\n")
  cat("  Model      :", x$model, "\n")
  cat("  Training N :", x$sd_train$N, "\n")
  cat("  AIC        :", round(x$glm_fit$aic, 2), "\n")
  invisible(x)
}


# -----------------------------------------------------------------------
#  gam_depth_classify
# -----------------------------------------------------------------------

#' GAM Classifier on Signed Depth
#'
#' Fits a generalised additive model (GAM) with a smooth term on the signed
#' depth to estimate class membership probabilities. An optional iterative
#' outlier down-weighting scheme is available (Section 3.8 of Perez Ruiz,
#' 2020).
#'
#' @param X_train Numeric matrix (\eqn{N \times M}).
#' @param y_train Integer vector of labels (0/1).
#' @param X_test Numeric matrix. If \code{NULL} the training set is used.
#' @param covariates Character: \code{"sdp"} (default) or \code{"sdp+mode"}
#'   to include a second smooth on the signed distance to the mode.
#' @param k_gam Basis dimension for \code{\link[mgcv]{s}}. Default \code{10}.
#' @param n_pc Number of PCs for mode estimation. Default \code{10}.
#' @param downweight Logical; if \code{TRUE} iterate with outlier
#'   down-weighting. Default \code{FALSE}.
#' @param max_iter Maximum down-weighting iterations. Default \code{10}.
#' @param grid Numeric vector of length \eqn{M}.
#' @param type Depth variant.
#'
#' @return An object of class \code{"fd_gam_fit"} with components:
#'   \describe{
#'     \item{predicted}{Predicted class labels.}
#'     \item{prob}{Matrix with columns \code{prob_0} and \code{prob_1}.}
#'     \item{gam_fit}{The fitted \code{\link[mgcv]{gam}} object.}
#'     \item{sd_train}{The \code{"fd_signed_depth"} object for the training
#'       set.}
#'     \item{covariates}{Character: covariates used.}
#'   }
#'
#' @examples
#' set.seed(17)
#' M <- 80; N <- 100
#' t  <- seq(0, 1, length.out = M)
#' X0 <- t(replicate(50, sin(2 * pi * t) + rnorm(M, sd = 0.4)))
#' X1 <- t(replicate(50, cos(2 * pi * t) + rnorm(M, sd = 0.4)))
#' X  <- rbind(X0, X1)
#' y  <- rep(0:1, each = 50)
#' fit <- gam_depth_classify(X, y)
#' print(fit)
#'
#' @export
gam_depth_classify <- function(X_train, y_train,
                               X_test     = NULL,
                               covariates = c("sdp", "sdp+mode"),
                               k_gam      = 10L,
                               n_pc       = 10L,
                               downweight = FALSE,
                               max_iter   = 10L,
                               grid       = NULL,
                               type       = c("tukey", "simplicial")) {
  covariates <- match.arg(covariates)
  type       <- match.arg(type)
  y_train    <- as.integer(y_train)
  classes    <- sort(unique(y_train))
  G          <- length(classes)
  M          <- ncol(X_train)
  if (is.null(grid)) grid <- seq(0, 1, length.out = M)
  if (G != 2L)
    stop("Multiclass GAM is planned for v0.2. ",
         "For G > 2 use logistic_depth_classify() with pairwise comparisons.")
  sd_tr  <- signed_depth(X_train, grid = grid, type = type)
  sdp_tr <- sd_tr$sdp
  df_tr  <- data.frame(y_bin = as.integer(y_train == classes[2L]),
                       sdp   = sdp_tr)
  sdm_ref <- NULL
  if (covariates == "sdp+mode") {
    sdm_tr      <- .signed_dist_to_mode(X_train, n_pc = n_pc)
    sdm_ref     <- attr(sdm_tr, "ref_mode")
    df_tr$sdm   <- sdm_tr
  }
  if (covariates == "sdp") {
    gam_formula <- y_bin ~ s(sdp, k = 10)
  } else {
    gam_formula <- y_bin ~ s(sdp, k = 10) + s(sdm, k = 10)
  }
  weights_vec <- rep(1, nrow(df_tr))
  if (downweight) {
    for (iter in seq_len(max_iter)) {
      environment(gam_formula) <- environment()
      gam_fit  <- mgcv::gam(gam_formula, data = df_tr,
                            family = stats::binomial(),
                            weights = weights_vec)
      fitted_p <- stats::fitted(gam_fit)
      resid_p  <- abs(df_tr$y_bin - fitted_p)
      weights_vec <- ifelse(resid_p > 0.5, 0.5 / resid_p, 1)
    }
  } else {
    environment(gam_formula) <- environment()
    gam_fit <- mgcv::gam(gam_formula, data = df_tr,
                         family = stats::binomial())
  }
  if (is.null(X_test)) {
    df_te <- df_tr[, setdiff(names(df_tr), "y_bin"), drop = FALSE]
  } else {
    sdp_te <- .project_signed_depth(X_test, sd_tr)
    df_te  <- data.frame(sdp = sdp_te)
    if (covariates == "sdp+mode")
      df_te$sdm <- .signed_dist_to_mode(X_test, n_pc = n_pc,
                                        ref_mode = sdm_ref)
  }
  prob_1    <- stats::predict(gam_fit, newdata = df_te, type = "response")
  predicted <- as.integer(prob_1 > 0.5)
  structure(
    list(predicted  = predicted,
         prob       = cbind(prob_0 = 1 - prob_1, prob_1 = prob_1),
         gam_fit    = gam_fit, sd_train = sd_tr, covariates = covariates),
    class = "fd_gam_fit"
  )
}

#' @param x A \code{"fd_gam_fit"} object.
#' @param ... Ignored.
#' @return Invisibly returns \code{x}.
#' @rdname gam_depth_classify
#' @export
print.fd_gam_fit <- function(x, ...) {
  cat("GAM Depth Classifier\n")
  cat("  Covariates :", x$covariates, "\n")
  cat("  Training N :", x$sd_train$N, "\n")
  cat("  Dev. expl. :", round(summary(x$gam_fit)$dev.expl * 100, 1), "%\n")
  invisible(x)
}


# -----------------------------------------------------------------------
#  Internal: signed distance to the modal curve (Section 3.7.1)
# -----------------------------------------------------------------------

#' @keywords internal
.signed_dist_to_mode <- function(X, n_pc = 10L, ref_mode = NULL) {
  N   <- nrow(X); M <- ncol(X)
  npc <- min(as.integer(n_pc), N - 1L, M)
  X_c     <- scale(X, center = TRUE, scale = FALSE)
  svd_res <- svd(X_c / sqrt(N - 1), nu = 0, nv = npc)
  scores  <- X_c %*% svd_res$v
  if (is.null(ref_mode)) {
    modes <- vapply(seq_len(npc), function(j)
      modeest::mfv1(scores[, j], method = "parzen"), numeric(1L))
  } else {
    modes <- ref_mode
  }
  sdm <- as.numeric(
    (scores - matrix(modes, nrow = N, ncol = npc, byrow = TRUE)) %*%
    rep(1, npc))
  attr(sdm, "ref_mode") <- modes
  sdm
}
