Merge pull request #25 from mthulin/master

Add convenience functions for residuals and distributions

Author: dicook

DESCRIPTION

@@ -8,7 +8,8 @@ Authors@R: c(
     person("Hadley", "Wickham", email = "[email protected]", role = c("aut", "ctb"), comment = c(ORCID = "0000-0003-4757-117X")),
     person("Niladri Roy", "Chowdhury", email = "[email protected]", role = c("aut", "ctb")),
     person("Di", "Cook", email = "[email protected]", role = c("aut", "cre"), comment = c(ORCID = "0000-0002-3813-7155")),
-    person("Heike", "Hofmann", email = "[email protected]", role = c("aut", "ctb"), comment = c(ORCID = "0000-0001-6216-5183"))
+    person("Heike", "Hofmann", email = "[email protected]", role = c("aut", "ctb"), comment = c(ORCID = "0000-0001-6216-5183")),
+    person("Måns", "Thulin", email = "[email protected]", role = c("aut", "ctb"))
   )
 Maintainer: Di Cook <[email protected]>
 License: GPL (>= 2)
@@ -23,7 +24,8 @@ Imports:
     purrr,
     tidyr,
     tibble,
-    magrittr
+    magrittr,
+    stats
 Suggests:
     forecast,
     viridis,
@@ -32,5 +34,5 @@ LazyData: true
 Type: Package
 LazyLoad: false
 VignetteBuilder: knitr
-RoxygenNote: 7.3.1
+RoxygenNote: 7.3.2
 Encoding: UTF-8

NAMESPACE

@@ -8,6 +8,9 @@ export(decrypt)
 export(distmet)
 export(distplot)
 export(lineup)
+export(lineup_histograms)
+export(lineup_qq)
+export(lineup_residuals)
 export(null_dist)
 export(null_lm)
 export(null_permute)
@@ -17,6 +20,7 @@ export(pvisual)
 export(reg_dist)
 export(resid_boot)
 export(resid_pboot)
+export(resid_perm)
 export(resid_rotate)
 export(resid_sigma)
 export(rorschach)
@@ -33,9 +37,21 @@ importFrom(dplyr,filter)
 importFrom(dplyr,group_by)
 importFrom(dplyr,mutate)
 importFrom(dplyr,summarise)
+importFrom(ggplot2,.data)
 importFrom(ggplot2,aes)
+importFrom(ggplot2,after_stat)
+importFrom(ggplot2,facet_wrap)
+importFrom(ggplot2,geom_abline)
+importFrom(ggplot2,geom_density)
+importFrom(ggplot2,geom_histogram)
+importFrom(ggplot2,geom_line)
+importFrom(ggplot2,geom_point)
+importFrom(ggplot2,geom_qq)
+importFrom(ggplot2,geom_qq_line)
+importFrom(ggplot2,geom_smooth)
 importFrom(ggplot2,geom_tile)
 importFrom(ggplot2,ggplot)
+importFrom(ggplot2,labs)
 importFrom(ggplot2,last_plot)
 importFrom(ggplot2,scale_fill_gradient)
 importFrom(ggplot2,xlab)
@@ -46,15 +62,21 @@ importFrom(stats,as.ts)
 importFrom(stats,coef)
 importFrom(stats,cutree)
 importFrom(stats,density)
+importFrom(stats,deviance)
+importFrom(stats,df.residual)
 importFrom(stats,dist)
+importFrom(stats,fitted)
+importFrom(stats,formula)
 importFrom(stats,hclust)
 importFrom(stats,lm)
+importFrom(stats,lm.influence)
 importFrom(stats,pbinom)
 importFrom(stats,predict)
 importFrom(stats,qbinom)
 importFrom(stats,quantile)
 importFrom(stats,rbinom)
 importFrom(stats,resid)
+importFrom(stats,residuals)
 importFrom(stats,rnorm)
 importFrom(stats,runif)
 importFrom(stats,sd)

R/method-model.r

@@ -9,11 +9,13 @@
 #'   'rotate', 'perm', 'pboot' and 'boot' are defined by \code{\link{resid_rotate}},
 #'   \code{\link{resid_perm}}, \code{\link{resid_pboot}} and \code{\link{resid_boot}}
 #'   respectively
-#' @param ... other arguments passedd onto \code{method}.
+#' @param additional whether to compute additional measures: standardized
+#'   residuals and leverage
+#' @param ... other arguments passed onto \code{method}.
 #' @return a function that given \code{data} generates a null data set.
 #'   For use with \code{\link{lineup}} or \code{\link{rorschach}}
 #' @export
-#' @importFrom stats lm predict
+#' @importFrom stats lm predict deviance df.residual lm.influence
 #' @seealso null_permute, null_dist
 #' @examples
 #' data(tips)
@@ -23,7 +25,7 @@
 #' ggplot(lineup(null_lm(tip ~ total_bill, method = 'rotate'), tips.reg)) +
 #'   geom_point(aes(x = total_bill, y = .resid)) +
 #'   facet_wrap(~ .sample)
-null_lm <- function(f, method = "rotate", ...) {
+null_lm <- function(f, method = "rotate", additional = FALSE, ...) {
   n <- NULL
     if (is.character(method)) {
         method <- match.fun(paste("resid", method, sep = "_"))
@@ -33,9 +35,15 @@ null_lm <- function(f, method = "rotate", ...) {
         resp_var <- all.vars(f[[2]])
 
         resid <- method(model, df, ...)
-        fitted <- stats::predict(model, df)
+        fitted <- predict(model, df)
         df[".resid"] <- resid
         df[".fitted"] <- fitted
+        if(additional){
+          s <- sqrt(deviance(model)/df.residual(model))
+          hii <- lm.influence(model, do.coef = FALSE)$hat
+          df[".leverage"] <- dropInf(hii, hii)
+          df[".stdresid"] <- dropInf(resid/(s * sqrt(1 - hii)), hii)
+        }
         df[[resp_var]] <- fitted + resid
         df
     }
@@ -103,7 +111,20 @@ resid_boot <- function(model, data) {
 #'
 #' @param model to extract residuals from
 #' @importFrom stats resid
+#' @param data used to fit model
 #' @export
 resid_perm <- function(model, data) {
     sample(stats::resid(model))
 }
+
+
+# Helper function for leverages, adapted from plot.lm
+dropInf <- function(x, h) {
+  if (any(isInf <- h >= 1)) {
+    warning(gettextf("not plotting observations with leverage greater than one:\n  %s",
+                     paste(which(isInf), collapse = ", ")), call. = FALSE,
+            domain = NA)
+    x[isInf] <- NaN
+  }
+  x
+}