add 'hurdle' and 'zeroinfl' methods (leeper#1)

.travis.yml

@@ -20,6 +20,8 @@ r_packages:
 - nlme
 - nnet
 - ordinal
+- plm
+- pscl
 - quantreg
 - sampleSelection
 - survey

DESCRIPTION

@@ -3,8 +3,8 @@ Type: Package
 Title: Tidy, Type-Safe 'prediction()' Methods
 Description: A one-function package containing 'prediction()', a type-safe alternative to 'predict()' that always returns a data frame. The package currently supports common model types (e.g., "lm", "glm") from the 'stats' package, as well as numerous other model classes from other add-on packages. See the README or main package documentation page for a complete listing.
 License: MIT + file LICENSE
-Version: 0.1.16
-Date: 2017-04-10
+Version: 0.1.17
+Date: 2017-04-18
 Authors@R: c(person("Thomas J.", "Leeper",
                     role = c("aut", "cre"),
                     email = "[email protected]"),
@@ -39,6 +39,7 @@ Enhances:
     nnet,
     ordinal,
     plm,
+    pscl,
     quantreg,
     sampleSelection,
     survey (>= 3.31-5),

NAMESPACE

@@ -16,6 +16,7 @@ S3method(mean_or_mode,default)
 S3method(mean_or_mode,numeric)
 S3method(median_or_mode,default)
 S3method(median_or_mode,numeric)
+S3method(predict,zeroinfl)
 S3method(prediction,Arima)
 S3method(prediction,ar)
 S3method(prediction,arima0)
@@ -30,6 +31,7 @@ S3method(prediction,glm)
 S3method(prediction,glmx)
 S3method(prediction,gls)
 S3method(prediction,hetglm)
+S3method(prediction,hurdle)
 S3method(prediction,hxlr)
 S3method(prediction,ivreg)
 S3method(prediction,lm)

NEWS.md

@@ -1,3 +1,8 @@
+# CHANGES TO prediction 0.1.17
+
+* Added `prediction.zeroinfl()` method for "zeroinfl" objects from **pscl**. (#1)
+* Added `prediction.hurdle()` method for "hurdle" objects from **pscl**. (#1)
+
 # CHANGES TO prediction 0.1.16
 
 * Added `prediction.plm()` method for "plm" objects from **plm**. (#1)

R/prediction.R

@@ -24,6 +24,7 @@
 #'   \item \dQuote{gam}, see \code{\link[gam]{gam}}
 #'   \item \dQuote{gee}, see \code{\link[gee]{gee}}
 #'   \item \dQuote{gls}, see \code{\link[nlme]{gls}}
+#'   \item \dQuote{hurdle}, see \code{\link[pscl]{hurdle}}
 #'   \item \dQuote{hxlr}, see \code{\link[crch]{hxlr}}
 #'   \item \dQuote{ivreg}, see \code{\link[AER]{ivreg}}
 #'   \item \dQuote{lda}, see \code{\link[MASS]{lda}}
@@ -47,6 +48,7 @@
 #'   \item \dQuote{survreg}, see \code{\link[survival]{survreg}}
 #'   \item \dQuote{svm}, see \code{\link[e1071]{svm}}
 #'   \item \dQuote{svyglm}, see \code{\link[survey]{svyglm}}
+#'   \item \dQuote{zeroinfl}, see \code{\link[pscl]{zeroinfl}}
 #' }
 #' 
 #' @return A data frame with class \dQuote{prediction} that has a number of rows equal to number of rows in \code{data}, or a multiple thereof, if \code{!is.null(at)}. The return value contains \code{data} (possibly modified by \code{at} using \code{\link{build_datalist}}), plus a column containing fitted/predicted values (\code{"fitted"}) and a column containing the standard errors thereof (\code{"se.fitted"}). Additional columns may be reported depending on the object class.

R/prediction_hurdle.R

@@ -0,0 +1,40 @@
+#' @rdname prediction
+#' @export
+prediction.hurdle <- 
+function(model, 
+         data = find_data(model, parent.frame()), 
+         at = NULL, 
+         type = c("response", "count", "prob", "zero"), 
+         ...) {
+
+    type <- match.arg(type)
+
+    # extract predicted values
+    data <- data
+    if (missing(data) || is.null(data)) {
+        pred <- predict(model, type = type, ...)
+        pred <- data.frame(fitted = pred[["fit"]])
+    } else {
+        # setup data
+        out <- build_datalist(data, at = at)
+        for (i in seq_along(out)) {
+            tmp <- predict(model, 
+                           newdata = out[[i]], 
+                           type = type, 
+                           se.fit = TRUE,
+                           ...)
+            out[[i]] <- cbind(out[[i]], fitted = tmp)
+            rm(tmp)
+        }
+        pred <- do.call("rbind", out)
+    }
+    pred[["se.fitted"]] <- NA_real_
+
+    # obs-x-(ncol(data)+2) data frame
+    structure(pred, 
+              class = c("prediction", "data.frame"), 
+              row.names = seq_len(nrow(pred)),
+              at = if (is.null(at)) at else names(at), 
+              model.class = class(model),
+              type = type)
+}

R/prediction_zeroinfl.R

@@ -0,0 +1,3 @@
+#' @rdname prediction
+#' @export
+prediction.zeroinfl <- prediction.hurdle

README.Rmd

@@ -63,6 +63,7 @@ The currently supported model classes are:
  - "gam" from `gam::gam()`
  - "gee" from `gee::gee()`
  - "gls" from `nlme::gls()`
+ - "hurdle" from `pscl::hurdle()`
  - "hxlr" from `crch::hxlr()`
  - "ivreg" from `AER::ivreg()`
  - "lda" from `MASS:lda()`
@@ -86,6 +87,7 @@ The currently supported model classes are:
  - "survreg" from `survival::survreg()`
  - "svm" from `e1071::svm()`
  - "svyglm" from `survey::svyglm()`
+ - "zeroinfl" from `pscl::zeroinfl()`
 
 ## Requirements and Installation
 

README.md

@@ -109,6 +109,7 @@ The currently supported model classes are:
  - "gam" from `gam::gam()`
  - "gee" from `gee::gee()`
  - "gls" from `nlme::gls()`
+ - "hurdle" from `pscl::hurdle()`
  - "hxlr" from `crch::hxlr()`
  - "ivreg" from `AER::ivreg()`
  - "lda" from `MASS:lda()`
@@ -132,6 +133,7 @@ The currently supported model classes are:
  - "survreg" from `survival::survreg()`
  - "svm" from `e1071::svm()`
  - "svyglm" from `survey::svyglm()`
+ - "zeroinfl" from `pscl::zeroinfl()`
 
 ## Requirements and Installation
 

tests/testthat/tests-methods.R

@@ -208,6 +208,22 @@ if (requireNamespace("plm")) {
     })
 }
 
+if (requireNamespace("pscl")) {
+    test_that("Test prediction() for 'hurdle'", {
+        data("bioChemists", package = "pscl")
+        m <- hurdle::hurdle(art ~ ., data = bioChemists)
+        expect_true(inherits(prediction(m), "prediction"))
+    })
+    test_that("Test prediction() for 'zeroinfl'", {
+        data("bioChemists", package = "pscl")
+        m <- hurdle::zeroinfl(art ~ ., data = bioChemists)
+        expect_true(inherits(prediction(m), "prediction"))
+    })
+    #test_that("Test prediction() for 'ideal'", {
+    #    expect_true(inherits(prediction(m), "prediction"))
+    #})
+}
+
 if (requireNamespace("quantreg")) {
     #test_that("Test prediction() for 'rq'", {})
 }