#' Four-parameter logistic (4PL) dose-response function
#'
#' Evaluates the classic four-parameter logistic model used to describe
#' drug dose-response curves in high-throughput screens.
#'
#' The model is
#' \deqn{f(x) = \mathrm{bottom} +
#'   \frac{\mathrm{top} - \mathrm{bottom}}{1 + (x / \mathrm{ic50})^{\mathrm{hill}}}}
#'
#' @param x Numeric vector of drug concentrations (on the same scale used to fit
#'   the model, typically the raw concentration).
#' @param top Response of the upper asymptote (e.g. viability with no drug).
#' @param ic50 Concentration producing the half-maximal response.
#' @param hill Hill slope controlling the steepness of the curve.
#' @param bottom Response of the lower asymptote (e.g. viability at saturating
#'   drug).
#'
#' @return A numeric vector of predicted responses, the same length as `x`.
#'
#' @examples
#' four_pl(x = c(0.01, 0.1, 1, 10), top = 1, ic50 = 1, hill = 1, bottom = 0)
#'
#' @seealso [compute_auc()], [fit_dose_response()]
#' @export
four_pl <- function(x, top, ic50, hill, bottom) {
  if (!is.numeric(x)) {
    stop("`x` must be numeric.", call. = FALSE)
  }
  bottom + (top - bottom) / (1 + (x / ic50)^hill)
}

#' Area under a four-parameter logistic dose-response curve
#'
#' Integrates a fitted [four_pl()] curve between two concentrations to obtain
#' the area under the curve (AUC), a robust summary of drug potency used for
#' between-condition comparisons.
#'
#' @param min_concentration Lower integration limit (minimum tested
#'   concentration).
#' @param max_concentration Upper integration limit (maximum tested
#'   concentration).
#' @param top,ic50,hill,bottom Four-parameter logistic parameters, as in
#'   [four_pl()].
#'
#' @return A single numeric value: the integrated area under the curve. When
#'   integration fails (for example a degenerate fit) `NA_real_` is returned
#'   with a warning.
#'
#' @examples
#' compute_auc(
#'   min_concentration = 0.01, max_concentration = 10,
#'   top = 1, ic50 = 1, hill = 1, bottom = 0
#' )
#'
#' @seealso [four_pl()], [fit_dose_response()]
#' @export
compute_auc <- function(min_concentration, max_concentration,
                        top, ic50, hill, bottom) {
  if (min_concentration >= max_concentration) {
    stop("`min_concentration` must be smaller than `max_concentration`.",
      call. = FALSE
    )
  }
  out <- tryCatch(
    stats::integrate(
      four_pl,
      lower = min_concentration, upper = max_concentration,
      top = top, ic50 = ic50, hill = hill, bottom = bottom
    )$value,
    error = function(e) {
      warning("AUC integration failed: ", conditionMessage(e), call. = FALSE)
      NA_real_
    }
  )
  out
}

#' Fit a four-parameter logistic dose-response model
#'
#' Fits a 4PL curve for a single drug under one condition by non-linear least
#' squares, entirely in base R (no external fitting package required). Robust
#' starting values are derived from the data and refined with a bounded
#' `L-BFGS-B` optimisation over several initial `IC50` guesses, falling back to
#' a derivative-free `Nelder-Mead` search if needed. The model uses the same
#' parameterisation as [four_pl()], which matches the `dr4pl` package
#' convention (`UpperLimit`, `IC50`, `Slope`, `LowerLimit`).
#'
#' @param data A data frame containing at least the response and concentration
#'   columns for one drug and one condition.
#' @param response Name of the (normalised) response column, as a string.
#' @param concentration Name of the concentration column, as a string.
#' @param bounds Optional named list overriding the box constraints used by the
#'   bounded optimiser. Recognised names are `top`, `bottom`, `ic50` and `hill`,
#'   each a numeric length-two vector `c(lower, upper)`.
#'
#' @return An object of class `dsr_4pl`: a list with elements `coefficients`
#'   (named numeric vector `top`, `ic50`, `hill`, `bottom`), `fitted`,
#'   `residuals`, `convergence` (logical), `sse`, `data` and `call`. The
#'   companion methods `coef()`, `predict()`, `fitted()`, `residuals()` and
#'   `print()` are provided for this class.
#'
#' @details The fitted parameters can be passed directly to [compute_auc()] to
#'   obtain a potency summary, for example
#'   `do.call(compute_auc, c(list(min(x), max(x)), as.list(coef(fit))))`.
#'
#' @examples
#' one <- subset(
#'   screen_doseresponse,
#'   drug_name == "DrugA" & condition == "Gy0" & experiment_type == "sample"
#' )
#' fit <- fit_dose_response(one, "normalized_cell_count", "concentration")
#' coef(fit)
#' compute_auc(
#'   min(one$concentration), max(one$concentration),
#'   top = coef(fit)[["top"]], ic50 = coef(fit)[["ic50"]],
#'   hill = coef(fit)[["hill"]], bottom = coef(fit)[["bottom"]]
#' )
#'
#' @seealso [four_pl()], [compute_auc()]
#' @export
fit_dose_response <- function(data, response, concentration, bounds = NULL) {
  for (col in c(response, concentration)) {
    if (!col %in% names(data)) {
      stop("Column '", col, "' not found in `data`.", call. = FALSE)
    }
  }

  y <- .as_numeric(data[[response]])
  x <- .as_numeric(data[[concentration]])
  keep <- is.finite(x) & is.finite(y)
  x <- x[keep]
  y <- y[keep]

  if (length(x) < 4) {
    stop("At least 4 finite observations are required to fit a 4PL model.",
      call. = FALSE
    )
  }

  fit <- .fit_4pl(x, y, bounds = bounds)
  fit$call <- match.call()
  fit$data <- data.frame(concentration = x, response = y)
  fit
}

# Internal: coerce a column to numeric safely. Crucially, factors are converted
# via their *labels* (as.character) rather than their integer codes, so that a
# concentration column stored as a factor such as factor(c("0.01", "0.1", "1"))
# yields the real doses 0.01, 0.1, 1 and not the level codes 1, 2, 3.
.as_numeric <- function(v) {
  if (is.numeric(v)) {
    return(v)
  }
  if (is.factor(v)) {
    v <- as.character(v)
  }
  suppressWarnings(as.numeric(v))
}

# Internal: non-linear least-squares fit of the 4PL model in base R.
# The IC50 is optimised on the log10 scale, which conditions the problem well
# when concentrations span several orders of magnitude.
.fit_4pl <- function(x, y, bounds = NULL) {
  x_pos <- x[x > 0]
  rng_y <- range(y, na.rm = TRUE)
  span <- diff(rng_y)
  mid <- mean(rng_y)
  lx <- log10(x_pos)

  # Default box constraints, generous but keeping the curve well posed.
  default_bounds <- list(
    top = c(mid, rng_y[2] + 0.5 * span + 1e-3),
    bottom = c(rng_y[1] - 0.5 * span - 1e-3, mid),
    ic50 = c(10^(min(lx) - 1), 10^(max(lx) + 1)),
    hill = c(0.05, 25)
  )
  if (!is.null(bounds)) {
    default_bounds[names(bounds)] <- bounds
  }
  b <- default_bounds
  # Optimise over (top, log10_ic50, hill, bottom).
  lower <- c(b$top[1], log10(b$ic50[1]), b$hill[1], b$bottom[1])
  upper <- c(b$top[2], log10(b$ic50[2]), b$hill[2], b$bottom[2])

  sse <- function(p) {
    pred <- four_pl(x, top = p[1], ic50 = 10^p[2], hill = p[3], bottom = p[4])
    val <- sum((y - pred)^2)
    if (!is.finite(val)) 1e12 else val
  }

  # Multi-start over IC50 (log scale) spanning the tested concentration range.
  top0 <- rng_y[2]
  bottom0 <- rng_y[1]
  le_grid <- unique(as.numeric(stats::quantile(lx, c(0.25, 0.5, 0.75))))

  best <- NULL
  for (le0 in le_grid) {
    start <- c(top0, le0, 1, bottom0)
    start <- pmin(pmax(start, lower), upper)
    res <- tryCatch(
      stats::optim(start, sse,
        method = "L-BFGS-B",
        lower = lower, upper = upper
      ),
      error = function(e) NULL
    )
    if (!is.null(res) && (is.null(best) || res$value < best$value)) {
      best <- res
    }
  }

  # Fall back to a derivative-free search if the bounded optimiser failed.
  if (is.null(best)) {
    best <- stats::optim(c(top0, stats::median(lx), 1, bottom0), sse,
      method = "Nelder-Mead"
    )
  }

  par <- c(best$par[1], 10^best$par[2], best$par[3], best$par[4])
  names(par) <- c("top", "ic50", "hill", "bottom")
  fitted <- four_pl(x, top = par[1], ic50 = par[2], hill = par[3], bottom = par[4])

  structure(
    list(
      coefficients = par,
      fitted = as.numeric(fitted),
      residuals = as.numeric(y - fitted),
      convergence = isTRUE(best$convergence == 0),
      sse = best$value
    ),
    class = "dsr_4pl"
  )
}

#' @describeIn fit_dose_response Extract the fitted 4PL coefficients (`top`,
#'   `ic50`, `hill`, `bottom`).
#' @param object A `dsr_4pl` object.
#' @param ... Ignored, for S3 method consistency.
#' @export
coef.dsr_4pl <- function(object, ...) {
  object$coefficients
}

#' @describeIn fit_dose_response Predict responses from a fitted model.
#' @param newdata Optional numeric vector of concentrations at which to predict.
#'   Defaults to the concentrations used for fitting.
#' @export
predict.dsr_4pl <- function(object, newdata = NULL, ...) {
  x <- if (is.null(newdata)) object$data$concentration else newdata
  p <- object$coefficients
  four_pl(x, top = p[["top"]], ic50 = p[["ic50"]], hill = p[["hill"]],
    bottom = p[["bottom"]]
  )
}

#' @describeIn fit_dose_response Extract fitted values.
#' @export
fitted.dsr_4pl <- function(object, ...) {
  object$fitted
}

#' @describeIn fit_dose_response Extract residuals.
#' @export
residuals.dsr_4pl <- function(object, ...) {
  object$residuals
}

#' @describeIn fit_dose_response Print a short summary of the fitted model.
#' @param x A `dsr_4pl` object.
#' @export
print.dsr_4pl <- function(x, ...) {
  cat("Four-parameter logistic fit (diffHTS)\n")
  cat("  top   =", format(x$coefficients[["top"]], digits = 4), "\n")
  cat("  ic50  =", format(x$coefficients[["ic50"]], digits = 4), "\n")
  cat("  hill  =", format(x$coefficients[["hill"]], digits = 4), "\n")
  cat("  bottom=", format(x$coefficients[["bottom"]], digits = 4), "\n")
  cat("  SSE   =", format(x$sse, digits = 4),
    if (x$convergence) "(converged)" else "(not converged)", "\n"
  )
  invisible(x)
}
