Removed singleR class

Added sigma, influence, rstudent, rstandard methods

Fixed a bug with errors for summary.singleRmargin

Added better errors for plot method

Added better error messages for add1, drop1, profile, anova

NAMESPACE

@@ -1,19 +1,21 @@
 # Generated by roxygen2: do not edit by hand
 
-S3method(AIC,singleRStaticCountData)
-S3method(BIC,singleRStaticCountData)
+S3method(add1,singleRStaticCountData)
+S3method(anova,singleRStaticCountData)
 S3method(bread,singleRStaticCountData)
 S3method(confint,singleRStaticCountData)
 S3method(cooks.distance,singleRStaticCountData)
 S3method(df.residual,singleRStaticCountData)
 S3method(dfbeta,singleRStaticCountData)
 S3method(dfpopsize,singleRStaticCountData)
+S3method(drop1,singleRStaticCountData)
 S3method(estfun,singleRStaticCountData)
 S3method(estimatePopsize,default)
 S3method(extractAIC,singleRStaticCountData)
 S3method(family,singleRStaticCountData)
 S3method(fitted,singleRStaticCountData)
 S3method(hatvalues,singleRStaticCountData)
+S3method(influence,singleRStaticCountData)
 S3method(logLik,singleRStaticCountData)
 S3method(model.frame,singleRStaticCountData)
 S3method(model.matrix,singleRStaticCountData)
@@ -26,8 +28,12 @@ S3method(print,singleRStaticCountData)
 S3method(print,singleRfamily)
 S3method(print,summarysingleRStaticCountData)
 S3method(print,summarysingleRmargin)
+S3method(profile,singleRStaticCountData)
 S3method(redoPopEstimation,singleRStaticCountData)
 S3method(residuals,singleRStaticCountData)
+S3method(rstandard,singleRStaticCountData)
+S3method(rstudent,singleRStaticCountData)
+S3method(sigma,singleRStaticCountData)
 S3method(simulate,singleRStaticCountData)
 S3method(simulate,singleRfamily)
 S3method(stratifyPopsize,singleRStaticCountData)
@@ -90,6 +96,8 @@ importFrom(sandwich,estfun)
 importFrom(sandwich,vcovHC)
 importFrom(stats,AIC)
 importFrom(stats,BIC)
+importFrom(stats,add1)
+importFrom(stats,anova)
 importFrom(stats,coef)
 importFrom(stats,contrasts)
 importFrom(stats,cooks.distance)
@@ -100,11 +108,13 @@ importFrom(stats,dfbeta)
 importFrom(stats,dlnorm)
 importFrom(stats,dnbinom)
 importFrom(stats,dnorm)
+importFrom(stats,drop1)
 importFrom(stats,extractAIC)
 importFrom(stats,family)
 importFrom(stats,fitted)
 importFrom(stats,glm)
 importFrom(stats,hatvalues)
+importFrom(stats,influence)
 importFrom(stats,lm)
 importFrom(stats,logLik)
 importFrom(stats,model.frame)
@@ -116,6 +126,7 @@ importFrom(stats,pnorm)
 importFrom(stats,ppoints)
 importFrom(stats,predict)
 importFrom(stats,printCoefmat)
+importFrom(stats,profile)
 importFrom(stats,pt)
 importFrom(stats,qnorm)
 importFrom(stats,qqline)
@@ -124,8 +135,11 @@ importFrom(stats,quantile)
 importFrom(stats,rbinom)
 importFrom(stats,reformulate)
 importFrom(stats,residuals)
+importFrom(stats,rstandard)
+importFrom(stats,rstudent)
 importFrom(stats,runif)
 importFrom(stats,sd)
+importFrom(stats,sigma)
 importFrom(stats,simulate)
 importFrom(stats,terms)
 importFrom(stats,uniroot)

R/estimatePopsize.R

@@ -755,7 +755,7 @@ estimatePopsize.default <- function(formula,
         naAction         = naAction,
         fittingLog       = if (is.null(IRLSlog)) "IRLS logs were not saved." else IRLSlog
       ),
-      class = c("singleRStaticCountData", "singleR", "glm", "lm")
+      class = c("singleRStaticCountData", "glm", "lm")
     )
   } else {
     stop("Ratio regression is not yet implemented")

R/marginal.R

@@ -97,7 +97,7 @@ marginalFreq <- function(object,
 #' @param df degrees of freedom if not provided the function will try and manually
 #' but it is not always possible.
 #' @param dropl5 a character indicating treatment of cells with frequencies < 5 
-#' either grouping them, dropping or leaving them as is. Defaults to drop.
+#' either grouping them, dropping or leaving them as is. Defaults to \code{drop}.
 #' @param ... currently does nothing.
 #'
 #' @method summary singleRmargin
@@ -120,6 +120,10 @@ summary.singleRmargin <- function(object, df,
                                              "group", 
                                              "no"), 
                                   ...) {
+  if (missing(dropl5)) {
+    dropl5 <- "drop"
+  }
+
   if (!is.character(dropl5) | length(dropl5) > 1) {
     warning("The argument dropl5 should be a 1 length character vector")
     dropl5 <- dropl5[1]

R/methodsNotWorking.R

@@ -0,0 +1,25 @@
+# Add in the future actual methods for this:
+#' @importFrom stats add1
+#' @method add1 singleRStaticCountData
+#' @exportS3Method 
+add1.singleRStaticCountData <- function(object, scope, ...) {
+  stop("The add1 method for singleRStaticCountData class doesn't work yet.")
+}
+#' @importFrom stats profile
+#' @method profile singleRStaticCountData
+#' @exportS3Method 
+profile.singleRStaticCountData <- function(object, scope, ...) {
+  stop("The profile method for singleRStaticCountData class doesn't work yet.")
+}
+#' @importFrom stats drop1
+#' @method drop1 singleRStaticCountData
+#' @exportS3Method 
+drop1.singleRStaticCountData <- function(object, scope, ...) {
+  stop("The drop1 method for singleRStaticCountData class doesn't work yet.")
+}
+#' @importFrom stats anova
+#' @method anova singleRStaticCountData
+#' @exportS3Method 
+anova.singleRStaticCountData <- function(object, ...) {
+  stop("The anova method for singleRStaticCountData class doesn't work yet.")
+}

R/miscPrints.R

@@ -1,4 +1,5 @@
 #' @method print singleRStaticCountData
+#' @importFrom stats AIC BIC
 #' @exportS3Method 
 print.singleRStaticCountData <- function(x, ...) {
   cat("Call: ")

R/plots.R

@@ -102,12 +102,27 @@ plot.singleRStaticCountData <- function(x,
                                         histKernels = TRUE,
                                         dfpop,
                                         ...) {
-  if (missing(plotType)) stop("Argument plotType must be provided needed")
+  if (missing(plotType) | (!is.null(plotType) & 
+      !isTRUE(is.integer(plotType)) & !isTRUE(is.character(plotType)))) {
+    if (is.numeric(plotType) & (length(plotType) == 1)) {
+      plotType <- as.integer(plotType)
+    } else {
+      stop("Argument plotType must be provided as a character or integer or NULL.")
+    }
+  }
+  if (isTRUE(is.integer(plotType))) {
+    plotType <- c(
+      "qq", "marginal", "fitresid",
+      "bootHist", "rootogram", "dfpopContr",
+      "dfpopBox", "scaleLoc", "cooks",
+      "hatplot", "strata"
+    )[plotType]
+  }
   ## sugested by Victoria Wimmer
   oldpar <- graphics::par(no.readonly = TRUE)
   on.exit(graphics::par(oldpar))
 
-  if ((plotType == "bootHist") && (!is.numeric(x$populationSize$boot))) {
+  if (isTRUE(plotType == "bootHist") && isTRUE(!is.numeric(x$populationSize$boot))) {
     stop("Trying to plot bootstrap results with no bootstrap performed")
   } 
   plotType <- match.arg(plotType)

R/smallMethods.R

@@ -18,19 +18,6 @@ popSizeEst <- function(object, ...) {
 family.singleRStaticCountData <- function(object, ...) {
   object$model
 }
-
-#' @method AIC singleRStaticCountData
-#' @importFrom stats AIC
-#' @exportS3Method 
-AIC.singleRStaticCountData <- function(object, ...) {
-  2 * (length(object$coefficients) - object$logL)
-}
-#' @method BIC singleRStaticCountData
-#' @importFrom stats BIC
-#' @exportS3Method 
-BIC.singleRStaticCountData <- function(object, ...) {
-  length(object$coefficients) * log(nobs(object, ...)) - 2 * object$logL
-}
 #' @method extractAIC singleRStaticCountData
 #' @importFrom stats extractAIC
 #' @exportS3Method 
@@ -172,3 +159,70 @@ nobs.singleRStaticCountData <- function(object, ...) {
 df.residual.singleRStaticCountData <- function(object, ...) {
   object$dfResidual
 }
+
+#' @importFrom stats sigma
+#' @method sigma singleRStaticCountData
+#' @exportS3Method 
+sigma.singleRStaticCountData <- function(object, ...) {
+  predict(object, type = "mean", se = TRUE)[c(3, 4)]
+}
+
+#' @importFrom stats influence
+#' @method influence singleRStaticCountData
+#' @exportS3Method 
+influence.singleRStaticCountData <- function(model, do.coef = FALSE, ...) {
+  res <- list()
+  hat <- hatvalues(model)
+  if (NCOL(hat) > 1) {
+    for (k in 1L:NCOL(hat)) {
+      res[[paste0("hat:", colnames(hat)[k])]] <- hat[, k]
+    }
+  } else {
+    res[["hat"]] <- hat[, 1]
+  }
+
+  if (isTRUE(do.coef)) {
+    dfb <- dfbeta(model, ...)
+    res[["coefficients"]] <- dfb
+  }
+
+  sigma <- sigma(model)
+  res[["sigma:truncated"]]    <- sigma[, 1]
+  res[["sigma:nontruncated"]] <- sigma[, 2]
+
+  res[["dev.res"]] <- residuals(model, type = "deviance")[, 1]
+
+  res[["pear.res"]] <- residuals(model, type = "pearson")[, 1]
+
+  res
+}
+
+#' @importFrom stats rstudent
+#' @method rstudent singleRStaticCountData
+#' @exportS3Method 
+rstudent.singleRStaticCountData <- function(model, ...) {
+  res <- residuals(model, type = "pearson")[, 1]
+  hat <- hatvalues(model)[, 1]
+
+  res <- res / sqrt((1 - hat))
+
+  res[is.infinite(res)] <- NaN
+  res
+}
+
+#' @importFrom stats rstandard
+#' @method rstandard singleRStaticCountData
+#' @exportS3Method 
+rstandard.singleRStaticCountData <- function(model,
+                                             type = c("deviance", "pearson"), 
+                                             ...) {
+  type <- match.arg(type)
+  res <- switch (type,
+    pearson  = residuals(model, type = "pearsonSTD")[, 1],
+    deviance = residuals(model, type = "deviance")[, 1] / 
+      (sqrt(1 - hatvalues(model)[, 1]) * sigma(model)[, 1]),
+  )
+
+  res[is.infinite(res)] <- NaN
+  res
+}