
#' Goodness-of-Fit Test for Ordinal Regression Models
#'
#' Tests the goodness of fit for ordinal regression models, reproducing
#' results equivalent to 'Stata's output. Supports models from \code{polr()},
#' \code{vglm()}, and binary \code{glm()}.
#'
#' @param model A fitted model object. Supported classes: \code{polr} (MASS),
#'   \code{vglm} (VGAM), or \code{glm} (stats, binomial family).
#' @param data A data frame used to fit the model.
#' @param catvars Character vector of categorical variable names. Required only
#'   when \code{test = "pr.chi2"} or \code{test = "pr.dev"}.
#' @param g Integer. Number of quantile groups (default: 10).
#' @param test Character. The test to perform. One of \code{"hl"} (default),
#'   \code{"lipsitz"}, \code{"pr.chi2"}, or \code{"pr.dev"}.
#' @param ties Character. Tie-breaking method for grouping. One of
#'   \code{"stata"} (default), \code{"sorted"}, or \code{"equal"}.
#'   \code{"stata"} reproduces 'Stata's behavior.
#' @param show_table Logical. If \code{TRUE}, prints the observed/expected
#'   frequency table. Default is \code{FALSE}.
#'
#' @return An object of class \code{htest} containing:
#' \describe{
#'   \item{statistic}{The chi-squared test statistic.}
#'   \item{parameter}{Degrees of freedom.}
#'   \item{p.value}{The p-value.}
#'   \item{method}{A character string naming the test used.}
#' }
#'
#' @examples
#' library(MASS)
#' data(housing, package = "MASS")
#' m <- polr(Sat ~ Infl + Type + Cont, data = housing, Hess = TRUE)
#' ordinalGOF(m, data = housing, g = 5, test = "hl", ties = "stata")
#'
#' @importFrom stats model.response model.frame pchisq median
#' @importFrom dplyr select mutate group_by n_distinct all_of row_number
#' @importFrom MASS polr
#' @importFrom VGAM vglm predict
#' @importFrom magrittr %>%
#'
#' @export


ordinalGOF <- function(model,
                        data,
                        catvars = NULL,
                        g = 10,
                        test = c("hl", "pr.chi2", "pr.dev", "lipsitz"),
                        ties = c("stata", "sorted", "equal"),
                        show_table = FALSE) {

  test <- match.arg(test)
  ties <- match.arg(ties)
  pattern <- NULL
  model_class <- class(model)[1]

  if (model_class == "polr") {
    # MASS::polr
    outcome <- model.response(model.frame(model))
    probs <- predict(model, type = "probs")

  } else if (model_class == "vglm") {
    # VGAM::vglm
    outcome <- model@y
    if (is.matrix(outcome)) {
      outcome <- factor(max.col(outcome) - 1,
                        levels = 0:(ncol(outcome) - 1),
                        ordered = TRUE)
    }
    probs <- predict(model, type = "response")

  } else if (model_class == "glm") {
    # stats::glm with binomial family
    outcome <- model$y
    outcome <- ordered(ifelse(outcome == 1, 1, 0), levels = c(0, 1))
    p1 <- predict(model, type = "response")
    probs <- cbind(1 - p1, p1)
    colnames(probs) <- c("0", "1")

  } else {
    stop(paste("Model class '", model_class,
               "' not supported. Use polr(), clm(), or vglm().", sep = ""))
  }

  # Ensuring outcome is ordered
  if (!is.ordered(outcome)) {
    outcome <- ordered(outcome)
  }


  J <- ncol(probs)
  n <- length(outcome)
  cat_labels <- levels(outcome) #added for generalization

  # Different methods use different approaches entirely
  if (ties == "stata") {
    # Stata method: Your current approach
    ord_score <- as.vector(probs %*% 0:(J - 1))
    ord_score <- round(ord_score, 7)  # Round to match Stata's tie-breaking
    df_value <- (g - 2) * (J - 1)

    sorted_indices <- order(ord_score, outcome)
    group_ids <- numeric(n)
    cutpoints <- numeric(g - 1)

    base_group_size <- floor(n / g)
    extras <- n %% g
    group_sizes <- rep(base_group_size, g)
    group_sizes[c(1, 6)] <- group_sizes[c(1, 6)] + c(extras %/% 2 + extras %% 2, extras %/% 2)

    index <- 1
    for (i in 1:g) {
      upper <- index + group_sizes[i] - 1
      group_ids[sorted_indices[index:upper]] <- i
      if (i < g) {
        cutpoints[i] <- ord_score[sorted_indices[upper]]
      }
      index <- upper + 1
    }

  } else if (ties == "sorted") {
    # gofcat method: Sort by score then outcome, use equal-sized groups
    ord_score <- as.vector(probs %*% 0:(J - 1))
    ord_score <- round(ord_score, 7)
    df_value <- (g - 2) * (J - 1) + (J - 2)

    sorted_indices <- order(ord_score, outcome)

    # gofcat's splitter: puts ALL extras in the LAST group
    base_size <- floor(n / g)
    extras <- n %% g
    group_sizes <- rep(base_size, g)

    # Put ALL extras in the last group (not first groups)
    group_sizes[g] <- group_sizes[g] + extras

    # Assign groups to sorted observations
    group_ids <- numeric(n)
    index <- 1
    for (i in 1:g) {
      upper <- index + group_sizes[i] - 1
      group_ids[sorted_indices[index:upper]] <- i
      index <- upper + 1
    }

    # Calculate cutpoints
    cutpoints <- numeric(g - 1)
    for (i in 1:(g-1)) {
      cutpoints[i] <- max(ord_score[group_ids == i])
    }

  } else if (ties == "equal") {

    ord_score <- as.vector(probs %*% 0:(J - 1))
    ord_score <- round(ord_score, 7)
    df_value <- (g - 2) * (J - 1) + (J - 2)

    df_temp <- data.frame(score = ord_score, idx = 1:n)
    df_temp <- df_temp[order(df_temp$score), ]

    # Create groups based on sorted position
    df_temp$group <- as.numeric(cut(1:n, breaks = g, labels = 1:g, include.lowest = TRUE))

    # Put back in original order
    df_temp <- df_temp[order(df_temp$idx), ]
    group_ids <- df_temp$group

    # Calculate cutpoints
    cutpoints <- numeric(g - 1)
    for (i in 1:(g-1)) {
      cutpoints[i] <- max(ord_score[group_ids == i])
    }
  }

  df_work <- data.frame(outcome = outcome, ord_score = ord_score, probs)
  df_work$group <- group_ids

  print("Decile cutpoints of expected ordinal score:")
  print(round(cutpoints, 6))

  print("Ordinal score quantile group sizes:")
  print(table(df_work$group))

  if (test == "hl" || test == "lipsitz") {
    expected <- matrix(0, nrow = g, ncol = J)
    observed <- matrix(0, nrow = g, ncol = J)
    maxscore <- numeric(g)
    totals <- numeric(g)

    for (i in 1:g) {
      idx <- which(df_work$group == i)
      grp_probs <- probs[idx, , drop = FALSE]
      expected[i, ] <- colSums(grp_probs)
      outcome_factor <- factor(df_work$outcome[idx], levels = sort(unique(outcome)))
      observed[i, ] <- tabulate(as.integer(outcome_factor), nbins = J)
      maxscore[i] <- max(df_work$ord_score[idx])
      totals[i] <- length(idx)
    }

    valid <- expected > 0

    if (test == "hl") {
      stat <- sum((observed[valid] - expected[valid])^2 / expected[valid])
      df <- df_value
      method <- "Fagerland-Hosmer Ordinal HL Test"
    } else {
      stat <- 2 * sum(observed[valid] * log(pmax(observed[valid], 1e-10) / expected[valid]))
      df <- g - 1
      method <- "Lipsitz Test"
    }
    p <- pchisq(stat, df, lower.tail = FALSE)


    if (show_table) {
      cat("\nHL Table: Observed and Expected Frequencies by Group\n")
      header_cats <- paste(sapply(1:J, function(j) {
        sprintf("Obs_%s  Est_%s", cat_labels[j], cat_labels[j])
      }), collapse = " | ")
      cat(sprintf("|Group | Ordinal score | %s | Total |\n", header_cats))
      cat(paste(rep("-", 80), collapse = ""), "\n")
      for (i in 1:g) {
        cat_values <- paste(sapply(1:J, function(j) {
          sprintf("%5d  %6.2f", observed[i, j], expected[i, j])
        }), collapse = " | ")
        cat(sprintf("| %4d |     %8.4f | %s | %5d |\n",
                    i, maxscore[i], cat_values, totals[i]))
      }
      cat(paste(rep("-", 80), collapse = ""), "\n")
    }
  }

  if (test == "pr.chi2" || test == "pr.dev") {
    if (is.null(catvars)) stop("catvars must be specified for PR tests")

    cat_patterns <- data %>% select(all_of(catvars)) %>% mutate(rowid = row_number())
    cat_patterns$pattern <- apply(cat_patterns[, catvars], 1, paste, collapse = "_")
    df_work$pattern <- cat_patterns$pattern

    df_work <- df_work %>% group_by(pattern) %>% mutate(score_grp = ifelse(ord_score <= median(ord_score), "L", "H"))
    df_work$cell <- paste0(df_work$pattern, ":", df_work$score_grp)
    cellnames <- unique(df_work$cell)

    expected <- matrix(0, nrow = length(cellnames), ncol = J)
    observed <- matrix(0, nrow = length(cellnames), ncol = J)
    totals <- numeric(length(cellnames))

    for (i in seq_along(cellnames)) {
      cell_i <- cellnames[i]
      idx <- which(df_work$cell == cell_i)
      expected[i, ] <- colSums(probs[idx, , drop = FALSE])
      outcome_factor <- factor(df_work$outcome[idx], levels = levels(df_work$outcome))
      observed[i, ] <- tabulate(as.integer(outcome_factor), nbins = J)
      totals[i] <- length(idx)
    }

    valid <- expected > 0
    if (test == "pr.chi2") {
      stat <- sum((observed[valid] - expected[valid])^2 / expected[valid])
      method <- "Pulkstenis-Robinson Chi-squared Test"
    } else {
      stat <- 2 * sum(observed[valid] * log(pmax(observed[valid], 1e-10) / expected[valid]))
      method <- "Pulkstenis-Robinson Deviance Test"
    }

    I <- n_distinct(df_work$pattern)
    df <- (2 * I - 1) * (J - 1) - length(catvars) - 1
    p <- pchisq(stat, df, lower.tail = FALSE)

    if (show_table) {
      cat("\nPR Table: Observed and Expected Frequencies by Pattern\n")
      for (i in seq_along(cellnames)) {
        obs_str <- paste(sapply(1:J, function(j) sprintf("%3d", observed[i, j])), collapse = " ")
        exp_str <- paste(sapply(1:J, function(j) sprintf("%6.2f", expected[i, j])), collapse = " ")
        cat(sprintf("%s | Obs: %s | Exp: %s | Total: %3d\n",
                    cellnames[i], obs_str, exp_str, totals[i]))
      }
    }
  }

  result <- list(
    statistic = stat,
    parameter = df,
    p.value = p,
    method = method
  )
  class(result) <- "htest"
  return(result)
}

