R/interval.R

Defines functions r.squared rsquared stat.uneval stat.htest stat pval

Documented in pval rsquared r.squared stat stat.htest stat.uneval

#' Extract summary statistics
#' 
#' Extract confidence intervals, test statistics or p-values from an 
#'   `htest` object.
#' @rdname interval
#' @param object a fitted model object or an htest object.
#' @param parm a specification of which parameters are to be given confidence intervals, 
#'   either a vector of numbers or a vector of names. If missing, all parameters are considered.
#' @param level the confidence level required.
#' @param x An object of class `htest`.
#' @param \dots Additional arguments.
#' @return the extracted p-value, confidence interval, or test statistic
#' 
#' @examples
#' confint(t.test(rnorm(100)))
#' pval(t.test(rnorm(100)))
#' stat(t.test(rnorm(100)))
#' confint(var.test(rnorm(10,sd=1), rnorm(20, sd=2)))
#' pval(var.test(rnorm(10,sd=1), rnorm(20, sd=2)))
#' if (require(mosaicData)) {
#' data(HELPrct)
#' stat(t.test (age ~ shuffle(sex), data=HELPrct))
#' # Compare to test statistic computed with permuted values of sex.
#' do(10) * stat(t.test (age ~ shuffle(sex), data=HELPrct))
#' }
#' @keywords stats 
#' @keywords inference 

# remove inverval alias to avoid conflict with lubridate::interval
# interval <- confint

#' @param verbose a logical
#' @export

confint.htest <- function (object, parm, level, ...){
  if (! missing( parm ) || !missing( level ) ) { warning("parm and level are ignored.") }
  int <- object$conf.int
  lev <- attr(int, "conf.level")
  verbose <- list(...)[['verbose']]
  if (is.null(verbose)) verbose <- FALSE
  if ( verbose ) {
	  cat('\nMethod: ')
	  cat(object$method)
	  cat('\nEstimate: ')
	  cat( format(object$estimate, getOption('digits',3)) )
	  cat( paste("\n", lev * 100, "% confidence interval: ", sep = "") )
	  cat( paste(format(as.vector(int), getOption('digits',3)), collapse=" ") )
  }
  interv <- as.vector(int) 
  names(interv) <- c('lower','upper')
  level <- c(level=lev)
  int <- c(object$estimate, interv, level )
  int <- 
    as.data.frame(
      matrix(nrow = 1, c(object$estimate, lower = interv[1], upper = interv[2], level = level)))
  names(int) <- c(names(object$estimate), "lower", "upper", "level")
  if (verbose) 
    invisible(int) 
  else 
    int
}

#' @rdname interval
#' @keywords stats 
#' @keywords inference 
#' @export

pval <- function(x, ...){UseMethod("pval", x)}

#' @rdname interval
#' @param digits number of digits to display in verbose output
#' @export

pval.htest <- function (x, digits=4, verbose=FALSE, ...){
  pval <- x$p.value
  if (!verbose) {
    return( c(p.value=pval) )
  }
  # verbose stuff below
  stat <- x$statistic
  param <- x$parameter
  method <- x$method
  cat('\n')
  cat( paste('Method: ', method, "\n", sep="") )
  
  tryCatch( {
    alt <- x$alternative
    direction <- switch(alt, 
                        'less' = ' < ',
                        'greater' = ' > ',
                        'two.sided' = ' <> ',
                        ' <> '
    )
    null <- x$null.value
    cat('\n\n')
    cat(paste(
      'Null Hypothesis: ', 
      names(null), 
      " = ", 
      null,
      sep="") 
    )  
    cat('\n')
    cat(paste(
      'Alt. Hypothesis: ', 
      names(null), 
      direction, 
      null,
      sep="") 
    )  
    estimate <- x$estimate
    cat('\n\n')
    cat(paste(names(stat), " = ", 
              signif(stat,digits=digits),
              sep="") )  
    cat('  (')
    cat( paste( 
      names(param), " = ", 
      signif(param,digits=digits), 
      sep="",
      collapse=', ') )  
    cat(')\n\n')
  }, error=function(e) {}
  )
  cat( paste("p-value = ", signif(pval,digits), sep="") ) 
  cat('\n\n')
  return(invisible(c(p.value=pval)))
}

#' @rdname interval
#' @keywords stats 
#' @keywords inference 
#' @export

stat <- function(x,...) { UseMethod("stat", x)}

#' @rdname interval
#' @export

stat.htest <- function(x,...) {
	x $ statistic
}

# This is added for compatibility with ggplot2 version 2.3

#' @rdname interval
#' @importFrom utils packageVersion
#' @export
#' 
stat.uneval <- function(x, ...) {
  if (utils::packageVersion("ggplot2") <= "2.2.1") {
    stop("ggplot2 > 2.2.1 required for ggplot2::stat().")
  } else {
	  ggplot2::stat(x, ...)
  }
}


#' Extract r-squared value
#' 
#' Attempts to extract an r-squared value from a model or model-like object.
#' @param x an object
#' @param \dots additional arguments
#' @export

rsquared <- function(x, ...) {
  NULLFUN <- function(e) NULL 
  result <- tryCatch( x$r.squared, error=NULLFUN)
  if (is.null(result)) 
    result <- tryCatch( summary(x, ...)$r.squared, error=NULLFUN )
  return(result)
}

#' @rdname defunct
#' @export

r.squared <- function(...) {
  .Defunct("rsquared")
}

Try the mosaic package in your browser

Any scripts or data that you put into this service are public.

mosaic documentation built on Nov. 10, 2023, 1:11 a.m.