#' Packages up the object goodness of fit,
#' \code{GoodnessOfFitInternal} puts together the various bits of \code{GoodnessOfFit}. These should usually not
#' be used directly unless by experienced users.
#' @param value The computed goodness-of-fit.
#' @param description Text elements used to construct the print statment.
#' @param call The original call used to create the object for which goodness-of-fit is being computed.
#' @param ... Additional arguments affecting the goodness-of-fit displayed.
#' @return A \code{\link{list}} with components
#' @return value The computed goodness-of-fit.
#' @return description Text elements used to construct the print statment.
#' @return call The original call used to create the object for which goodness-of-fit is being computed.
GoodnessOfFitInternal <- function(value, description, call) {
result <- list(call = call, value = value, description = description)
class(result) <- "flipGOF"
result
}
#' Extracts fitted and observed.
#' \code{FittedAndObserved} extracts vectors of fitted (or predicted) and observed values from an object for use in computing
#' \code{GoodnessOfFit}.
#' @param object An object for which a summary is desired..
#' @return fitted Fitted values from the object.
#' @return observed Observed values from the object.
FittedAndObserved = function(object) {
fitted = fitted(object)
if(is.null(fitted))
fitted = predict(object)
observed = fitted + resid(object)
list(fitted = fitted, observed = observed)
}
print.flipGOF = function(x, digits = max(3L, getOption("digits") - 3L), ...)
{
cat("\nCall:\n", paste(deparse(x$call), sep = "\n", collapse = "\n"),
"\n\n", sep = "")
cat(paste0(c(x$description,"\n", collapse = "")))
invisible(x)
}
#' Object Goodness-of-Fit
#' \code{GoodnessOfFit} summary is a generic function used to produce result summaries of the
#' results of the model object. The function invokes particular \code{\link{methods}}
#' which depend on the \code{\link{class}} of the first argument.
#'
#' reports the goodness-of-fit of an object.
#' @param object An object for which a summary is desired..
#' @param digits Minimal number of significant digits, see \code{\link{print.default}}.
#' @param ... Additional arguments affecting the goodness-of-fit displayed.
#' @examples
#'
#' # linear regression
#' x <- rnorm(10)
#' y <- rnorm(10) + x
#' mod <- lm(y ~ x)
#' GoodnessOfFit(mod)
#'
#' # MDS - square
#' library(smacof)
#' data(breakfastDissimilarities)
#' mdsInterval <- smacofSym(breakfastDissimilarities[[4]],
#' type = "interval", eps = 1e-12, itmax = 100000)
#' GoodnessOfFit(mdsInterval)
#' # MDS - rectangular
#' data(breakfast)
#' GoodnessOfFit(smacofRect(breakfast))
#' @export
GoodnessOfFit <- function(object, digits = max(3L, getOption("digits") - 3L), ...) {
UseMethod("GoodnessOfFit")
}
#' @describeIn GoodnessOfFit Default goodness-of-fit \eqn{R^2}
#' @export
GoodnessOfFit.default = function(object, digits = max(3L, getOption("digits") - 3L), ...) {
obs.fit = FittedAndObserved(object)
r2 = cor(obs.fit$fitted, obs.fit$observed)^2
names(r2) <- "R-squared"
description <- list("Variance explained: ",
formatC(100 * r2, digits = digits),
"%\n(R-squared * 100)")
GoodnessOfFitInternal(r2, description, object$call)
}
#' @describeIn GoodnessOfFit Goodness-of-fit for a smacof object with square data (i.e., dissimilarities/distance)
#' @export
GoodnessOfFit.smacof = function(object, digits = max(3L, getOption("digits") - 3L), ...) {
stress = object$stress
names(stress) = "STRESS1"
description = list("Variance Explained: ",
formatC(100 * (1 - stress), digits = digits),
"%\n(100 - STRESS1 * 100)")
GoodnessOfFitInternal(stress, description, object$call)
}
#' @describeIn GoodnessOfFit Goodness-of-fit for a smacofR object with rectangular data (e.g., preferences)
#' @export
GoodnessOfFit.smacofR = function(object, digits = max(3L, getOption("digits") - 3L), ...) {
stress = object$stress
names(stress) = "STRESS2"
description = list("Variance Explained: ",
formatC(100 - stress * 100, digits = digits),
"%\n(100 - STRESS2 * 100)")
GoodnessOfFitInternal(stress, description, object$call)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.