R/VIMethod1_JG.R

Defines functions VI.tsplot VI.matrix VI.lm VI.list VI.histogram VI.dotplot VI.data.frame VI.boxplot VI.default print.VI VI .getGraphName

Documented in print.VI VI VI.boxplot VI.data.frame VI.default VI.dotplot VI.histogram VI.list VI.lm VI.matrix VI.tsplot

### Internal functions for base R plots

.getGraphName = function(graph, titlePreamble = "With the title:", noTitleMessage="With no title") {
  if (length(graph$main) > 0) {
    if (nchar(gsub(" ", "",graph$main, fixed=T)) != 0) {
      paste(titlePreamble,graph$main)
    } else {
      noTitleMessage
    }
    
  } else if (nchar(graph$ExtraArgs$main) > 0) {
    paste(titlePreamble,graph$ExtraArgs$main)
  } else {
    noTitleMessage
  }
}


###VI methods

VI = function(x, Describe=FALSE, ...) {
       UseMethod("VI")
     }

print.VI = function(x, ...){
cat(x, sep="\n")
return(invisible(x))
}


VI.default =
    function(x, Describe=FALSE, ...) {
      .NoVIMethod()
      print(x)
    }



VI.boxplot =
    function(x, Describe=FALSE, ...) {
x=Augment(x)
      cat(paste0(
              'This graph has ', x$Boxplots, ' printed ', x$VertHorz,
              '\n', .getGraphName(x), '\n',
              .ifelse(length(x$ExtraArgs$xlab) > 0, InQuotes(x$ExtraArgs$xlab), 'No label'),
              ' appears on the x-axis.\n',
              .ifelse(length(x$ExtraArgs$ylab) > 0, paste0('"', x$ExtraArgs$ylab, '"'), 'No label'),
              ' appears on the y-axis.\n'))
      if (x$horizontal) {
        cat("Tick marks for the x-axis are at:", .GetAxisTicks(x$par$xaxp), "\n")
      } else {
        cat("Tick marks for the y-axis are at:", .GetAxisTicks(x$par$yaxp), "\n")
      }
      for (i in 1:x$NBox) {
        cat(x$VarGroupUpp, x$names[i], 'has', x$n[i], 'values.\n')
        if (any(x$group == i)) {
          cat('An outlier is marked at:', x$out[which(x$group == i)], '\n')
        } else {
          cat('There are no outliers marked for this', x$VarGroup, '\n')
        }
        cat('The whiskers extend to', x$stats[1, i], 'and', x$stats[5, i],
            'from the ends of the box, \nwhich are at', x$stats[2, i], 'and',
            x$stats[4, i], '\n')
        BoxLength = x$stats[4, i] - x$stats[2, i]
        cat('The median,', x$stats[3, i], 'is',
            round(100 * (x$stats[3, i] - x$stats[2, i]) / BoxLength, 0),
            '% from the', .ifelse(x$horizontal, 'left', 'lower'),
            'end of the box to the', .ifelse(x$horizontal, 'right', 'upper'),
            'end.\n')
        cat('The', .ifelse(x$horizontal, 'right', 'upper'), 'whisker is',
            round((x$stats[5, i] -
                   x$stats[4, i]) / (x$stats[2, i] - x$stats[1, i]), 2),
            'times the length of the', .ifelse(x$horizontal, 'left', 'lower'),
            'whisker.\n')
      }
      cat('\n')
    }

VI.data.frame =
    function(x, Describe=FALSE, ...) {
      ThisDF = x
      cat("\nThe summary of each variable is\n")
      with(ThisDF, {
                     for (i in names(ThisDF)) {
                       cat(paste(i, ": ", sep = ""))
                       Wanted = summary(get(i))
                       cat(paste(names(Wanted), Wanted, " "))
                       cat("\n")
                     }
                   })  # closure of the with command
      cat("\n")
    }

VI.dotplot =
    function(x, Describe=FALSE, ...) {
      MinVal = min(unlist(x$vals))
      MaxVal = max(unlist(x$vals))
      Bins = getOption("BrailleR.DotplotBins")
      Cuts = seq(MinVal, MaxVal, (MaxVal - MinVal) / Bins)
      # now do the description bit
      cat(paste0('This graph has ', x$dotplots, ' printed ', x$VertHorz, '\n',
                 .getGraphName(x), '\n'))
      if (!is.null(x$ExtraArgs$dlab) | !is.null(x$ExtraArgs$glab)) {
        .OldCodeWarning(Old="dlab or glab arguments", New = "xlab and ylab ")
      } else {
        cat(paste0(ifelse(length(x$ExtraArgs$xlab) > 0, InQuotes(x$ExtraArgs$xlab), 'No label'),
                   ' appears on the x-axis.\n',
                   .ifelse(length(x$ExtraArgs$ylab) > 0, paste0('"', x$ExtraArgs$ylab, '"'),
                          'No label'), ' appears on the y-axis.\n'))
      }
      if (x$vertical) {
        cat("Tick marks for the y-axis are at:", .GetAxisTicks(x$par$yaxp), "\n")
      } else {
        cat("Tick marks for the x-axis are at:", .GetAxisTicks(x$par$xaxp), "\n")
      }
      cat(paste("the data that range from", MinVal, "to", MaxVal,
                "has been broken into", Bins, "bins.\nThe counts are:\n"))
      for (i in 1:x$NPlot) {
        cat(paste0(names(x$vals)[i], ": "))
        cat(graphics::hist(x$vals[[i]], breaks = Cuts, plot = FALSE)$counts,
            "\n")
      }
      return(invisible(NULL))
    }


VI.histogram =
    function(x, Describe=FALSE, ...) {
      cat(paste0('This is a histogram, with the title: ',
                 .getGraphName(x, titlePreamble = "with the title:", noTitleMessage = "with no title"),
          '\n', .ifelse(length(x$ExtraArgs$xlab) > 0, InQuotes(x$ExtraArgs$xlab), InQuotes(x$xname)),
          ' is marked on the x-axis.\n'))
      cat("Tick marks for the x-axis are at:", .GetAxisTicks(x$par$xaxp), "\n")
      cat('There are a total of', sum(x$counts),
          'elements for this variable.\n')
      cat("Tick marks for the y-axis are at:", .GetAxisTicks(x$par$yaxp), "\n")
      NoBins = length(x$breaks) - 1
      if (x$equidist) {
        cat('It has', NoBins, 'bins with equal widths, starting at',
            x$breaks[1], 'and ending at', x$breaks[NoBins + 1], '.\n')
        cat('The mids and counts for the bins are:')
        cat(paste0("\nmid = ", x$mids, "  count = ", x$counts))
      } else {
        cat('The', NoBins, 'bins have unequal bin sizes.\n')
        cat('The intervals and densities for the bins are:')
        cat(paste("\nFor the bin from ", x$breaks[1:NoBins], " to ",
                  x$breaks[-1], "the density is ", x$density, sep = ""))
      }
      cat("\n")
    }


VI.htest = function (x, Describe=FALSE, digits = getOption("digits"),  ...) 
{
    cat("\n")
    cat(strwrap(x$method ), sep = "\n")
    if (!is.null(x$statistic)) 
cat(paste("\n", names(x$statistic), "=", format(x$statistic, 
            digits = max(1L, digits - 2L))))
    if (!is.null(x$parameter)) 
cat(paste("\n", names(x$parameter), "=", format(x$parameter, 
            digits = max(1L, digits - 2L))))
    if (!is.null(x$p.value)) {
        fp <- format.pval(x$p.value, digits = max(1L, digits - 
            3L))
cat(paste("\n", "p-value", if (substr(fp, 1L, 1L) == 
            "<") fp else paste("=", fp)))
    }


    if (!is.null(x$conf.int)) {
cat("\n\n")
        cat(format(100 * attr(x$conf.int, "conf.level")), " percent confidence interval:\n", 
            " ", paste(format(x$conf.int[1:2], digits = digits), 
                collapse = " "), sep = "")
    }
    cat("\n\n")
    invisible(x)
}



VI.list =
    function(x, Describe=FALSE, ...) {
      cat("No VI method has yet been written for this type of object so it has been printed for you in its entirety.\n")
      print(x)
    }


VI.lm =
    function(x, Describe=FALSE, ...) {
      ModelName <- match.call(expand.dots = FALSE)$x
      FolderName = paste0(ModelName, ".Validity")
      RmdName = paste0(FolderName, ".Rmd")
      TitleName =
          paste0(
              'Checking validity for the model "', ModelName,
              '" by way of standardised residuals, leverages, and Cook\'s distances
```{r GetVars, echo=FALSE}
Residuals=rstudent(',
              ModelName, ')
Fits= fitted(', ModelName,
              ')
Leverages= hatvalues(', ModelName, ')
Cooks= cooks.distance(',
              ModelName, ')
```   ')

      Residuals = rstudent(x)

      UniDesc(
          Residuals, Title = TitleName, Filename = RmdName, Folder = FolderName,
          Process = FALSE, VI = TRUE, Latex = FALSE, View = FALSE)

      cat(paste0(
              '## Regression diagnostic plots
### Standardised residuals

```{r Fits, fig.cap="Standardised residuals plotted against fitted values"}
plot(Fits, Residuals)
WhereXY(Fits, Residuals, yDist="normal")
```

```{r Order, fig.cap="Standardised residuals plotted against order"}
plot(Residuals)
WhereXY(1:length(Residuals), Residuals, yDist="normal")
```

```{r Lag1Resids, fig.cap="standardised residuals plotted against lagged residuals"}
n = length(Residuals)
plot(Residuals[-n], Residuals[-1], ylab= paste("Residuals 2 to", n), xlab=paste("Residuals 1 to",(n-1)))
WhereXY(Residuals[-n], Residuals[-1], xDist="normal")
```
The lag 1 autocorrelation of the standardised residuals is `r cor(Residuals[-n], Residuals[-1])`.

### Influence

```{r Leverages, fig.cap="Standardised residuals plotted against leverages"}
plot(Leverages, Residuals)
WhereXY(Leverages, Residuals, yDist="normal")
```

`r sum(Leverages>2*mean(Leverages))` points have excessive leverage.
`r sum(Cooks>1)` points have Cook\'s distances greater than one.

### Outliers and influential observations

```{r ListInfObs}
InflObs = data.frame(',
              ModelName,
              '$model, Fit=Fits, St.residual=Residuals, Leverage=Leverages, Cooks.distance=Cooks)[abs(Residuals)>2 | Cooks > 1 | Leverages > 2*mean(Leverages) , ]
```

```{r ListInfObsLatex, purl=FALSE}
library(xtable)
print(xtable(InflObs, caption="Listing of suspected outliers and influential observations.", label="InflObs',
              ModelName, '", digits=4), file = "', FolderName,
              '/Influential.tex")
```

```{r ListInfObsKabled, results="asis", purl=FALSE}
kable(InflObs)
```   \n\n'),
          file = RmdName, append = TRUE)

      # stop writing markdown and process the written file into html and an R script
      knit2html(RmdName, quiet = TRUE,
                stylesheet = FindCSSFile(getOption("BrailleR.Style")))
      file.remove(sub(".Rmd", ".md", RmdName))
      purl(RmdName, quiet = TRUE)
      if (getOption("BrailleR.View")) browseURL(sub(".Rmd", ".html", RmdName))

      # do the clean up
      #rm(list=c("Residuals", "Fits", "Leverages", "Cooks"), envir=.GlobalEnv)
      return(invisible(TRUE))
    }

VI.matrix = function(x, Describe=FALSE, ...) {
              VI(as.data.frame.matrix(x), Describe=Describe, ...)
            }



VI.qcc = function (x, ...) 
{
TypeText = paste("This control chart is a", x$type, "chart.")
SubgroupSizesConst = diff(range(x$sizes))==0 
PointText = paste("Data for", length(x$statistics), "subgroups of", .ifelse(SubgroupSizesConst, "equal", "varying"), "size are marked.")
CenterText = .ifelse(length(x$center)==1,
    paste0("The center line is marked at ", signif(x$center,4),  "."),
    "There is more than one center line.")
CLText = .ifelse(length(x$limits)==2,
   paste0("The LCL is at ", signif(x$limits[,1], 4), " and the UCL is at ", signif(x$limits[,2],4), "."),
    "There are more than one set of control limits.")
NoBL = length(x$violations$beyond.limits)
BLText = paste("There",  .ifelse(NoBL==1, "is", "are"), .ifelse(NoBL==0, "no", NoBL), .ifelse(NoBL==1, "point", "points"), "that breach the control limits.")
NoVR = length(x$violations$violating.runs) 
VRText = paste0("There ", .ifelse(NoVR==1, "is", "are"), " ", .ifelse(NoVR==0, "no", NoVR), " violating run", .ifelse(NoVR==1, "", "s"), ".")

Out = c(TypeText, PointText, CenterText, CLText, BLText, VRText)
class(Out) = "VI"
return(Out)
}


VI.tsplot =
    function(x, Describe=FALSE, ...) {
      x
    }

Try the BrailleR package in your browser

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

BrailleR documentation built on July 26, 2023, 5:46 p.m.