.packageName <- "desirability"
"dMax"    <- function(low, ...) UseMethod("dMax")
"dMin"    <- function(low, ...) UseMethod("dMin")
"dTarget" <- function(low, ...) UseMethod("dTarget")
"dArb"    <- function(x, ...) UseMethod("dArb")
"dBox"    <- function(low, ...) UseMethod("dBox")
"dOverall"    <- function(...) UseMethod("dOverall")



dMax.default <- function(low, high, scale = 1, tol = NULL, ...)
{
   if(low >= high) stop("the low value must be greater than the high value")
   if(scale <= 0) stop("the scale parameter must be greater than zero")
      
   tmp <- list(low = low, high = high, scale = scale, missing = NA, ...)
   testSeq <- seq(tmp$low, tmp$high, length = 100)
   nonInformValue <- mean(predict.dMax(tmp, testSeq))

   structure(
      list(low = low, high = high, scale = scale, missing = nonInformValue, tol = tol, call = match.call(expand.dots = TRUE)),
      class = "dMax")      
}

dMin.default <- function(low, high, scale = 1, tol = NULL, ...)
{
   if(low >= high) stop("the low value must be greater than the high value")
   if(scale <= 0) stop("the scale parameter must be greater than zero")

   tmp <- list(low = low, high = high, scale = scale, missing = NA)
   testSeq <- seq(tmp$low, tmp$high, length = 100)
   nonInformValue <- mean(predict.dMin(tmp, testSeq))
   
   structure(
      list(low = low, high = high, scale = scale, missing = nonInformValue, tol = tol, call = match.call(expand.dots = TRUE)),
      class = "dMin")      
   
}

dTarget.default <- function(low, target, high, lowScale = 1, highScale = 1, tol = NULL, ...)
{
   if(low >= high) stop("the low value must be greater than the high value")
   if(low >= target) stop("the low value must be greater than the target")
   if(target >= high) stop("the target value must be greater than the high value")
   if(lowScale <= 0 | highScale <= 0) stop("the scale parameter must be greater than zero")

   tmp <- list(low = low, target = target, high = high, lowScale = lowScale, highScale = highScale, missing = NA)
   testSeq <- seq(tmp$low, tmp$high, length = 100)
   nonInformValue <- mean(predict.dTarget(tmp, testSeq))

   structure(
      list(low = low, target = target, high = high, lowScale = lowScale, highScale = highScale, missing = nonInformValue, tol = tol, call = match.call(expand.dots = TRUE)),
      class = "dTarget")   
}

dArb.default <- function(x, d, tol = NULL, ...)
{
   if(any(d > 1)| any(d < 0)) stop("the desirability values must be 0 <= d <= 1")
   if(length(x) != length(d)) stop("x and d must have the same length")
   if(length(x) < 2 | length(d) < 2) stop("x and d must have at least two values")
   
   ord <- order(x)
   x <- x[ord]
   d <- d[ord]
   
   tmp <- list(x = x, d = d, missing = NA)
   testSeq <- seq(min(x), max(x), length = 100)
   nonInformValue <- mean(predict.dArb(tmp, testSeq), na.rm = TRUE)

   structure(
      list(x = x, d = d, missing = nonInformValue, tol = tol, call = match.call(expand.dots = TRUE)),
      class = "dArb")   
   
}

dBox.default <- function(low, high, tol = NULL, ...)
{
   if(low >= high) stop("the low value must be greater than the high value")
      
   tmp <- list(low = low, high = high, missing = NA)
   testSeq <- seq(tmp$low, tmp$high, length = 100)
   nonInformValue <- mean(predict.dBox(tmp, testSeq))

   structure(
      list(low = low, high = high, missing = nonInformValue, tol = tol, call = match.call(expand.dots = TRUE)),
      class = "dBox")      
}

dOverall.default <- function(...)
{
   dObjs <- list(...)
   dClasses <- unlist(lapply(dObjs, class))
   if(!all(dClasses %in% c("dMax", "dMin", "dTarget", "dArb", "dBox")))
      stop("some classes do not have classes in dMax, dMin, dTarget, dArb or dBox")
   structure(
      list(d = dObjs, call = match.call(expand.dots = TRUE)),
      class = "dOverall")   
}
plot.dMax <- function(x, add = FALSE, nonInform = TRUE, ...)
{
   xRange <- extendrange(c(x$low, x$high))
   if(!add) plot(xRange, c(0, 1), type = "n", xlab = "Input", ylab = "Desirability")
   segments(min(xRange), 0, x$low, 0, ...)
   segments(x$high, 1, max(xRange), 1, ...)
   input <- seq(from = x$low, to = x$high, length = 100)
   output <- predict.dMax(x, input)
   points(input, output, type = "l", ...)
   
   if(nonInform) abline(h = x$missing, lty = 2, ...)
   invisible(x)
}



plot.dBox <- function(x, add = FALSE, nonInform = TRUE, ...)
{
   xRange <- extendrange(c(x$low, x$high))
   if(!add) plot(xRange, c(0, 1), type = "n", xlab = "Input", ylab = "Desirability")
   segments(min(xRange), 0, x$low, 0, ...)
   segments(max(xRange), 0, x$high, 0, ...)   
   segments(x$low, 1, x$low, 0, ...)
   segments(x$high, 1,x$high, 0, ...)
   segments(x$low, 1, x$high, 1, ...)
   
   if(nonInform) abline(h = x$missing, lty = 2, ...)
   invisible(x)
}


plot.dMin <- function(x, add = FALSE, nonInform = TRUE, ...)
{
   xRange <- extendrange(c(x$low, x$high))
   if(!add) plot(xRange, c(0, 1), type = "n", xlab = "Input", ylab = "Desirability")
   segments(min(xRange), 1, x$low, 1, ...)
   segments(x$high, 0, max(xRange), 0, ...)
   input <- seq(from = x$low, to = x$high, length = 100)
   output <- predict.dMin(x, input)
   points(input, output, type = "l", ...)
   if(nonInform) abline(h = x$missing, lty = 2, ...)
   invisible(x)   
}



plot.dTarget <- function(x, add = FALSE, nonInform = TRUE, ...)
{
   xRange <- extendrange(c(x$low, x$high))
   if(!add) plot(xRange, c(0, 1), type = "n", xlab = "Input", ylab = "Desirability")
   segments(min(xRange), 0, x$low, 0, ...)
   segments(x$high, 0, max(xRange), 0, ...)
   input <- seq(from = x$low, to = x$high, length = 100)
   output <- predict.dTarget(x, input)
   points(input, output, type = "l", ...)
   if(nonInform) abline(h = x$missing, lty = 2, ...)
   invisible(x)   
}


plot.dArb <- function(x, add = FALSE, nonInform = TRUE, ...)
{
   xRange <- extendrange(x$x)
   if(!add) plot(xRange, c(0, 1), type = "n", xlab = "Input", ylab = "Desirability")
   input <- seq(from = xRange[1], to = xRange[2], length = 100)
   output <- predict(x, input)
   points(input, output, type = "l", ...)
   if(nonInform) abline(h = x$missing, lty = 2, ...)
   invisible(x)   
   
}


predict.dBox <- function(object, newdata = NA, ...)
{
   out <- vector(length = length(newdata), mode = "numeric") * NA 
   out[newdata < object$low | newdata > object$low] <- 0
   out[newdata >= object$low & newdata <= object$low] <- 1
   out[is.na(out)] <- object$missing
   if(!is.null(object$tol)) out[out == 0] <- object$tol
   out
}

predict.dMax <- function(object, newdata = NA, ...)
{
   out <- vector(length = length(newdata), mode = "numeric") * NA 
   out[newdata < object$low] <- 0
   out[newdata > object$high] <- 1
   out[newdata <= object$high & newdata >= object$low] <- (
      (newdata[newdata <= object$high & newdata >= object$low] - object$low)/
      (object$high - object$low))^object$scale 
   out[is.na(out)] <- object$missing      
   out
}

predict.dMin <- function(object, newdata = NA, ...)
{
   out <- vector(length = length(newdata), mode = "numeric") * NA
   out[newdata < object$low] <- 1
   out[newdata > object$high] <- 0
   out[newdata <= object$high & newdata >= object$low] <- (
      (newdata[newdata <= object$high & newdata >= object$low] - object$high)/
      (object$low - object$high))^object$scale 
   out[is.na(out)] <- object$missing      
   out
}


predict.dTarget <- function(object, newdata = NA, ...)
{
   out <- vector(length = length(newdata), mode = "numeric")  * NA
   out[newdata < object$low | newdata > object$high] <- 0
   out[newdata <= object$target & newdata >= object$low] <- (
      (newdata[newdata <= object$target & newdata >= object$low] - object$low)/
      (object$target - object$low))^object$lowScale 
   out[newdata <= object$high & newdata >= object$target] <- (
      (newdata[newdata <= object$high & newdata >= object$target] - object$high)/
      (object$target - object$high))^object$highScale       
   out[is.na(out)] <- object$missing
      
   out
}

predict.dArb <- function(object, newdata = NA, ...)
{
   out <- vector(length = length(newdata), mode = "numeric")  * NA
   out[newdata < min(object$x)] <- object$d[1]
   out[newdata > max(object$x)] <- object$d[length(object$d)]
   

   inBtwn <- newdata >= min(object$x) & newdata <= max(object$x)
   if(any(inBtwn))
   {
      tmp <- matrix(newdata[inBtwn], ncol = 1)
      approxD <- apply(
         tmp, 
         1, 
         function(u, x, y) approx(x, y, u)$y, 
         x = object$x,
         y = object$d)
      out[inBtwn] <- approxD
      
   }
   out[is.na(out)] <- object$missing
   
   out
}

predict.dOverall <- function(object, newdata = matrix(NA, ncol = length(object$d)), all = FALSE, ...)
{
   numD <- length(object$d)
   if(is.vector(newdata)) newdata <- matrix(newdata, ncol = length(newdata))
   if(is.matrix(newdata)) newdata <- as.matrix(newdata)
   if(numD != ncol(newdata)) stop("the number of columns in newdata must match the number of desirability functions")
   
   indD <- newdata * NA
   for(i in 1:numD)
   {
      indD[,i] <- predict(object$d[[i]], newdata[,i])
   }
   overall <- apply(indD, 1, prod)^(1/numD)
   if(all)
   {
      out <- cbind(indD, overall)
      names(out)[numD + 1] <- "Overall"
   
   } else out <- overall
   
   out
}

print.dBox <- function(x, digits = max(3, getOption("digits") - 3), printCall = TRUE, ...)
{
   cat("Box-like desirability function\n")
   cat("\nCall: ", deparse(x$call), "\n\n", sep = "")
   
   cat("Non-informative value:", round(x$missing, digits), "\n")
   if(!is.null(x$tol)) cat("tolerance:", round(x$tol, digits), "\n")

   invisible(x)
}

print.dMax <- function(x, digits = max(3, getOption("digits") - 3), printCall = TRUE, ...)
{
   cat("Larger-is-better desirability function\n")
   cat("\nCall: ", deparse(x$call), "\n\n", sep = "")
   
   cat("Non-informative value:", round(x$missing, digits), "\n")
   if(!is.null(x$tol)) cat("tolerance:", round(x$tol, digits), "\n")

   invisible(x)
}

print.dMin <- function(x, digits = max(3, getOption("digits") - 3), printCall = TRUE, ...)
{
   cat("Smaller-is-better desirability function\n")
   cat("\nCall: ", deparse(x$call), "\n\n", sep = "")
   
   cat("Non-informative value:", round(x$missing, digits), "\n")
   if(!is.null(x$tol)) cat("tolerance:", round(x$tol, digits), "\n")
   
   invisible(x)
}

print.dTarget <- function(x, digits = max(3, getOption("digits") - 3), printCall = TRUE, ...)
{
   cat("Target-is-best desirability function\n")
   cat("\nCall: ", deparse(x$call), "\n\n", sep = "")
   
   cat("Non-informative value:", round(x$missing, digits), "\n")

   if(!is.null(x$tol)) cat("tolerance:", round(x$tol, digits), "\n")
   invisible(x)
}

print.dArb <- function(x, digits = max(3, getOption("digits") - 3), printCall = TRUE, ...)
{
   cat("Arbitrary desirability function\n")
   cat("\nCall: ", deparse(x$call), "\n\n", sep = "")
   
   cat("Non-informative value:", round(x$missing, digits), "\n")
   if(!is.null(x$tol)) cat("tolerance:", round(x$tol, digits), "\n")

   invisible(x)
}

print.dOverall <- function(x, digits = max(3, getOption("digits") - 3), printCall = TRUE, ...)
{
   cat("Combined desirability function\n")
   cat("\nCall: ", deparse(x$call), "\n\n", sep = "")

   for(i in seq(along = x$d))
   {
      cat("----\n")
      print(x$d[[i]], printCall = FALSE)
   }     
   invisible(x)
}
