R/plotfunctions.R

In Rsampling: Ports the Workflow of "Resampling Stats" Add-in to R

#' Spaghetti plot
#'
#' Quick plot of paired differences, for exploratory purposes.
#' @param p1,p2 vectors of paired values (numerical vectors)
#' @param highlight should positive and negative differences within pairs highlighted with different colors? Logical
#' @param col.dif color vector if \code{highlight = TRUE}
#' @param groups.names labels for the groups names; numeric or character vector of length two.
#' @param ... further arguments to be passed to \code{plot} function.
#'
#' @export
#' @import graphics
#' @import stats
splot <- function(p1, p2, highlight = TRUE, col.dif = c("black","grey"), groups.names=c(1,2), ...){
  dots <- list(...)
  if(!"pch"%in%names(dots)) dots$pch=19
  if(!"xlim"%in%names(dots)) dots$xlim=c(0.8,2.2)
  grupo <- rep(groups.names,each=length(p1))
  if(highlight){
    diferencas <- p1-p2
    do.call(stripchart, c(list(x=as.formula("c(p1[diferencas>0],p2[diferencas>0])~rep(groups.names,each=length(p1[diferencas>0]))"),
                               vertical =TRUE,col=col.dif[1], ylim=range(c(p1,p2))),dots))
    do.call(stripchart, list(x=as.formula("c(p1[diferencas<=0],p2[diferencas<=0])~rep(groups.names,each=length(p1[diferencas<=0]))"),
                               vertical =TRUE,col=col.dif[2], pch=dots$pch, add=TRUE))
    segments(x0=1,y0=p1[diferencas>0],x1=2,y1=p2[diferencas>0],col=col.dif[1])
    segments(x0=1,y0=p1[diferencas<=0],x1=2,y1=p2[diferencas<=0], col=col.dif[2])
  }
  else{
    do.call(stripchart, c(list(x=as.formula("c(p1,p2)~grupo"), vertical =TRUE),dots))
    segments(x0=1,y0=p1,x1=2,y1=p2)
  }
}

#' Statistic distribution plot
#'
#' Plots the distribution of the statistic of interest. Has switches to 
#' plot the extreme values and
#' null hypothesis rejection region (also known as critical region).
#' @param dist the statistic distribution, as generated by 
#' \code{\link{Rsampling}} (numeric vector)
#' @param svalue the result of applying the statistic over the original data
#' @param pside the alternative hypothesis for the hypothesis testing
#' @param extreme logical. should extreme points be highlighted in the plot?
#' @param vline logical. should the svalue be displayed as a vertical line?
#' @param rejection logical. should the critical region be highlighted?
#' @param ... further arguments to be passed to \code{hist} function.
#' @seealso See the package vignettes for more information about how to interpret this graph
#' @export
#' @import graphics
#' @import grDevices
dplot <- function(dist, svalue, pside=c("Two sided", "Greater", "Lesser"),
                  extreme = TRUE, vline = TRUE, rejection = TRUE, ...) {
  # argument handling and default values
  pside <- match.arg(pside)
  dots <- list(...)
  if(!"col" %in% names(dots)) dots$col = "skyblue"
  if(!"border" %in% names(dots)) dots$border = "white"
  # what should be the xlim?
  maxx <- max(abs(dist))
  if(abs(svalue) > maxx) maxx = abs(svalue); 
  if(!"xlim" %in% names(dots)) dots$xlim = 1.1*c(-maxx, maxx)
  if(!"main" %in% names(dots)) dots$main = "Distribution of the statistic of interest"
  if(!"xlab" %in% names(dots)) dots$xlab= "Statistic of interest"
  # draws the histogram
  oh <- do.call(hist, c(list(dist), dots))
  # adds the extreme values in orange. the definition of "extreme" depends on whether the test is
  # one sided or two sided
  extremes <- switch(pside,
                 "Two sided" = dist[abs(dist) >= abs(svalue)],
                 "Greater" = dist[dist >= svalue],
                 "Lesser" = dist[dist <= svalue]
                 )
  if(extreme && length(extremes)>0) 
    hist(extremes, xlim=dots$xlim, col="orange1", border = dots$border, 
         add=TRUE, breaks = oh$breaks)
  # vertical svalue with the original statistic
  if(vline) abline(v = svalue, lty=2, col="red")
  # Vertical svalues for rejection region
  dist.q <- quantile(dist, c(0.025, 0.975, 0.95, 0.05))
  rrejection <- switch(pside,
                      "Two sided" = dist.q[1:2],
                      "Greater" = c(dots$xlim[1], dist.q[3]),
                      "Lesser" = c(dist.q[4], dots$xlim[2])
                      )
  if(rejection)
    rect(xleft=rrejection[1], xright=rrejection[2], ybottom = 0, ytop=max(oh$counts),
      col=gray.colors(1,alpha=.3), lwd=0)
}