New Upstream Snapshot - r-cran-prediction
Ready changes
Summary
Merged new upstream version: 0.3.14+git20191224.1.c239565 (was: 0.3.14).
Resulting package
Built on 2023-01-20T01:28 (took 6m54s)
The resulting binary packages can be installed (if you have the apt repository enabled) by running one of:
apt install -t fresh-snapshots r-cran-prediction
Lintian Result
Diff
diff --git a/DESCRIPTION b/DESCRIPTION
index 0a67171..78f9777 100644
--- a/DESCRIPTION
+++ b/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 'summary()' method provides a data frame with average predictions, possibly over counterfactual versions of the data (a la the 'margins' command in 'Stata'). Marginal effect estimation is provided by the related package, 'margins' <https://cran.r-project.org/package=margins>. 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.3.14
-Date: 2019-06-16
+Version: 0.3.15
+Date: 2019-12-24
Authors@R: c(person("Thomas J.", "Leeper",
role = c("aut", "cre"),
email = "thosjleeper@gmail.com",
@@ -27,12 +27,10 @@ Enhances: AER, aod, betareg, biglm, brglm, caret, crch, e1071, earth,
3.31-5), survival, truncreg, VGAM
ByteCompile: true
Encoding: UTF-8
-RoxygenNote: 6.1.1
+RoxygenNote: 7.0.2
NeedsCompilation: no
-Packaged: 2019-06-17 18:36:42 UTC; THOMAS
+Packaged: 2023-01-20 01:23:13 UTC; root
Author: Thomas J. Leeper [aut, cre] (<https://orcid.org/0000-0003-4097-6326>),
Carl Ganz [ctb],
Vincent Arel-Bundock [ctb] (<https://orcid.org/0000-0003-2042-7063>)
Maintainer: Thomas J. Leeper <thosjleeper@gmail.com>
-Repository: CRAN
-Date/Publication: 2019-06-17 19:40:03 UTC
diff --git a/LICENSE b/LICENSE
index 29bb09c..ed86bff 100644
--- a/LICENSE
+++ b/LICENSE
@@ -1,2 +1,2 @@
-YEAR: 2016-2018
-COPYRIGHT HOLDER: Thomas J. Leeper
+YEAR: 2016-2018
+COPYRIGHT HOLDER: Thomas J. Leeper
diff --git a/MD5 b/MD5
deleted file mode 100644
index bbe4089..0000000
--- a/MD5
+++ /dev/null
@@ -1,96 +0,0 @@
-c99f5a95d4b090cc1384d2fda1fad003 *DESCRIPTION
-875ed094f58c0c1b2c38c2aecc6e1e9f *LICENSE
-df5a4adb0d6171e3b33f46e1213c855d *NAMESPACE
-0afdbf4c8a650275cc6ec65d9ccdba48 *NEWS.md
-f9d37a2a80f0f9d04696e92f6c2ab653 *R/build_datalist.R
-105ced25ae286073487387409560b16d *R/find_data.R
-143c5d8a66b917e3106ac135e2e98e76 *R/make_data_frame.R
-a8c2122556b46f3c342733d71da79d4f *R/margex.R
-da5660b8f426c6b9ae6ff27abc793080 *R/mean_or_mode.R
-0a4e9994a07d4a9895c317c6ecd0c014 *R/prediction.R
-7e5f4746fc400c4d92f4c5ad1c991e4e *R/prediction_Arima.R
-629093292de8b2aa4f5389b6ef003d1c *R/prediction_ar.R
-84c158331418816751d4649c9444c69a *R/prediction_arima0.R
-39382b3ec5ff1a50306ffb299344dd39 *R/prediction_betareg.R
-1bbb3b8a8ca6397b47fe68a929c34390 *R/prediction_bigFastLm.R
-bdae9856e4e7c2be3dda719ebc6c596b *R/prediction_bigglm.R
-fe73e08cea5a1883497ba0fe7751c566 *R/prediction_biglm.R
-ab2f4567280d8352e5348501fb73b063 *R/prediction_bruto.R
-f0d57fde58010db1f06c1ef19d74d19a *R/prediction_clm.R
-3cc3f5dbcf789da1d7833373c0782b58 *R/prediction_coxph.R
-953f95190d3d17dc0fdcf61a57078cd0 *R/prediction_crch.R
-be818010a8adc80cf4bf4a76340c0b0e *R/prediction_earth.R
-8dbd4d4fdb863aca0207712389ab91a1 *R/prediction_fda.R
-65c8fc9f11e573289e326cb7f4f4c302 *R/prediction_gam.R
-ae4f28d4062082125dc723688c25ab28 *R/prediction_gausspr.R
-825925f51f2a49f98a1ef28280193053 *R/prediction_gee.R
-f2b475a93aa8d7070c8fcc146c709260 *R/prediction_glimML.R
-75324ba15cddb60772707af35a042148 *R/prediction_glimQL.R
-fd6fc7a9ef1f039b9a93955926fa4210 *R/prediction_glm.R
-5fe8c9ca754342e25dc8796f39be6245 *R/prediction_glmnet.R
-14ab1ebce030f4ec871511e3849b4ce2 *R/prediction_glmx.R
-65dceb496efa24276719b309f9df7048 *R/prediction_gls.R
-80c7fa5777c4beb86cee8f21fd41f6b3 *R/prediction_hetglm.R
-2e12e3004cd38e217a06b215ab3b710b *R/prediction_hurdle.R
-1691620dd40b2f014b4a405d2a7e9a08 *R/prediction_hxlr.R
-cdc0ffdc6b67152073c421e9c8e42f88 *R/prediction_ivreg.R
-5d61ae51b61869b687a4d0fc7f546440 *R/prediction_knnreg.R
-6a67310a26234218eccc04cc3d0d2a4f *R/prediction_kqr.R
-d696ccbb0f3b555cfb63f48a44031ecb *R/prediction_ksvm.R
-07b8f692f3ac4577fa22bffe16564cd0 *R/prediction_lda.R
-b66ad16941fe13c11965745705be8464 *R/prediction_lm.R
-3fa5c205e7401c2364e949289ecbd271 *R/prediction_lme.R
-c1fc72eba423456ea73cbbf046f609a7 *R/prediction_loess.R
-5bd17dac4240da89d0245ec0f835a237 *R/prediction_lqs.R
-c77c070e90ba7d7bd56ed00071385d2b *R/prediction_mars.R
-ea59d4e0fd6e20089f4b43a6a512e03f *R/prediction_mca.R
-8a2bad4170b4c42bad5b9e98b2117793 *R/prediction_mclogit.R
-d8657ed9b8a2cd5291fb4613ca94a2ef *R/prediction_merMod.R
-edde9f770e2ba5588087e985b9669052 *R/prediction_mlogit.R
-001bdc6520500b6f13fd5e34f785cd7d *R/prediction_mnlogit.R
-ff8633187787584629421ee8d58f2110 *R/prediction_mnp.R
-9f78f9478b75f23b92d0b4f9be32a441 *R/prediction_multinom.R
-06bf831fffc18259f8eba2da6b6c48e8 *R/prediction_naiveBayes.R
-b169c60d262482ab0c762624221dac4f *R/prediction_nls.R
-5a85eca5711455d33629aefcefc537fa *R/prediction_nnet.R
-81f4a705c6fe2ec4dd52abd8e7997c30 *R/prediction_plm.R
-2b7792c52ea2ee8f0bd1f9f78127db97 *R/prediction_polr.R
-de4b32b3878ccae87f788c0d487c23e2 *R/prediction_polyreg.R
-c3f30d2c76007d1c9a960133317baaf6 *R/prediction_ppr.R
-a0bffc459d37c55d85b718e6342b5455 *R/prediction_princomp.R
-3fdb66525fc695bc0f46c1ebcd5efcd4 *R/prediction_qda.R
-9de548c4c1b300269b5e6a6ecc266876 *R/prediction_rlm.R
-b20136e41550d9afa7a92629628a6345 *R/prediction_rpart.R
-5d318c73bcad0b86ad85bfb2db1e8871 *R/prediction_rq.R
-cb5e6b97b26079ee1a308e1133658e32 *R/prediction_selection.R
-c2fbbee642a19593ea43280f3b985f33 *R/prediction_speedglm.R
-cc8690e9ae2267734b790f1570ec55bf *R/prediction_speedlm.R
-bbdb365f0c1dbc609a5bc8745eb65308 *R/prediction_survreg.R
-6cb453e5cdfd5752556019c6366971f3 *R/prediction_svm.R
-fbef2e67f7a1130a62341b4deda53b62 *R/prediction_svyglm.R
-720d221abccc96ac7f8e55a9184b778c *R/prediction_train.R
-4fbef4c0b5d2687c0eb9b5f70f6819db *R/prediction_tree.R
-39de348f4883e8a8e15c4e82f4aba63a *R/prediction_truncreg.R
-7f64b9941686dbaede4d9ef77c35deba *R/prediction_vgam.R
-f9ab3d7d2845cd4e52f7368aa496a703 *R/prediction_vglm.R
-4cd5361420a13da52d83bc21d5317493 *R/prediction_zeroinfl.R
-4258a0ed57e287660281e73ceef8c581 *R/print.R
-10a7e116d64b42f5b75ab839193b737e *R/seq_range.R
-7b87a3a1cdb74f3feb8082c6d4434183 *R/summary.R
-ca9ac657b19b846bd21d2a5488f1645e *R/utils.R
-f362b5a8c87e6dd25ff7142b34dc5726 *README.md
-e9d44d03f5420756e7ada891b94f7235 *data/margex.rda
-3acbd06a9009c660ff9bdf5e418a6b90 *inst/CITATION
-7d518cae27e112cc4240f7058a0584e2 *man/build_datalist.Rd
-3619985ff0f3bd43fa6814b1a0874fe5 *man/figures/logo.png
-da41232f73d433a26fd62f613bf536a0 *man/figures/logo.svg
-c22772da367a524088f9519c925c50b3 *man/find_data.Rd
-18ef9fa9c4858888586db3c989deb73c *man/margex.Rd
-133a4501528cd3ade7a8cdb46dab023f *man/mean_or_mode.Rd
-5ec0e0d0ea5ad7db678dbc82c64d0cef *man/prediction.Rd
-bc55730250606031ee18b095eb840f5e *man/seq_range.Rd
-3654c24de1c773caa482666f764b7360 *tests/testthat-prediction.R
-4d7c7d803b404c321305c266ea190fe4 *tests/testthat/tests-build_datalist.R
-994b206daee44fcf020e9373badc56bd *tests/testthat/tests-core.R
-f3200112d3d96313ea4fdc638990ad46 *tests/testthat/tests-find_data.R
-1ab11f55bb053062305f62a60ebe191a *tests/testthat/tests-methods.R
diff --git a/NAMESPACE b/NAMESPACE
index f7d5c8b..3daf9dc 100644
--- a/NAMESPACE
+++ b/NAMESPACE
@@ -1,96 +1,96 @@
-# Generated by roxygen2: do not edit by hand
-
-S3method(find_data,crch)
-S3method(find_data,data.frame)
-S3method(find_data,default)
-S3method(find_data,glimML)
-S3method(find_data,glm)
-S3method(find_data,hxlr)
-S3method(find_data,lm)
-S3method(find_data,mca)
-S3method(find_data,merMod)
-S3method(find_data,svyglm)
-S3method(find_data,train)
-S3method(find_data,vgam)
-S3method(find_data,vglm)
-S3method(head,prediction)
-S3method(mean_or_mode,data.frame)
-S3method(mean_or_mode,default)
-S3method(mean_or_mode,numeric)
-S3method(median_or_mode,data.frame)
-S3method(median_or_mode,default)
-S3method(median_or_mode,numeric)
-S3method(prediction,Arima)
-S3method(prediction,Gam)
-S3method(prediction,ar)
-S3method(prediction,arima0)
-S3method(prediction,betareg)
-S3method(prediction,biglm)
-S3method(prediction,bruto)
-S3method(prediction,clm)
-S3method(prediction,coxph)
-S3method(prediction,crch)
-S3method(prediction,default)
-S3method(prediction,earth)
-S3method(prediction,fda)
-S3method(prediction,gausspr)
-S3method(prediction,gee)
-S3method(prediction,glimML)
-S3method(prediction,glimQL)
-S3method(prediction,glm)
-S3method(prediction,glmnet)
-S3method(prediction,glmx)
-S3method(prediction,gls)
-S3method(prediction,hetglm)
-S3method(prediction,hurdle)
-S3method(prediction,hxlr)
-S3method(prediction,ivreg)
-S3method(prediction,knnreg)
-S3method(prediction,kqr)
-S3method(prediction,ksvm)
-S3method(prediction,lm)
-S3method(prediction,lme)
-S3method(prediction,loess)
-S3method(prediction,lqs)
-S3method(prediction,mars)
-S3method(prediction,mca)
-S3method(prediction,mclogit)
-S3method(prediction,merMod)
-S3method(prediction,mnp)
-S3method(prediction,multinom)
-S3method(prediction,nls)
-S3method(prediction,nnet)
-S3method(prediction,plm)
-S3method(prediction,polr)
-S3method(prediction,polyreg)
-S3method(prediction,ppr)
-S3method(prediction,princomp)
-S3method(prediction,rlm)
-S3method(prediction,rpart)
-S3method(prediction,rq)
-S3method(prediction,selection)
-S3method(prediction,speedglm)
-S3method(prediction,speedlm)
-S3method(prediction,survreg)
-S3method(prediction,svm)
-S3method(prediction,svyglm)
-S3method(prediction,train)
-S3method(prediction,truncreg)
-S3method(prediction,zeroinfl)
-S3method(print,prediction)
-S3method(print,summary.prediction)
-S3method(summary,prediction)
-S3method(tail,prediction)
-export(build_datalist)
-export(find_data)
-export(mean_or_mode)
-export(median_or_mode)
-export(prediction)
-export(prediction_summary)
-export(seq_range)
-import(stats)
-importFrom(data.table,rbindlist)
-importFrom(stats,model.frame)
-importFrom(stats,terms)
-importFrom(utils,head)
-importFrom(utils,tail)
+# Generated by roxygen2: do not edit by hand
+
+S3method(find_data,crch)
+S3method(find_data,data.frame)
+S3method(find_data,default)
+S3method(find_data,glimML)
+S3method(find_data,glm)
+S3method(find_data,hxlr)
+S3method(find_data,lm)
+S3method(find_data,mca)
+S3method(find_data,merMod)
+S3method(find_data,svyglm)
+S3method(find_data,train)
+S3method(find_data,vgam)
+S3method(find_data,vglm)
+S3method(head,prediction)
+S3method(mean_or_mode,data.frame)
+S3method(mean_or_mode,default)
+S3method(mean_or_mode,numeric)
+S3method(median_or_mode,data.frame)
+S3method(median_or_mode,default)
+S3method(median_or_mode,numeric)
+S3method(prediction,Arima)
+S3method(prediction,Gam)
+S3method(prediction,ar)
+S3method(prediction,arima0)
+S3method(prediction,betareg)
+S3method(prediction,biglm)
+S3method(prediction,bruto)
+S3method(prediction,clm)
+S3method(prediction,coxph)
+S3method(prediction,crch)
+S3method(prediction,default)
+S3method(prediction,earth)
+S3method(prediction,fda)
+S3method(prediction,gausspr)
+S3method(prediction,gee)
+S3method(prediction,glimML)
+S3method(prediction,glimQL)
+S3method(prediction,glm)
+S3method(prediction,glmnet)
+S3method(prediction,glmx)
+S3method(prediction,gls)
+S3method(prediction,hetglm)
+S3method(prediction,hurdle)
+S3method(prediction,hxlr)
+S3method(prediction,ivreg)
+S3method(prediction,knnreg)
+S3method(prediction,kqr)
+S3method(prediction,ksvm)
+S3method(prediction,lm)
+S3method(prediction,lme)
+S3method(prediction,loess)
+S3method(prediction,lqs)
+S3method(prediction,mars)
+S3method(prediction,mca)
+S3method(prediction,mclogit)
+S3method(prediction,merMod)
+S3method(prediction,mnp)
+S3method(prediction,multinom)
+S3method(prediction,nls)
+S3method(prediction,nnet)
+S3method(prediction,plm)
+S3method(prediction,polr)
+S3method(prediction,polyreg)
+S3method(prediction,ppr)
+S3method(prediction,princomp)
+S3method(prediction,rlm)
+S3method(prediction,rpart)
+S3method(prediction,rq)
+S3method(prediction,selection)
+S3method(prediction,speedglm)
+S3method(prediction,speedlm)
+S3method(prediction,survreg)
+S3method(prediction,svm)
+S3method(prediction,svyglm)
+S3method(prediction,train)
+S3method(prediction,truncreg)
+S3method(prediction,zeroinfl)
+S3method(print,prediction)
+S3method(print,summary.prediction)
+S3method(summary,prediction)
+S3method(tail,prediction)
+export(build_datalist)
+export(find_data)
+export(mean_or_mode)
+export(median_or_mode)
+export(prediction)
+export(prediction_summary)
+export(seq_range)
+import(stats)
+importFrom(data.table,rbindlist)
+importFrom(stats,model.frame)
+importFrom(stats,terms)
+importFrom(utils,head)
+importFrom(utils,tail)
diff --git a/NEWS.md b/NEWS.md
index 30b5b92..5c186bc 100644
--- a/NEWS.md
+++ b/NEWS.md
@@ -1,214 +1,220 @@
-# prediction 0.3.13
-
-* Fixed a bug in `prediction_glm` with the `data` argument (Issue #32).
-
-# prediction 0.3.12
-
-* Remove mnlogit dependency, as it has been removed from CRAN.
-
-# prediction 0.3.11
-
-* Remove bigFastLm dependency, as it has been removed from CRAN.
-
-# prediction 0.3.10
-
-* Added tests for `find_data()` and `prediction.lm()` to check for correct behavior in the presence of missing data (`na.action`) and `subset` arguments. (#28)
-
-# prediction 0.3.8
-
-* Provisional support for variances of average predictions for GLMs. (#17)
-* Added an example dataset, `margex`, borrowed from Stata's identically named data.
-
-# prediction 0.3.7
-
-* `summary(prediction(...))` now reports variances of average predictions, along with test statistics, p-values, and confidence intervals, where supported. (#17)
-* Added a function `prediction_summary()` which simply calls `summary(prediction(...))`.
-* All methods now return additional attributes.
-
-# prediction 0.3.6
-
-* Small fixes for failing CRAN checks. (#25)
-* Remove `prediction.bigglm()` method (from **biglm**) due to failing tests. (#25)
-
-# prediction 0.3.5
-
-* Fixed a bug that required specifying `stats::poly()` rather than just `poly()` in model formulae. (#22)
-
-# prediction 0.3.4
-
-* Added `prediction.glmnet()` method for "glmnet" objects from **glmnet**. (#1)
-
-# prediction 0.3.3
-
-* `prediction.merMod()` gains an `re.form` argument to pass forward to `predict.merMod()`.
-
-# prediction 0.3.2
-
-* Fix typo in "speedglm" that was overwriting "glm" method.
-
-# prediction 0.3.0
-
-* CRAN release.
-
-# prediction 0.2.11
-
-* Added `prediction.glmML()` method for "glimML" objects from **aod**. (#1)
-* Added `prediction.glmQL()` method for "glimQL" objects from **aod**. (#1)
-* Added `prediction.truncreg()` method for "truncreg" objects from **truncreg**. (#1)
-* Noted implicit support for "tobit" objects from **AER**. (#1)
-
-# prediction 0.2.10
-
-* Added `prediction.bruto()` method for "bruto" objects from **mda**. (#1)
-* Added `prediction.fda()` method for "fda" objects from **mda**. (#1)
-* Added `prediction.mars()` method for "mars" objects from **mda**. (#1)
-* Added `prediction.mda()` method for "mda" objects from **mda**. (#1)
-* Added `prediction.polyreg()` method for "polyreg" objects from **mda**. (#1)
-
-# prediction 0.2.9
-
-* Added `prediction.speedglm()` and `prediction.speedlm()` methods for "speedglm" and "speedlm" objects from **speedglm**. (#1)
-* Added `prediction.bigLm()` method for "bigLm" objects from **bigFastlm**. (#1)
-* Added `prediction.biglm()` and `prediction.bigglm()` methods for "biglm" and "bigglm" objects from **biglm**, including those based by `"ffdf"` from **ff**. (#1)
-
-# prediction 0.2.8
-
-* Changed internal behavior of `build_datalist()`. The function now returns an an `at_specification` attribute, which is a data frame representation of the `at` argument.
-
-# prediction 0.2.6
-
-* Due to a change in gam_1.15, `prediction.gam()` is now `prediction.Gam()` for "Gam" objects from **gam**. (#1)
-
-# prediction 0.2.6
-
-* Added `prediction.train()` method for "train" objects from **caret**. (#1)
-
-# prediction 0.2.5
-
-* The `at` argument in `build_datalist()` now accepts a data frame of combinations for limiting the set of levels.
-
-# prediction 0.2.3
-
-* Most `prediction()` methods gain a (experimental) `calculate_se` argument, which regulates whether to calculate standard errors for predictions. Setting to `FALSE` can improve performance if they are not needed.
-
-# prediction 0.2.3
-
-* `build_datalist()` gains an `as.data.frame` argument, which - if `TRUE` - returns a stacked data frame rather than a list. This argument is now used internally in most `prediction()` functions in an effort to improve performance. (#18)
-
-# prediction 0.2.2
-
-* Expanded test suite scope and fixed a few small bugs.
-* Added a `summary.prediction()` method to interact with the average predicted values that are printed when `at != NULL`.
-
-# prediction 0.2.1
-
-* Added `prediction.knnreg()` method for "knnreg" objects from **caret**. (#1)
-* Added `prediction.gausspr()` method for "gausspr" objects from **kernlab**. (#1)
-* Added `prediction.ksvm()` method for "ksvm" objects from **kernlab**. (#1)
-* Added `prediction.kqr()` method for "kqr" objects from **kernlab**. (#1)
-* Added `prediction.earth()` method for "earth" objects from **earth**. (#1)
-* Added `prediction.rpart()` method for "rpart" objects from **rpart**. (#1)
-
-# prediction 0.2.0
-
-* CRAN Release.
-* Added `mean_or_mode.data.frame()` and `median_or_mode.data.frame()` methods.
-
-# prediction 0.1.17
-
-* Added `prediction.zeroinfl()` method for "zeroinfl" objects from **pscl**. (#1)
-* Added `prediction.hurdle()` method for "hurdle" objects from **pscl**. (#1)
-* Added `prediction.lme()` method for "lme" and "nlme" objects from **nlme**. (#1)
-* Documented `prediction.merMod()`.
-
-# prediction 0.1.16
-
-* Added `prediction.plm()` method for "plm" objects from **plm**. (#1)
-
-# prediction 0.1.15
-
-* Expanded test suite considerably and updated `CONTRIBUTING.md` to reflect expected test-driven development.
-* A few small code tweaks and bug fixes resulting from the updated test suite.
-
-# prediction 0.1.14
-
-* Added `prediction.mnp()` method for "mnp" objects from **MNP**. (#1)
-* Added `prediction.mnlogit()` method for "mnlogit" objects from **mnlogit**. (#1)
-* Added `prediction.gee()` method for "gee" objects from **gee**. (#1)
-* Added `prediction.lqs()` method for "lqs" objects from **MASS**. (#1)
-* Added `prediction.mca()` method for "mca" objects from **MASS**. (#1)
-* Noted (built-in) support for "brglm" objects from **brglm** via the `prediction.glm()` method. (#1)
-
-# prediction 0.1.13
-
-* Added a `category` argument to `prediction()` methods for models of multilevel outcomes (e.g., ordered probit, etc.) to be dictate which level is expressed as the `"fitted"` column. (#14)
-* Added an `at` argument to `prediction()` methods. (#13)
-* Made `mean_or_mode()` and `median_or_mode()` S3 generics.
-* Fixed a bug in `mean_or_mode()` and `median_or_mode()` where incorrect factor levels were being returned.
-
-# prediction 0.1.12
-
-* Added `prediction.princomp()` method for "princomp" objects from **stats**. (#1)
-* Added `prediction.ppr()` method for "ppr" objects from **stats**. (#1)
-* Added `prediction.naiveBayes()` method for "naiveBayes" objects from **e1071**. (#1)
-* Added `prediction.rlm()` method for "rlm" objects from **MASS**. (#1)
-* Added `prediction.qda()` method for "qda" objects from **MASS**. (#1)
-* Added `prediction.lda()` method for "lda" objects from **MASS**. (#1)
-* `find_data()` now respects the `subset` argument in an original model call. (#15)
-* `find_data()` now respects the `na.action` argument in an original model call. (#15)
-* `find_data()` now gracefully fails when a model is specified without a formula. (#16)
-* `prediction()` methods no longer add a "fit" or "se.fit" class to any columns. Fitted values are identifiable by the column name only.
-
-# prediction 0.1.11
-
-* `build_datalist()` now returns `at` value combinations as a list.
-
-# prediction 0.1.10
-
-* Added `prediction.nnet()` method for "nnet" and "multinom" objects from **nnet**. (#1)
-
-# prediction 0.1.9
-
-* `prediction()` methods now return the value of `data` as part of the response data frame. (#8, h/t Ben Whalley)
-* Slight change to `find_data()` methods for `"crch"` and `"hxlr"`. (#5)
-* Added `prediction.glmx()` and `prediction.hetglm()` methods for "glmx" and "hetglm" objects from **glmx**. (#1)
-* Added `prediction.betareg()` method for "betareg" objects from **betareg**. (#1)
-* Added `prediction.rq()` method for "rq" objects from **quantreg**. (#1)
-* Added `prediction.gam()` method for "gam" objects from **gam**. (#1)
-* Expanded basic test suite.
-
-# prediction 0.1.8
-
-* Added `prediction()` and `find_data()` methods for `"crch"` `"hxlr"` objects from **crch**. (#4, h/t Carl Ganz)
-
-# prediction 0.1.7
-
-* Added `prediction()` and `find_data()` methods for `"merMod"` objects from **lme4**. (#1)
-
-# prediction 0.1.6
-
-* Moved the `seq_range()` function from **margins** to **prediction**.
-* Moved the `build_datalist()` function from **margins** to **prediction**. This will simplify the ability to calculate arbitrary predictions.
-
-# prediction 0.1.5
-
-* Added `prediction.svm()` method for objects of class `"svm"` from **e1071**. (#1)
-* Fixed a bug in `prediction.polr()` when attempting to pass a `type` argument, which is always ignored. A warning is now issued when attempting to override this.
-
-# prediction 0.1.4
-
-* Added `mean_or_mode()` and `median_or_mode()` functions, which provide a simple way to aggregate a variable of factor or numeric type. (#3)
-* Added `prediction()` methods for various time-series model classes: "ar", "arima0", and "Arima".
-
-# prediction 0.1.3
-
-* `find_data()` is now a generic, methods for "lm", "glm", and "svyglm" classes. (#2, h/t Carl Ganz)
-
-# prediction 0.1.2
-
-* Added support for "svyglm" class from the **survey** package. (#1)
-* Added tentative support for "clm" class from the **ordinal** package. (#1)
-
-# prediction 0.1.0
-
-* Initial package released.
+## prediction 0.3.15
+
+* `build_datalist()` now works correctly with data.table datasets. (#34, #35, h/t Dan Schrage)
+* `build_datalist()` dropped factor levels when replacing a factor variable. (#39, h/t Tomasz Żółtak)
+* `find_data()` now respects `subset` and `na.actions` arguments for `svyglm()` models. (#37, h/t Tomasz Żółtak)
+
+## prediction 0.3.13
+
+* Fixed a bug in `prediction_glm` with the `data` argument (Issue #32).
+
+## prediction 0.3.12
+
+* Remove mnlogit dependency, as it has been removed from CRAN.
+
+## prediction 0.3.11
+
+* Remove bigFastLm dependency, as it has been removed from CRAN.
+
+## prediction 0.3.10
+
+* Added tests for `find_data()` and `prediction.lm()` to check for correct behavior in the presence of missing data (`na.action`) and `subset` arguments. (#28)
+
+## prediction 0.3.8
+
+* Provisional support for variances of average predictions for GLMs. (#17)
+* Added an example dataset, `margex`, borrowed from Stata's identically named data.
+
+## prediction 0.3.7
+
+* `summary(prediction(...))` now reports variances of average predictions, along with test statistics, p-values, and confidence intervals, where supported. (#17)
+* Added a function `prediction_summary()` which simply calls `summary(prediction(...))`.
+* All methods now return additional attributes.
+
+## prediction 0.3.6
+
+* Small fixes for failing CRAN checks. (#25)
+* Remove `prediction.bigglm()` method (from **biglm**) due to failing tests. (#25)
+
+## prediction 0.3.5
+
+* Fixed a bug that required specifying `stats::poly()` rather than just `poly()` in model formulae. (#22)
+
+## prediction 0.3.4
+
+* Added `prediction.glmnet()` method for "glmnet" objects from **glmnet**. (#1)
+
+## prediction 0.3.3
+
+* `prediction.merMod()` gains an `re.form` argument to pass forward to `predict.merMod()`.
+
+## prediction 0.3.2
+
+* Fix typo in "speedglm" that was overwriting "glm" method.
+
+## prediction 0.3.0
+
+* CRAN release.
+
+## prediction 0.2.11
+
+* Added `prediction.glmML()` method for "glimML" objects from **aod**. (#1)
+* Added `prediction.glmQL()` method for "glimQL" objects from **aod**. (#1)
+* Added `prediction.truncreg()` method for "truncreg" objects from **truncreg**. (#1)
+* Noted implicit support for "tobit" objects from **AER**. (#1)
+
+## prediction 0.2.10
+
+* Added `prediction.bruto()` method for "bruto" objects from **mda**. (#1)
+* Added `prediction.fda()` method for "fda" objects from **mda**. (#1)
+* Added `prediction.mars()` method for "mars" objects from **mda**. (#1)
+* Added `prediction.mda()` method for "mda" objects from **mda**. (#1)
+* Added `prediction.polyreg()` method for "polyreg" objects from **mda**. (#1)
+
+## prediction 0.2.9
+
+* Added `prediction.speedglm()` and `prediction.speedlm()` methods for "speedglm" and "speedlm" objects from **speedglm**. (#1)
+* Added `prediction.bigLm()` method for "bigLm" objects from **bigFastlm**. (#1)
+* Added `prediction.biglm()` and `prediction.bigglm()` methods for "biglm" and "bigglm" objects from **biglm**, including those based by `"ffdf"` from **ff**. (#1)
+
+## prediction 0.2.8
+
+* Changed internal behavior of `build_datalist()`. The function now returns an an `at_specification` attribute, which is a data frame representation of the `at` argument.
+
+## prediction 0.2.6
+
+* Due to a change in gam_1.15, `prediction.gam()` is now `prediction.Gam()` for "Gam" objects from **gam**. (#1)
+
+## prediction 0.2.6
+
+* Added `prediction.train()` method for "train" objects from **caret**. (#1)
+
+## prediction 0.2.5
+
+* The `at` argument in `build_datalist()` now accepts a data frame of combinations for limiting the set of levels.
+
+## prediction 0.2.3
+
+* Most `prediction()` methods gain a (experimental) `calculate_se` argument, which regulates whether to calculate standard errors for predictions. Setting to `FALSE` can improve performance if they are not needed.
+
+## prediction 0.2.3
+
+* `build_datalist()` gains an `as.data.frame` argument, which - if `TRUE` - returns a stacked data frame rather than a list. This argument is now used internally in most `prediction()` functions in an effort to improve performance. (#18)
+
+## prediction 0.2.2
+
+* Expanded test suite scope and fixed a few small bugs.
+* Added a `summary.prediction()` method to interact with the average predicted values that are printed when `at != NULL`.
+
+## prediction 0.2.1
+
+* Added `prediction.knnreg()` method for "knnreg" objects from **caret**. (#1)
+* Added `prediction.gausspr()` method for "gausspr" objects from **kernlab**. (#1)
+* Added `prediction.ksvm()` method for "ksvm" objects from **kernlab**. (#1)
+* Added `prediction.kqr()` method for "kqr" objects from **kernlab**. (#1)
+* Added `prediction.earth()` method for "earth" objects from **earth**. (#1)
+* Added `prediction.rpart()` method for "rpart" objects from **rpart**. (#1)
+
+## prediction 0.2.0
+
+* CRAN Release.
+* Added `mean_or_mode.data.frame()` and `median_or_mode.data.frame()` methods.
+
+## prediction 0.1.17
+
+* Added `prediction.zeroinfl()` method for "zeroinfl" objects from **pscl**. (#1)
+* Added `prediction.hurdle()` method for "hurdle" objects from **pscl**. (#1)
+* Added `prediction.lme()` method for "lme" and "nlme" objects from **nlme**. (#1)
+* Documented `prediction.merMod()`.
+
+## prediction 0.1.16
+
+* Added `prediction.plm()` method for "plm" objects from **plm**. (#1)
+
+## prediction 0.1.15
+
+* Expanded test suite considerably and updated `CONTRIBUTING.md` to reflect expected test-driven development.
+* A few small code tweaks and bug fixes resulting from the updated test suite.
+
+## prediction 0.1.14
+
+* Added `prediction.mnp()` method for "mnp" objects from **MNP**. (#1)
+* Added `prediction.mnlogit()` method for "mnlogit" objects from **mnlogit**. (#1)
+* Added `prediction.gee()` method for "gee" objects from **gee**. (#1)
+* Added `prediction.lqs()` method for "lqs" objects from **MASS**. (#1)
+* Added `prediction.mca()` method for "mca" objects from **MASS**. (#1)
+* Noted (built-in) support for "brglm" objects from **brglm** via the `prediction.glm()` method. (#1)
+
+## prediction 0.1.13
+
+* Added a `category` argument to `prediction()` methods for models of multilevel outcomes (e.g., ordered probit, etc.) to be dictate which level is expressed as the `"fitted"` column. (#14)
+* Added an `at` argument to `prediction()` methods. (#13)
+* Made `mean_or_mode()` and `median_or_mode()` S3 generics.
+* Fixed a bug in `mean_or_mode()` and `median_or_mode()` where incorrect factor levels were being returned.
+
+## prediction 0.1.12
+
+* Added `prediction.princomp()` method for "princomp" objects from **stats**. (#1)
+* Added `prediction.ppr()` method for "ppr" objects from **stats**. (#1)
+* Added `prediction.naiveBayes()` method for "naiveBayes" objects from **e1071**. (#1)
+* Added `prediction.rlm()` method for "rlm" objects from **MASS**. (#1)
+* Added `prediction.qda()` method for "qda" objects from **MASS**. (#1)
+* Added `prediction.lda()` method for "lda" objects from **MASS**. (#1)
+* `find_data()` now respects the `subset` argument in an original model call. (#15)
+* `find_data()` now respects the `na.action` argument in an original model call. (#15)
+* `find_data()` now gracefully fails when a model is specified without a formula. (#16)
+* `prediction()` methods no longer add a "fit" or "se.fit" class to any columns. Fitted values are identifiable by the column name only.
+
+## prediction 0.1.11
+
+* `build_datalist()` now returns `at` value combinations as a list.
+
+## prediction 0.1.10
+
+* Added `prediction.nnet()` method for "nnet" and "multinom" objects from **nnet**. (#1)
+
+## prediction 0.1.9
+
+* `prediction()` methods now return the value of `data` as part of the response data frame. (#8, h/t Ben Whalley)
+* Slight change to `find_data()` methods for `"crch"` and `"hxlr"`. (#5)
+* Added `prediction.glmx()` and `prediction.hetglm()` methods for "glmx" and "hetglm" objects from **glmx**. (#1)
+* Added `prediction.betareg()` method for "betareg" objects from **betareg**. (#1)
+* Added `prediction.rq()` method for "rq" objects from **quantreg**. (#1)
+* Added `prediction.gam()` method for "gam" objects from **gam**. (#1)
+* Expanded basic test suite.
+
+## prediction 0.1.8
+
+* Added `prediction()` and `find_data()` methods for `"crch"` `"hxlr"` objects from **crch**. (#4, h/t Carl Ganz)
+
+## prediction 0.1.7
+
+* Added `prediction()` and `find_data()` methods for `"merMod"` objects from **lme4**. (#1)
+
+## prediction 0.1.6
+
+* Moved the `seq_range()` function from **margins** to **prediction**.
+* Moved the `build_datalist()` function from **margins** to **prediction**. This will simplify the ability to calculate arbitrary predictions.
+
+## prediction 0.1.5
+
+* Added `prediction.svm()` method for objects of class `"svm"` from **e1071**. (#1)
+* Fixed a bug in `prediction.polr()` when attempting to pass a `type` argument, which is always ignored. A warning is now issued when attempting to override this.
+
+## prediction 0.1.4
+
+* Added `mean_or_mode()` and `median_or_mode()` functions, which provide a simple way to aggregate a variable of factor or numeric type. (#3)
+* Added `prediction()` methods for various time-series model classes: "ar", "arima0", and "Arima".
+
+## prediction 0.1.3
+
+* `find_data()` is now a generic, methods for "lm", "glm", and "svyglm" classes. (#2, h/t Carl Ganz)
+
+## prediction 0.1.2
+
+* Added support for "svyglm" class from the **survey** package. (#1)
+* Added tentative support for "clm" class from the **ordinal** package. (#1)
+
+## prediction 0.1.0
+
+* Initial package released.
diff --git a/R/build_datalist.R b/R/build_datalist.R
index 61ac7f8..23aed3c 100644
--- a/R/build_datalist.R
+++ b/R/build_datalist.R
@@ -1,146 +1,170 @@
-#' @title Build list of data.frames
-#' @description Construct a list of data.frames based upon an input data.frame and a list of one or more \code{at} values
-#' @param data A data.frame containing the original data.
-#' @param at A list of one or more named vectors of values, which will be used to specify values of variables in \code{data}. All possible combinations are generated. Alternatively, this can be a data frame of combination levels if only a subset of combinations are desired. See examples.
-#' @param as.data.frame A logical indicating whether to return a single stacked data frame rather than a list of data frames
-#' @param \dots Ignored.
-#' @return A list of data.frames, unless \code{as.data.frame = TRUE} in which case a single, stacked data frame is returned.
-#' @author Thomas J. Leeper
-#' @examples
-#' # basic examples
-#' require("datasets")
-#' build_datalist(head(mtcars), at = list(cyl = c(4, 6)))
-#'
-#' str(build_datalist(head(mtcars), at = list(cyl = c(4,6), wt = c(2.75,3,3.25))), 1)
-#'
-#' str(build_datalist(head(mtcars), at = data.frame(cyl = c(4,4), wt = c(2.75,3))))
-#'
-#' @keywords data manip
-#' @seealso \code{\link{find_data}}, \code{\link{mean_or_mode}}, \code{\link{seq_range}}
-#' @importFrom data.table rbindlist
-#' @export
-build_datalist <-
-function(data,
- at = NULL,
- as.data.frame = FALSE,
- ...){
-
- # check for `at` specification and `as.data.frame` arguments
- if (!is.null(at) && length(at) > 0) {
- # check `at` specification against data
- check_at(data, at)
-
- # setup list of data.frames based on at
- data_out <- set_data_to_at(data, at = at)
- at_specification <- cbind(index = seq_len(nrow(data_out[["at"]])), data_out[["at"]])
- data_out <- data_out[["data"]]
-
- if (isTRUE(as.data.frame)) {
- data_out <- data.table::rbindlist(data_out)
- }
-
- } else if (isTRUE(as.data.frame)) {
- # if `at` empty and `as.data.frame = TRUE`, simply return original data
- data_out <- data
- at_specification <- NULL
- } else {
- # if `at` empty, simply setup data.frame and return
- data_out <- list(data)
- at_specification <- NULL
- }
- return(structure(data_out, at_specification = at_specification))
-}
-
-check_at <- function(data, at) {
- # check names of `at`
- check_at_names(names(data), at)
-
- # check factor levels specified in `at`
- check_factor_levels(data, at)
-
- # check values of numeric values are interpolations
- check_values(data, at)
-}
-
-check_factor_levels <- function(data, at) {
- # function to check whether factor levels in `at` are reasonable
- levels <- lapply(data, function(v) {
- if (is.factor(v)) {
- levels(v)
- } else if (is.character(v)) {
- levels(factor(v))
- } else {
- NULL
- }
- })
- levels <- levels[!sapply(levels, is.null)]
- at <- at[names(at) %in% names(levels)]
- for (i in seq_along(at)) {
- atvals <- as.character(at[[i]])
- x <- atvals %in% levels[[names(at)[i]]]
- if (!all(x)) {
- stop(paste0("Illegal factor levels for variable '", names(at)[i], "': ",
- paste0(shQuote(atvals[!x]), collapse = ", ")),
- call. = FALSE)
- }
- }
- invisible(NULL)
-}
-
-check_values <- function(data, at) {
- # drop variables not in `at`
- dat <- data[, names(at), drop = FALSE]
-
- # drop non-numeric variables from `dat` and `at`
- not_numeric <- !sapply(dat, class) %in% c("character", "factor", "ordered", "logical")
- at <- at[names(at) %in% names(dat)[not_numeric]]
- dat <- dat[, not_numeric, drop = FALSE]
-
- if (length(dat) > 0 & length(at) > 0) {
- # calculate variable ranges
- limits <- do.call(rbind, lapply(dat, range, na.rm = TRUE))
- rownames(limits) <- names(dat)
-
- # check ranges
- for (i in seq_along(at)) {
- out <- (at[[i]] < limits[names(at)[i],1]) | (at[[i]] > limits[names(at)[i],2])
- if (any( out ) ) {
- datarange <- paste0("outside observed data range (", limits[names(at)[i],1], ",", limits[names(at)[i],2], ")!")
- warning(ngettext(sum(out), paste0("A 'at' value for '", names(at)[i], "' is ", datarange),
- paste0("Some 'at' values for '", names(at)[i], "' are ", datarange)))
- }
- }
- }
-}
-
-check_at_names <- function(namevec, at) {
- if (is.null(namevec)) {
- return()
- }
- if (is.null(names(at)) || any(names(at) == "")) {
- stop("'at' contains unnamed list elements")
- }
- b <- !names(at) %in% namevec
- if (any(b)) {
- e <- ngettext(sum(b), "Unrecognized variable name in 'at': ", "Unrecognized variable names in 'at': ")
- stop(paste0(e, paste0("(", which(b), ") ", gsub("", "<empty>", names(at)[b]), collapse = ", ")))
- }
-}
-
-# data.frame builder, given specified `at` values
-## returns the `at` combination as a data frame
-set_data_to_at <- function(data, at = NULL) {
- # expand `at` combinations
- if (inherits(at, "data.frame")) {
- expanded <- at
- } else {
- expanded <- expand.grid(at, KEEP.OUT.ATTRS = FALSE)
- }
- e <- split(expanded, unique(expanded))
- data_out <- lapply(e, function(atvals) {
- dat <- data
- dat <- `[<-`(dat, , names(atvals), value = atvals)
- structure(dat, at = as.list(atvals))
- })
- return(list(data = data_out, at = expanded))
-}
+#' @title Build list of data.frames
+#' @description Construct a list of data.frames based upon an input data.frame and a list of one or more \code{at} values
+#' @param data A data.frame containing the original data.
+#' @param at A list of one or more named vectors of values, which will be used to specify values of variables in \code{data}. All possible combinations are generated. Alternatively, this can be a data frame of combination levels if only a subset of combinations are desired. See examples.
+#' @param as.data.frame A logical indicating whether to return a single stacked data frame rather than a list of data frames
+#' @param \dots Ignored.
+#' @return A list of data.frames, unless \code{as.data.frame = TRUE} in which case a single, stacked data frame is returned.
+#' @author Thomas J. Leeper
+#' @examples
+#' # basic examples
+#' require("datasets")
+#' build_datalist(head(mtcars), at = list(cyl = c(4, 6)))
+#'
+#' str(build_datalist(head(mtcars), at = list(cyl = c(4,6), wt = c(2.75,3,3.25))), 1)
+#'
+#' str(build_datalist(head(mtcars), at = data.frame(cyl = c(4,4), wt = c(2.75,3))))
+#'
+#' @keywords data manip
+#' @seealso \code{\link{find_data}}, \code{\link{mean_or_mode}}, \code{\link{seq_range}}
+#' @importFrom data.table rbindlist
+#' @export
+build_datalist <-
+function(data,
+ at = NULL,
+ as.data.frame = FALSE,
+ ...){
+
+ # check for `at` specification and `as.data.frame` arguments
+ if (!is.null(at) && length(at) > 0) {
+ # check `at` specification against data
+ check_at(data, at)
+
+ # setup list of data.frames based on at
+ data_out <- set_data_to_at(data, at = at)
+ at_specification <- cbind(index = seq_len(nrow(data_out[["at"]])), data_out[["at"]])
+ data_out <- data_out[["data"]]
+
+ if (isTRUE(as.data.frame)) {
+ data_out <- data.table::rbindlist(data_out)
+ }
+
+ } else if (isTRUE(as.data.frame)) {
+ # if `at` empty and `as.data.frame = TRUE`, simply return original data
+ data_out <- data
+ at_specification <- NULL
+ } else {
+ # if `at` empty, simply setup data.frame and return
+ data_out <- list(data)
+ at_specification <- NULL
+ }
+ return(structure(data_out, at_specification = at_specification))
+}
+
+check_at <- function(data, at) {
+ # check names of `at`
+ check_at_names(names(data), at)
+
+ # check factor levels specified in `at`
+ check_factor_levels(data, at)
+
+ # check values of numeric values are interpolations
+ check_values(data, at)
+}
+
+check_factor_levels <- function(data, at) {
+ # function to check whether factor levels in `at` are reasonable
+ levels <- lapply(data, function(v) {
+ if (is.factor(v)) {
+ levels(v)
+ } else if (is.character(v)) {
+ levels(factor(v))
+ } else {
+ NULL
+ }
+ })
+ levels <- levels[!sapply(levels, is.null)]
+ at <- at[names(at) %in% names(levels)]
+ for (i in seq_along(at)) {
+ atvals <- as.character(at[[i]])
+ x <- atvals %in% levels[[names(at)[i]]]
+ if (!all(x)) {
+ stop(paste0("Illegal factor levels for variable '", names(at)[i], "': ",
+ paste0(shQuote(atvals[!x]), collapse = ", ")),
+ call. = FALSE)
+ }
+ }
+ invisible(NULL)
+}
+
+check_values <- function(data, at) {
+ # drop variables not in `at`
+ if (inherits(data, "data.table")) {
+ dat <- data[, names(at), with = FALSE]
+ } else {
+ dat <- data[names(at)]
+ }
+
+ # drop non-numeric variables from `dat` and `at`
+ not_numeric <- !sapply(dat, class) %in% c("character", "factor", "ordered", "logical")
+ at <- at[names(at) %in% names(dat)[not_numeric]]
+ if (inherits(dat, "data.table")) {
+ dat <- dat[, which(not_numeric), with = FALSE]
+ } else {
+ dat <- dat[, not_numeric, drop = FALSE]
+ }
+
+ if (length(dat) > 0 & length(at) > 0) {
+ # calculate variable ranges
+ limits <- do.call(rbind, lapply(dat, range, na.rm = TRUE))
+ rownames(limits) <- names(dat)
+
+ # check ranges
+ for (i in seq_along(at)) {
+ out <- (at[[i]] < limits[names(at)[i],1]) | (at[[i]] > limits[names(at)[i],2])
+ if (any( out ) ) {
+ datarange <- paste0("outside observed data range (", limits[names(at)[i],1], ",", limits[names(at)[i],2], ")!")
+ warning(ngettext(sum(out), paste0("A 'at' value for '", names(at)[i], "' is ", datarange),
+ paste0("Some 'at' values for '", names(at)[i], "' are ", datarange)))
+ }
+ }
+ }
+}
+
+check_at_names <- function(namevec, at) {
+ if (is.null(namevec)) {
+ return()
+ }
+ if (is.null(names(at)) || any(names(at) == "")) {
+ stop("'at' contains unnamed list elements")
+ }
+ b <- !names(at) %in% namevec
+ if (any(b)) {
+ e <- ngettext(sum(b), "Unrecognized variable name in 'at': ", "Unrecognized variable names in 'at': ")
+ stop(paste0(e, paste0("(", which(b), ") ", gsub("", "<empty>", names(at)[b]), collapse = ", ")))
+ }
+}
+
+# data.frame builder, given specified `at` values
+## returns the `at` combination as a data frame
+set_data_to_at <- function(data, at = NULL) {
+ # expand `at` combinations
+ if (inherits(at, "data.frame")) {
+ expanded <- at
+ } else {
+ expanded <- expand.grid(at, KEEP.OUT.ATTRS = FALSE)
+ }
+ e <- split(expanded, unique(expanded))
+ data_out <- lapply(e, function(atvals) {
+ dat <- data
+ for (i in seq_along(atvals)) {
+ is_factor <- inherits(dat[[names(atvals)[i]]], "factor")
+ if (is_factor) {
+ levs <- levels(dat[[names(atvals)[i]]])
+ if (inherits(dat, "data.table")) {
+ dat[, names(atvals)[i]] <- factor(atvals[[i]], levels = levs)
+ } else {
+ dat[names(atvals)[i]] <- factor(atvals[[i]], levels = levs)
+ }
+ } else{
+ if (inherits(dat, "data.table")) {
+ dat[, names(atvals)[i]] <- atvals[[i]]
+ } else {
+ dat[names(atvals)[i]] <- atvals[[i]]
+ }
+ }
+ }
+ structure(dat, at = as.list(atvals))
+ })
+ return(list(data = data_out, at = expanded))
+}
diff --git a/R/find_data.R b/R/find_data.R
index 6f6c9d7..a9d1e6a 100644
--- a/R/find_data.R
+++ b/R/find_data.R
@@ -1,131 +1,148 @@
-#' @rdname find_data
-#' @title Extract data from a model object
-#' @description Attempt to reconstruct the data used to create a model object
-#' @param model The model object.
-#' @param \dots Additional arguments passed to methods.
-#' @param env An environment in which to look for the \code{data} argument to the modelling call.
-#' @details This is a convenience function and, as such, carries no guarantees. To behave well, it typically requires that a model object be specified using a formula interface and an explicit \code{data} argument. Models that can be specified using variables from the \code{.GlobalEnv} or with a non-formula interface (e.g., a matrix of data) will tend to generate errors. \code{find_data} is an S3 generic so it is possible to expand it with new methods.
-#' @return A data frame containing the original data used in a modelling call, modified according to the original model's `subset` and `na.action` arguments, if appropriate.
-#' @examples
-#' require("datasets")
-#' x <- lm(mpg ~ cyl * hp + wt, data = head(mtcars))
-#' find_data(x)
-#'
-#' @seealso \code{\link{prediction}}, \code{\link{build_datalist}}, \code{\link{mean_or_mode}}, \code{\link{seq_range}}
-#' @export
-find_data <- function(model, ...) {
- UseMethod("find_data")
-}
-
-#' @rdname find_data
-#' @importFrom stats terms
-#' @export
-find_data.default <- function(model, env = parent.frame(), ...) {
- form <- try(terms(model), silent = TRUE)
- if (inherits(form, "try-error") && is.null(model[["call"]])) {
- stop("'find_data()' requires a formula call")
- } else {
- if (!is.null(model[["call"]][["data"]])) {
- dat <- eval(model[["call"]][["data"]], env)
- if (inherits(dat, "try-error")) {
- dat <- get_all_vars(model, data = model[["call"]][["data"]])
- }
- } else {
- dat <- get_all_vars(model, data = env)
- }
- # handle subset
- if (!is.null(model[["call"]][["subset"]])) {
- subs <- try(eval(model[["call"]][["subset"]], dat), silent = TRUE)
- if (inherits(subs, "try-error")) {
- subs <- try(eval(model[["call"]][["subset"]], env), silent = TRUE)
- if (inherits(subs, "try-error")) {
- subs <- TRUE
- warning("'find_data()' cannot locate variable(s) used in 'subset'")
- }
- }
- dat <- dat[subs, , drop = FALSE]
- }
- # handle na.action
- if (!is.null(model[["na.action"]])) {
- dat <- dat[-model[["na.action"]], , drop = FALSE]
- }
- }
- if (is.null(dat)) {
- stop("'find_data()' requires a formula call")
- }
- dat
-}
-
-#' @rdname find_data
-#' @export
-find_data.data.frame <- function(model, ...) {
- model
-}
-
-#' @rdname find_data
-#' @export
-find_data.crch <- find_data.default
-
-#' @rdname find_data
-#' @export
-find_data.glimML <- function(model, ...) {
- requireNamespace("methods", quietly = TRUE)
- methods::slot(model, "data")
-}
-
-find_data.glimQL <- function(model, env = parent.frame(), ...) {
- requireNamespace("methods", quietly = TRUE)
- methods::slot(model, "fm")$data
-}
-
-#' @rdname find_data
-#' @export
-find_data.glm <- find_data.default
-
-#' @rdname find_data
-#' @export
-find_data.hxlr <- find_data.default
-
-#' @rdname find_data
-#' @export
-find_data.lm <- find_data.default
-
-#' @rdname find_data
-#' @export
-find_data.mca <- function(model, env = parent.frame(), ...) {
- eval(model[["call"]][["df"]], envir = env)
-}
-
-#' @rdname find_data
-#' @importFrom stats model.frame
-#' @export
-find_data.merMod <- function(model, env = parent.frame(), ...) {
- model.frame(model)
-}
-
-#' @rdname find_data
-#' @export
-find_data.svyglm <- function(model, ...) {
- data <- model[["data"]]
- data
-}
-
-#' @rdname find_data
-#' @export
-find_data.train <- function(model, ...) {
- model[["trainingData"]]
-}
-
-#' @rdname find_data
-#' @export
-find_data.vgam <- function(model, env = parent.frame(), ...) {
- if (!requireNamespace("methods")) {
- stop("'find_data.vgam()' requires the 'methods' package")
- }
- dat <- methods::slot(model, "misc")[["dataname"]]
- get(dat, envir = env)
-}
-
-#' @rdname find_data
-#' @export
-find_data.vglm <- find_data.vgam
+#' @rdname find_data
+#' @title Extract data from a model object
+#' @description Attempt to reconstruct the data used to create a model object
+#' @param model The model object.
+#' @param \dots Additional arguments passed to methods.
+#' @param env An environment in which to look for the \code{data} argument to the modelling call.
+#' @details This is a convenience function and, as such, carries no guarantees. To behave well, it typically requires that a model object be specified using a formula interface and an explicit \code{data} argument. Models that can be specified using variables from the \code{.GlobalEnv} or with a non-formula interface (e.g., a matrix of data) will tend to generate errors. \code{find_data} is an S3 generic so it is possible to expand it with new methods.
+#' @return A data frame containing the original data used in a modelling call, modified according to the original model's `subset` and `na.action` arguments, if appropriate.
+#' @examples
+#' require("datasets")
+#' x <- lm(mpg ~ cyl * hp + wt, data = head(mtcars))
+#' find_data(x)
+#'
+#' @seealso \code{\link{prediction}}, \code{\link{build_datalist}}, \code{\link{mean_or_mode}}, \code{\link{seq_range}}
+#' @export
+find_data <- function(model, ...) {
+ UseMethod("find_data")
+}
+
+#' @rdname find_data
+#' @importFrom stats terms
+#' @export
+find_data.default <- function(model, env = parent.frame(), ...) {
+ form <- try(terms(model), silent = TRUE)
+ if (inherits(form, "try-error") && is.null(model[["call"]])) {
+ stop("'find_data()' requires a formula call")
+ } else {
+ if (!is.null(model[["call"]][["data"]])) {
+ dat <- eval(model[["call"]][["data"]], env)
+ if (inherits(dat, "try-error")) {
+ dat <- get_all_vars(model, data = model[["call"]][["data"]])
+ }
+ } else {
+ dat <- get_all_vars(model, data = env)
+ }
+ # handle subset
+ if (!is.null(model[["call"]][["subset"]])) {
+ subs <- try(eval(model[["call"]][["subset"]], dat), silent = TRUE)
+ if (inherits(subs, "try-error")) {
+ subs <- try(eval(model[["call"]][["subset"]], env), silent = TRUE)
+ if (inherits(subs, "try-error")) {
+ subs <- TRUE
+ warning("'find_data()' cannot locate variable(s) used in 'subset'")
+ }
+ }
+ dat <- dat[subs, , drop = FALSE]
+ }
+ # handle na.action
+ if (!is.null(model[["na.action"]])) {
+ dat <- dat[-model[["na.action"]], , drop = FALSE]
+ }
+ }
+ if (is.null(dat)) {
+ stop("'find_data()' requires a formula call")
+ }
+ dat
+}
+
+#' @rdname find_data
+#' @export
+find_data.data.frame <- function(model, ...) {
+ model
+}
+
+#' @rdname find_data
+#' @export
+find_data.crch <- find_data.default
+
+#' @rdname find_data
+#' @export
+find_data.glimML <- function(model, ...) {
+ requireNamespace("methods", quietly = TRUE)
+ methods::slot(model, "data")
+}
+
+find_data.glimQL <- function(model, env = parent.frame(), ...) {
+ requireNamespace("methods", quietly = TRUE)
+ methods::slot(model, "fm")$data
+}
+
+#' @rdname find_data
+#' @export
+find_data.glm <- find_data.default
+
+#' @rdname find_data
+#' @export
+find_data.hxlr <- find_data.default
+
+#' @rdname find_data
+#' @export
+find_data.lm <- find_data.default
+
+#' @rdname find_data
+#' @export
+find_data.mca <- function(model, env = parent.frame(), ...) {
+ eval(model[["call"]][["df"]], envir = env)
+}
+
+#' @rdname find_data
+#' @importFrom stats model.frame
+#' @export
+find_data.merMod <- function(model, env = parent.frame(), ...) {
+ model.frame(model)
+}
+
+#' @rdname find_data
+#' @export
+find_data.svyglm <- function(model, env = parent.frame(), ...) {
+ dat <- model[["data"]]
+ # handle subset
+ if (!is.null(model[["call"]][["subset"]])) {
+ subs <- try(eval(model[["call"]][["subset"]], dat), silent = TRUE)
+ if (inherits(subs, "try-error")) {
+ subs <- try(eval(model[["call"]][["subset"]], env), silent = TRUE)
+ if (inherits(subs, "try-error")) {
+ subs <- TRUE
+ warning("'find_data()' cannot locate variable(s) used in 'subset'")
+ }
+ }
+ dat <- dat[subs, , drop = FALSE]
+ }
+ # handle na.action
+ if (!is.null(model[["na.action"]])) {
+ dat <- dat[-model[["na.action"]], , drop = FALSE]
+ }
+
+ return(dat)
+}
+
+#' @rdname find_data
+#' @export
+find_data.train <- function(model, ...) {
+ model[["trainingData"]]
+}
+
+#' @rdname find_data
+#' @export
+find_data.vgam <- function(model, env = parent.frame(), ...) {
+ if (!requireNamespace("methods")) {
+ stop("'find_data.vgam()' requires the 'methods' package")
+ }
+ dat <- methods::slot(model, "misc")[["dataname"]]
+ get(dat, envir = env)
+}
+
+#' @rdname find_data
+#' @export
+find_data.vglm <- find_data.vgam
diff --git a/R/make_data_frame.R b/R/make_data_frame.R
index 9da6553..7e21d0d 100644
--- a/R/make_data_frame.R
+++ b/R/make_data_frame.R
@@ -1,4 +1,4 @@
-# internal function that overrides the defaults of `data.frame()`
-make_data_frame <- function(...) {
- data.frame(..., check.rows = FALSE, check.names = FALSE, fix.empty.names = FALSE, stringsAsFactors = FALSE)
-}
+# internal function that overrides the defaults of `data.frame()`
+make_data_frame <- function(...) {
+ data.frame(..., check.rows = FALSE, check.names = FALSE, fix.empty.names = FALSE, stringsAsFactors = FALSE)
+}
diff --git a/R/margex.R b/R/margex.R
index ab2fc0b..7169129 100644
--- a/R/margex.R
+++ b/R/margex.R
@@ -1,76 +1,76 @@
-#' @rdname margex
-#' @docType data
-#' @title Artificial data for margins, copied from Stata
-#' @description The dataset is identical to the one provided by Stata and available from \code{webuse::webuse("margex")} with categorical variables explicitly encoded as factors.
-#' @format A data frame with 3000 observations on the following 11 variables.
-#' \describe{
-#' \item{\samp{y}}{A numeric vector}
-#' \item{\samp{outcome}}{A binary numeric vector with values (0,1)}
-#' \item{\samp{sex}}{A factor with two levels}
-#' \item{\samp{group}}{A factor with three levels}
-#' \item{\samp{age}}{A numeric vector}
-#' \item{\samp{distance}}{A numeric vector}
-#' \item{\samp{ycn}}{A numeric vector}
-#' \item{\samp{yc}}{A numeric vector}
-#' \item{\samp{treatment}}{A factor with two levels}
-#' \item{\samp{agegroup}}{A factor with three levels}
-#' \item{\samp{arm}}{A factor with three levels}
-#' }
-#' @source \url{http://www.stata-press.com/data/r14/margex.dta}
-#' @examples
-#' \donttest{
-#'
-#' # Examples from Stata's help files
-#' # Also available from: webuse::webuse("margex")
-#' data("margex")
-#'
-#' # A simple case after regress
-#' # . regress y i.sex i.group
-#' # . margins sex
-#' m1 <- lm(y ~ factor(sex) + factor(group), data = margex)
-#' prediction(m1, at = list(sex = c("male", "female")))
-#'
-#' # A simple case after logistic
-#' # . logistic outcome i.sex i.group
-#' # . margins sex
-#' m2 <- glm(outcome ~ sex + group, binomial(), data = margex)
-#' prediction(m2, at = list(sex = c("male", "female")))
-#'
-#' # Average response versus response at average
-#' # . margins sex
-#' prediction(m2, at = list(sex = c("male", "female")))
-#' # . margins sex, atmeans
-#' ## TODO
-#'
-#' # Multiple margins from one margins command
-#' # . margins sex group
-#' prediction(m2, at = list(sex = c("male", "female")))
-#' prediction(m2, at = list(group = c("1", "2", "3")))
-#'
-#' # Margins with interaction terms
-#' # . logistic outcome i.sex i.group sex#group
-#' # . margins sex group
-#' m3 <- glm(outcome ~ sex * group, binomial(), data = margex)
-#' prediction(m3, at = list(sex = c("male", "female")))
-#' prediction(m3, at = list(group = c("1", "2", "3")))
-#'
-#' # Margins with continuous variables
-#' # . logistic outcome i.sex i.group sex#group age
-#' # . margins sex group
-#' m4 <- glm(outcome ~ sex * group + age, binomial(), data = margex)
-#' prediction(m4, at = list(sex = c("male", "female")))
-#' prediction(m4, at = list(group = c("1", "2", "3")))
-#'
-#' # Margins of continuous variables
-#' # . margins, at(age=40)
-#' prediction(m4, at = list(age = 40))
-#' # . margins, at(age=(30 35 40 45 50))
-#' prediction(m4, at = list(age = c(30, 35, 40, 45, 50)))
-#'
-#' # Margins of interactions
-#' # . margins sex#group
-#' prediction(m4, at = list(sex = c("male", "female"), group = c("1", "2", "3")))
-#'
-#' }
-#' @seealso \code{\link{prediction}}
-"margex"
+#' @rdname margex
+#' @docType data
+#' @title Artificial data for margins, copied from Stata
+#' @description The dataset is identical to the one provided by Stata and available from \code{webuse::webuse("margex")} with categorical variables explicitly encoded as factors.
+#' @format A data frame with 3000 observations on the following 11 variables.
+#' \describe{
+#' \item{\samp{y}}{A numeric vector}
+#' \item{\samp{outcome}}{A binary numeric vector with values (0,1)}
+#' \item{\samp{sex}}{A factor with two levels}
+#' \item{\samp{group}}{A factor with three levels}
+#' \item{\samp{age}}{A numeric vector}
+#' \item{\samp{distance}}{A numeric vector}
+#' \item{\samp{ycn}}{A numeric vector}
+#' \item{\samp{yc}}{A numeric vector}
+#' \item{\samp{treatment}}{A factor with two levels}
+#' \item{\samp{agegroup}}{A factor with three levels}
+#' \item{\samp{arm}}{A factor with three levels}
+#' }
+#' @source \url{http://www.stata-press.com/data/r14/margex.dta}
+#' @examples
+#' \donttest{
+#'
+#' # Examples from Stata's help files
+#' # Also available from: webuse::webuse("margex")
+#' data("margex")
+#'
+#' # A simple case after regress
+#' # . regress y i.sex i.group
+#' # . margins sex
+#' m1 <- lm(y ~ factor(sex) + factor(group), data = margex)
+#' prediction(m1, at = list(sex = c("male", "female")))
+#'
+#' # A simple case after logistic
+#' # . logistic outcome i.sex i.group
+#' # . margins sex
+#' m2 <- glm(outcome ~ sex + group, binomial(), data = margex)
+#' prediction(m2, at = list(sex = c("male", "female")))
+#'
+#' # Average response versus response at average
+#' # . margins sex
+#' prediction(m2, at = list(sex = c("male", "female")))
+#' # . margins sex, atmeans
+#' ## TODO
+#'
+#' # Multiple margins from one margins command
+#' # . margins sex group
+#' prediction(m2, at = list(sex = c("male", "female")))
+#' prediction(m2, at = list(group = c("1", "2", "3")))
+#'
+#' # Margins with interaction terms
+#' # . logistic outcome i.sex i.group sex#group
+#' # . margins sex group
+#' m3 <- glm(outcome ~ sex * group, binomial(), data = margex)
+#' prediction(m3, at = list(sex = c("male", "female")))
+#' prediction(m3, at = list(group = c("1", "2", "3")))
+#'
+#' # Margins with continuous variables
+#' # . logistic outcome i.sex i.group sex#group age
+#' # . margins sex group
+#' m4 <- glm(outcome ~ sex * group + age, binomial(), data = margex)
+#' prediction(m4, at = list(sex = c("male", "female")))
+#' prediction(m4, at = list(group = c("1", "2", "3")))
+#'
+#' # Margins of continuous variables
+#' # . margins, at(age=40)
+#' prediction(m4, at = list(age = 40))
+#' # . margins, at(age=(30 35 40 45 50))
+#' prediction(m4, at = list(age = c(30, 35, 40, 45, 50)))
+#'
+#' # Margins of interactions
+#' # . margins sex#group
+#' prediction(m4, at = list(sex = c("male", "female"), group = c("1", "2", "3")))
+#'
+#' }
+#' @seealso \code{\link{prediction}}
+"margex"
diff --git a/R/mean_or_mode.R b/R/mean_or_mode.R
index 03baa74..b6ba543 100644
--- a/R/mean_or_mode.R
+++ b/R/mean_or_mode.R
@@ -1,69 +1,69 @@
-#' @rdname mean_or_mode
-#' @title Class-dependent variable aggregation
-#' @description Summarize a vector/variable into a single number, either a mean (median) for numeric vectors or the mode for categorical (character, factor, ordered, or logical) vectors. Useful for aggregation.
-#' @param x A vector.
-#' @return A numeric or factor vector of length 1.
-#' @examples
-#' require("datasets")
-#' # mean for numerics
-#' mean_or_mode(iris)
-#' mean_or_mode(iris[["Sepal.Length"]])
-#' mean_or_mode(iris[["Species"]])
-#'
-#' # median for numerics
-#' median_or_mode(iris)
-#'
-#' @seealso \code{\link{prediction}}, \code{\link{build_datalist}}, \code{\link{seq_range}}
-#' @import stats
-#' @export
-mean_or_mode <- function(x) {
- UseMethod("mean_or_mode")
-}
-
-#' @rdname mean_or_mode
-#' @export
-mean_or_mode.default <- function(x) {
- if (!is.factor(x)) {
- x <- as.factor(x)
- }
- factor(names(sort(table(x), decreasing = TRUE))[1L], levels = levels(x))
-}
-
-#' @rdname mean_or_mode
-#' @export
-mean_or_mode.numeric <- function(x) {
- mean(x, na.rm = TRUE)
-}
-
-#' @rdname mean_or_mode
-#' @export
-mean_or_mode.data.frame <- function(x) {
- setNames(lapply(x, mean_or_mode), names(x))
-}
-
-#' @rdname mean_or_mode
-#' @export
-median_or_mode <- function(x) {
- UseMethod("median_or_mode")
-}
-
-#' @rdname mean_or_mode
-#' @export
-median_or_mode.default <- function(x) {
- if (!is.factor(x)) {
- x <- as.factor(x)
- }
- factor(names(sort(table(x), decreasing = TRUE))[1L], levels = levels(x))
-}
-
-#' @rdname mean_or_mode
-#' @export
-median_or_mode.numeric <- function(x) {
- median(x, na.rm = TRUE)
-}
-
-#' @rdname mean_or_mode
-#' @export
-median_or_mode.data.frame <- function(x) {
- setNames(lapply(x, median_or_mode), names(x))
-}
+#' @rdname mean_or_mode
+#' @title Class-dependent variable aggregation
+#' @description Summarize a vector/variable into a single number, either a mean (median) for numeric vectors or the mode for categorical (character, factor, ordered, or logical) vectors. Useful for aggregation.
+#' @param x A vector.
+#' @return A numeric or factor vector of length 1.
+#' @examples
+#' require("datasets")
+#' # mean for numerics
+#' mean_or_mode(iris)
+#' mean_or_mode(iris[["Sepal.Length"]])
+#' mean_or_mode(iris[["Species"]])
+#'
+#' # median for numerics
+#' median_or_mode(iris)
+#'
+#' @seealso \code{\link{prediction}}, \code{\link{build_datalist}}, \code{\link{seq_range}}
+#' @import stats
+#' @export
+mean_or_mode <- function(x) {
+ UseMethod("mean_or_mode")
+}
+
+#' @rdname mean_or_mode
+#' @export
+mean_or_mode.default <- function(x) {
+ if (!is.factor(x)) {
+ x <- as.factor(x)
+ }
+ factor(names(sort(table(x), decreasing = TRUE))[1L], levels = levels(x))
+}
+
+#' @rdname mean_or_mode
+#' @export
+mean_or_mode.numeric <- function(x) {
+ mean(x, na.rm = TRUE)
+}
+
+#' @rdname mean_or_mode
+#' @export
+mean_or_mode.data.frame <- function(x) {
+ setNames(lapply(x, mean_or_mode), names(x))
+}
+
+#' @rdname mean_or_mode
+#' @export
+median_or_mode <- function(x) {
+ UseMethod("median_or_mode")
+}
+
+#' @rdname mean_or_mode
+#' @export
+median_or_mode.default <- function(x) {
+ if (!is.factor(x)) {
+ x <- as.factor(x)
+ }
+ factor(names(sort(table(x), decreasing = TRUE))[1L], levels = levels(x))
+}
+
+#' @rdname mean_or_mode
+#' @export
+median_or_mode.numeric <- function(x) {
+ median(x, na.rm = TRUE)
+}
+
+#' @rdname mean_or_mode
+#' @export
+median_or_mode.data.frame <- function(x) {
+ setNames(lapply(x, median_or_mode), names(x))
+}
diff --git a/R/prediction.R b/R/prediction.R
index 7c71f07..3ca09d3 100644
--- a/R/prediction.R
+++ b/R/prediction.R
@@ -1,171 +1,171 @@
-#' @rdname prediction
-#' @name prediction-package
-#' @title Extract Predictions from a Model Object
-#' @description Extract predicted values via \code{\link[stats]{predict}} from a model object, conditional on data, and return a data frame.
-#' @param model A model object, perhaps returned by \code{\link[stats]{lm}} or \code{\link[stats]{glm}}.
-#' @param data A data.frame over which to calculate marginal effects. If missing, \code{\link{find_data}} is used to specify the data frame.
-#' @param at A list of one or more named vectors, specifically values at which to calculate the predictions. These are used to modify the value of \code{data} (see \code{\link{build_datalist}} for details on use).
-#' @param type A character string indicating the type of marginal effects to estimate. Mostly relevant for non-linear models, where the reasonable options are \dQuote{response} (the default) or \dQuote{link} (i.e., on the scale of the linear predictor in a GLM). For models of class \dQuote{polr} (from \code{\link[MASS]{polr}}), possible values are \dQuote{class} or \dQuote{probs}; both are returned.
-#' @param vcov A matrix containing the variance-covariance matrix for estimated model coefficients, or a function to perform the estimation with \code{model} as its only argument.
-#' @param calculate_se A logical indicating whether to calculate standard errors for observation-specific predictions and average predictions (if possible). The output will always contain a \dQuote{calculate_se} column regardless of this value; this only controls the calculation of standard errors. Setting it to \code{FALSE} may improve speed.
-#' @param category For multi-level or multi-category outcome models (e.g., ordered probit, multinomial logit, etc.), a value specifying which of the outcome levels should be used for the \code{"fitted"} column. If missing, some default is chosen automatically.
-#' @param \dots Additional arguments passed to \code{\link[stats]{predict}} methods.
-#' @details This function is simply a wrapper around \code{\link[stats]{predict}} that returns a data frame containing the value of \code{data} and the predicted values with respect to all variables specified in \code{data}.
-#'
-#' Methods are currently implemented for the following object classes:
-#' \itemize{
-#' \item \dQuote{lm}, see \code{\link[stats]{lm}}
-#' \item \dQuote{glm}, see \code{\link[stats]{glm}}, \code{\link[MASS]{glm.nb}}, \code{\link[glmx]{glmx}}, \code{\link[glmx]{hetglm}}, \code{\link[brglm]{brglm}}
-#' \item \dQuote{ar}, see \code{\link[stats]{ar}}
-#' \item \dQuote{Arima}, see \code{\link[stats]{arima}}
-#' \item \dQuote{arima0}, see \code{\link[stats]{arima0}}
-#' \item \dQuote{bigglm}, see \code{\link[biglm]{bigglm}} (including \dQuote{ffdf}-backed models provided by \code{\link[ffbase]{bigglm.ffdf}})
-#' \item \dQuote{betareg}, see \code{\link[betareg]{betareg}}
-#' \item \dQuote{bruto}, see \code{\link[mda]{bruto}}
-#' \item \dQuote{clm}, see \code{\link[ordinal]{clm}}
-#' \item \dQuote{coxph}, see \code{\link[survival]{coxph}}
-#' \item \dQuote{crch}, see \code{\link[crch]{crch}}
-#' \item \dQuote{earth}, see \code{\link[earth]{earth}}
-#' \item \dQuote{fda}, see \code{\link[mda]{fda}}
-#' \item \dQuote{Gam}, see \code{\link[gam]{gam}}
-#' \item \dQuote{gausspr}, see \code{\link[kernlab]{gausspr}}
-#' \item \dQuote{gee}, see \code{\link[gee]{gee}}
-#' \item \dQuote{glmnet}, see \code{\link[glmnet]{glmnet}}
-#' \item \dQuote{gls}, see \code{\link[nlme]{gls}}
-#' \item \dQuote{glimML}, see \code{\link[aod]{betabin}}, \code{\link[aod]{negbin}}
-#' \item \dQuote{glimQL}, see \code{\link[aod]{quasibin}}, \code{\link[aod]{quasipois}}
-#' \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{knnreg}, see \code{\link[caret]{knnreg}}
-#' \item \dQuote{kqr}, see \code{\link[kernlab]{kqr}}
-#' \item \dQuote{ksvm}, see \code{\link[kernlab]{ksvm}}
-#' \item \dQuote{lda}, see \code{\link[MASS]{lda}}
-#' \item \dQuote{lme}, see \code{\link[nlme]{lme}}
-#' \item \dQuote{loess}, see \code{\link[stats]{loess}}
-#' \item \dQuote{lqs}, see \code{\link[MASS]{lqs}}
-#' \item \dQuote{mars}, see \code{\link[mda]{mars}}
-#' \item \dQuote{mca}, see \code{\link[MASS]{mca}}
-#' \item \dQuote{mclogit}, see \code{\link[mclogit]{mclogit}}
-#' \item \dQuote{mda}, see \code{\link[mda]{mda}}
-#' \item \dQuote{merMod}, see \code{\link[lme4]{lmer}}, \code{\link[lme4]{glmer}}
-#' \item \dQuote{mnp}, see \code{\link[MNP]{mnp}}
-#' \item \dQuote{naiveBayes}, see \code{\link[e1071]{naiveBayes}}
-#' \item \dQuote{nlme}, see \code{\link[nlme]{nlme}}
-#' \item \dQuote{nls}, see \code{\link[stats]{nls}}
-#' \item \dQuote{nnet}, see \code{\link[nnet]{nnet}}
-#' \item \dQuote{plm}, see \code{\link[plm]{plm}}
-#' \item \dQuote{polr}, see \code{\link[MASS]{polr}}
-#' \item \dQuote{polyreg}, see \code{\link[mda]{polyreg}}
-#' \item \dQuote{ppr}, see \code{\link[stats]{ppr}}
-#' \item \dQuote{princomp}, see \code{\link[stats]{princomp}}
-#' \item \dQuote{qda}, see \code{\link[MASS]{qda}}
-#' \item \dQuote{rlm}, see \code{\link[MASS]{rlm}}
-#' \item \dQuote{rpart}, see \code{\link[rpart]{rpart}}
-#' \item \dQuote{rq}, see \code{\link[quantreg]{rq}}
-#' \item \dQuote{selection}, see \code{\link[sampleSelection]{selection}}
-#' \item \dQuote{speedglm}, see \code{\link[speedglm]{speedglm}}
-#' \item \dQuote{speedlm}, see \code{\link[speedglm]{speedlm}}
-#' \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{tobit}, see \code{\link[AER]{tobit}}
-#' \item \dQuote{train}, see \code{\link[caret]{train}}
-#' \item \dQuote{truncreg}, see \code{\link[truncreg]{truncreg}}
-#' \item \dQuote{zeroinfl}, see \code{\link[pscl]{zeroinfl}}
-#' }
-#'
-#' Where implemented, \code{prediction} also returns average predictions (and the variances thereof). Variances are implemented using the delta method, as described in \url{http://indiana.edu/~jslsoc/stata/ci_computations/spost_deltaci.pdf}.
-#'
-#' @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{"calculate_se"}). Additional columns may be reported depending on the object class. The data frame also carries attributes used by \code{print} and \code{summary}, which will be lost during subsetting.
-#' @examples
-#' require("datasets")
-#' x <- lm(Petal.Width ~ Sepal.Length * Sepal.Width * Species, data = iris)
-#' # prediction for every case
-#' prediction(x)
-#'
-#' # prediction for first case
-#' prediction(x, iris[1,])
-#'
-#' # basic use of 'at' argument
-#' summary(prediction(x, at = list(Species = c("setosa", "virginica"))))
-#'
-#' # basic use of 'at' argument
-#' prediction(x, at = list(Sepal.Length = seq_range(iris$Sepal.Length, 5)))
-#'
-#' # prediction at means/modes of input variables
-#' prediction(x, at = lapply(iris, mean_or_mode))
-#'
-#' # prediction with multi-category outcome
-#' \dontrun{
-#' library("mlogit")
-#' data("Fishing", package = "mlogit")
-#' Fish <- mlogit.data(Fishing, varying = c(2:9), shape = "wide", choice = "mode")
-#' mod <- mlogit(mode ~ price + catch, data = Fish)
-#' prediction(mod)
-#' prediction(mod, category = 3)
-#' }
-#'
-#' @keywords models
-#' @seealso \code{\link{find_data}}, \code{\link{build_datalist}}, \code{\link{mean_or_mode}}, \code{\link{seq_range}}
-#' @import stats
-#' @export
-prediction <- function(model, ...) {
- UseMethod("prediction")
-}
-
-#' @rdname prediction
-#' @export
-prediction.default <-
-function(model,
- data = find_data(model, parent.frame()),
- at = NULL,
- type = "response",
- vcov = stats::vcov(model),
- calculate_se = TRUE,
- ...) {
-
- # extract predicted values
- data <- data
- if (missing(data) || is.null(data)) {
- if (isTRUE(calculate_se)) {
- pred <- predict(model, type = type, se.fit = TRUE, ...)
- pred <- make_data_frame(fitted = pred[["fit"]], se.fitted = pred[["se.fit"]])
- } else {
- pred <- predict(model, type = type, se.fit = FALSE, ...)
- pred <- make_data_frame(fitted = pred, se.fitted = rep(NA_real_, length(pred)))
- }
- } else {
- # setup data
- if (!is.null(at)) {
- data <- build_datalist(data, at = at, as.data.frame = TRUE)
- at_specification <- attr(data, "at_specification")
- }
- # calculate predictions
- if (isTRUE(calculate_se)) {
- tmp <- predict(model, newdata = data, type = type, se.fit = TRUE, ...)
- # cbind back together
- pred <- make_data_frame(data, fitted = tmp[["fit"]], se.fitted = tmp[["se.fit"]])
- } else {
- tmp <- predict(model, newdata = data, type = type, se.fit = FALSE, ...)
- # cbind back together
- pred <- make_data_frame(data, fitted = tmp, se.fitted = rep(NA_real_, nrow(data)))
- }
- }
-
- # variance(s) of average predictions
- J <- NULL
- vc <- NA_real_
-
- # output
- structure(pred,
- class = c("prediction", "data.frame"),
- at = if (is.null(at)) at else at_specification,
- type = type,
- call = if ("call" %in% names(model)) model[["call"]] else NULL,
- model_class = class(model),
- row.names = seq_len(nrow(pred)),
- vcov = vc,
- jacobian = J,
- weighted = FALSE)
-}
+#' @rdname prediction
+#' @name prediction-package
+#' @title Extract Predictions from a Model Object
+#' @description Extract predicted values via \code{\link[stats]{predict}} from a model object, conditional on data, and return a data frame.
+#' @param model A model object, perhaps returned by \code{\link[stats]{lm}} or \code{\link[stats]{glm}}.
+#' @param data A data.frame over which to calculate marginal effects. If missing, \code{\link{find_data}} is used to specify the data frame.
+#' @param at A list of one or more named vectors, specifically values at which to calculate the predictions. These are used to modify the value of \code{data} (see \code{\link{build_datalist}} for details on use).
+#' @param type A character string indicating the type of marginal effects to estimate. Mostly relevant for non-linear models, where the reasonable options are \dQuote{response} (the default) or \dQuote{link} (i.e., on the scale of the linear predictor in a GLM). For models of class \dQuote{polr} (from \code{\link[MASS]{polr}}), possible values are \dQuote{class} or \dQuote{probs}; both are returned.
+#' @param vcov A matrix containing the variance-covariance matrix for estimated model coefficients, or a function to perform the estimation with \code{model} as its only argument.
+#' @param calculate_se A logical indicating whether to calculate standard errors for observation-specific predictions and average predictions (if possible). The output will always contain a \dQuote{calculate_se} column regardless of this value; this only controls the calculation of standard errors. Setting it to \code{FALSE} may improve speed.
+#' @param category For multi-level or multi-category outcome models (e.g., ordered probit, multinomial logit, etc.), a value specifying which of the outcome levels should be used for the \code{"fitted"} column. If missing, some default is chosen automatically.
+#' @param \dots Additional arguments passed to \code{\link[stats]{predict}} methods.
+#' @details This function is simply a wrapper around \code{\link[stats]{predict}} that returns a data frame containing the value of \code{data} and the predicted values with respect to all variables specified in \code{data}.
+#'
+#' Methods are currently implemented for the following object classes:
+#' \itemize{
+#' \item \dQuote{lm}, see \code{\link[stats]{lm}}
+#' \item \dQuote{glm}, see \code{\link[stats]{glm}}, \code{\link[MASS]{glm.nb}}, \code{\link[glmx]{glmx}}, \code{\link[glmx]{hetglm}}, \code{\link[brglm]{brglm}}
+#' \item \dQuote{ar}, see \code{\link[stats]{ar}}
+#' \item \dQuote{Arima}, see \code{\link[stats]{arima}}
+#' \item \dQuote{arima0}, see \code{\link[stats]{arima0}}
+#' \item \dQuote{bigglm}, see \code{\link[biglm]{bigglm}} (including \dQuote{ffdf}-backed models provided by \code{\link[ffbase]{bigglm.ffdf}})
+#' \item \dQuote{betareg}, see \code{\link[betareg]{betareg}}
+#' \item \dQuote{bruto}, see \code{\link[mda]{bruto}}
+#' \item \dQuote{clm}, see \code{\link[ordinal]{clm}}
+#' \item \dQuote{coxph}, see \code{\link[survival]{coxph}}
+#' \item \dQuote{crch}, see \code{\link[crch]{crch}}
+#' \item \dQuote{earth}, see \code{\link[earth]{earth}}
+#' \item \dQuote{fda}, see \code{\link[mda]{fda}}
+#' \item \dQuote{Gam}, see \code{\link[gam]{gam}}
+#' \item \dQuote{gausspr}, see \code{\link[kernlab]{gausspr}}
+#' \item \dQuote{gee}, see \code{\link[gee]{gee}}
+#' \item \dQuote{glmnet}, see \code{\link[glmnet]{glmnet}}
+#' \item \dQuote{gls}, see \code{\link[nlme]{gls}}
+#' \item \dQuote{glimML}, see \code{\link[aod]{betabin}}, \code{\link[aod]{negbin}}
+#' \item \dQuote{glimQL}, see \code{\link[aod]{quasibin}}, \code{\link[aod]{quasipois}}
+#' \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{knnreg}, see \code{\link[caret]{knnreg}}
+#' \item \dQuote{kqr}, see \code{\link[kernlab]{kqr}}
+#' \item \dQuote{ksvm}, see \code{\link[kernlab]{ksvm}}
+#' \item \dQuote{lda}, see \code{\link[MASS]{lda}}
+#' \item \dQuote{lme}, see \code{\link[nlme]{lme}}
+#' \item \dQuote{loess}, see \code{\link[stats]{loess}}
+#' \item \dQuote{lqs}, see \code{\link[MASS]{lqs}}
+#' \item \dQuote{mars}, see \code{\link[mda]{mars}}
+#' \item \dQuote{mca}, see \code{\link[MASS]{mca}}
+#' \item \dQuote{mclogit}, see \code{\link[mclogit]{mclogit}}
+#' \item \dQuote{mda}, see \code{\link[mda]{mda}}
+#' \item \dQuote{merMod}, see \code{\link[lme4]{lmer}}, \code{\link[lme4]{glmer}}
+#' \item \dQuote{mnp}, see \code{\link[MNP]{mnp}}
+#' \item \dQuote{naiveBayes}, see \code{\link[e1071]{naiveBayes}}
+#' \item \dQuote{nlme}, see \code{\link[nlme]{nlme}}
+#' \item \dQuote{nls}, see \code{\link[stats]{nls}}
+#' \item \dQuote{nnet}, see \code{\link[nnet]{nnet}}
+#' \item \dQuote{plm}, see \code{\link[plm]{plm}}
+#' \item \dQuote{polr}, see \code{\link[MASS]{polr}}
+#' \item \dQuote{polyreg}, see \code{\link[mda]{polyreg}}
+#' \item \dQuote{ppr}, see \code{\link[stats]{ppr}}
+#' \item \dQuote{princomp}, see \code{\link[stats]{princomp}}
+#' \item \dQuote{qda}, see \code{\link[MASS]{qda}}
+#' \item \dQuote{rlm}, see \code{\link[MASS]{rlm}}
+#' \item \dQuote{rpart}, see \code{\link[rpart]{rpart}}
+#' \item \dQuote{rq}, see \code{\link[quantreg]{rq}}
+#' \item \dQuote{selection}, see \code{\link[sampleSelection]{selection}}
+#' \item \dQuote{speedglm}, see \code{\link[speedglm]{speedglm}}
+#' \item \dQuote{speedlm}, see \code{\link[speedglm]{speedlm}}
+#' \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{tobit}, see \code{\link[AER]{tobit}}
+#' \item \dQuote{train}, see \code{\link[caret]{train}}
+#' \item \dQuote{truncreg}, see \code{\link[truncreg]{truncreg}}
+#' \item \dQuote{zeroinfl}, see \code{\link[pscl]{zeroinfl}}
+#' }
+#'
+#' Where implemented, \code{prediction} also returns average predictions (and the variances thereof). Variances are implemented using the delta method, as described in \url{http://indiana.edu/~jslsoc/stata/ci_computations/spost_deltaci.pdf}.
+#'
+#' @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{"calculate_se"}). Additional columns may be reported depending on the object class. The data frame also carries attributes used by \code{print} and \code{summary}, which will be lost during subsetting.
+#' @examples
+#' require("datasets")
+#' x <- lm(Petal.Width ~ Sepal.Length * Sepal.Width * Species, data = iris)
+#' # prediction for every case
+#' prediction(x)
+#'
+#' # prediction for first case
+#' prediction(x, iris[1,])
+#'
+#' # basic use of 'at' argument
+#' summary(prediction(x, at = list(Species = c("setosa", "virginica"))))
+#'
+#' # basic use of 'at' argument
+#' prediction(x, at = list(Sepal.Length = seq_range(iris$Sepal.Length, 5)))
+#'
+#' # prediction at means/modes of input variables
+#' prediction(x, at = lapply(iris, mean_or_mode))
+#'
+#' # prediction with multi-category outcome
+#' \dontrun{
+#' library("mlogit")
+#' data("Fishing", package = "mlogit")
+#' Fish <- mlogit.data(Fishing, varying = c(2:9), shape = "wide", choice = "mode")
+#' mod <- mlogit(mode ~ price + catch, data = Fish)
+#' prediction(mod)
+#' prediction(mod, category = 3)
+#' }
+#'
+#' @keywords models
+#' @seealso \code{\link{find_data}}, \code{\link{build_datalist}}, \code{\link{mean_or_mode}}, \code{\link{seq_range}}
+#' @import stats
+#' @export
+prediction <- function(model, ...) {
+ UseMethod("prediction")
+}
+
+#' @rdname prediction
+#' @export
+prediction.default <-
+function(model,
+ data = find_data(model, parent.frame()),
+ at = NULL,
+ type = "response",
+ vcov = stats::vcov(model),
+ calculate_se = TRUE,
+ ...) {
+
+ # extract predicted values
+ data <- data
+ if (missing(data) || is.null(data)) {
+ if (isTRUE(calculate_se)) {
+ pred <- predict(model, type = type, se.fit = TRUE, ...)
+ pred <- make_data_frame(fitted = pred[["fit"]], se.fitted = pred[["se.fit"]])
+ } else {
+ pred <- predict(model, type = type, se.fit = FALSE, ...)
+ pred <- make_data_frame(fitted = pred, se.fitted = rep(NA_real_, length(pred)))
+ }
+ } else {
+ # setup data
+ if (!is.null(at)) {
+ data <- build_datalist(data, at = at, as.data.frame = TRUE)
+ at_specification <- attr(data, "at_specification")
+ }
+ # calculate predictions
+ if (isTRUE(calculate_se)) {
+ tmp <- predict(model, newdata = data, type = type, se.fit = TRUE, ...)
+ # cbind back together
+ pred <- make_data_frame(data, fitted = tmp[["fit"]], se.fitted = tmp[["se.fit"]])
+ } else {
+ tmp <- predict(model, newdata = data, type = type, se.fit = FALSE, ...)
+ # cbind back together
+ pred <- make_data_frame(data, fitted = tmp, se.fitted = rep(NA_real_, nrow(data)))
+ }
+ }
+
+ # variance(s) of average predictions
+ J <- NULL
+ vc <- NA_real_
+
+ # output
+ structure(pred,
+ class = c("prediction", "data.frame"),
+ at = if (is.null(at)) at else at_specification,
+ type = type,
+ call = if ("call" %in% names(model)) model[["call"]] else NULL,
+ model_class = class(model),
+ row.names = seq_len(nrow(pred)),
+ vcov = vc,
+ jacobian = J,
+ weighted = FALSE)
+}
diff --git a/R/prediction_Arima.R b/R/prediction_Arima.R
index 49f1f8a..43191de 100644
--- a/R/prediction_Arima.R
+++ b/R/prediction_Arima.R
@@ -1,28 +1,28 @@
-#' @rdname prediction
-#' @export
-prediction.Arima <- function(model, calculate_se = TRUE,...) {
-
- # extract predicted values
- if (isTRUE(calculate_se)) {
- tmp <- predict(object = model, se.fit = TRUE, ...)
- pred <- make_data_frame(fitted = tmp[[1L]], se.fitted = tmp[[2L]])
- } else {
- tmp <- predict(object = model, se.fit = FALSE, ...)
- pred <- make_data_frame(fitted = tmp, se.fitted = rep(NA_real_, length(tmp)))
- }
-
- # variance(s) of average predictions
- vc <- NA_real_
-
- # output
- structure(pred,
- class = c("prediction", "data.frame"),
- at = NULL,
- type = NA_character_,
- call = if ("call" %in% names(model)) model[["call"]] else NULL,
- model_class = class(model),
- row.names = seq_len(nrow(pred)),
- vcov = vc,
- jacobian = NULL,
- weighted = FALSE)
-}
+#' @rdname prediction
+#' @export
+prediction.Arima <- function(model, calculate_se = TRUE,...) {
+
+ # extract predicted values
+ if (isTRUE(calculate_se)) {
+ tmp <- predict(object = model, se.fit = TRUE, ...)
+ pred <- make_data_frame(fitted = tmp[[1L]], se.fitted = tmp[[2L]])
+ } else {
+ tmp <- predict(object = model, se.fit = FALSE, ...)
+ pred <- make_data_frame(fitted = tmp, se.fitted = rep(NA_real_, length(tmp)))
+ }
+
+ # variance(s) of average predictions
+ vc <- NA_real_
+
+ # output
+ structure(pred,
+ class = c("prediction", "data.frame"),
+ at = NULL,
+ type = NA_character_,
+ call = if ("call" %in% names(model)) model[["call"]] else NULL,
+ model_class = class(model),
+ row.names = seq_len(nrow(pred)),
+ vcov = vc,
+ jacobian = NULL,
+ weighted = FALSE)
+}
diff --git a/R/prediction_ar.R b/R/prediction_ar.R
index 3922609..1fb0fbf 100644
--- a/R/prediction_ar.R
+++ b/R/prediction_ar.R
@@ -1,45 +1,45 @@
-#' @rdname prediction
-#' @export
-prediction.ar <- function(model, data, at = NULL, calculate_se = TRUE,...) {
-
- # extract predicted values
- if (missing(data) || is.null(data)) {
- if (isTRUE(calculate_se)) {
- tmp <- predict(object = model, se.fit = TRUE, ...)
- pred <- make_data_frame(fitted = tmp[[1L]], se.fitted = tmp[[2L]])
- } else {
- tmp <- predict(object = model, se.fit = FALSE, ...)
- pred <- make_data_frame(fitted = tmp, se.fitted = rep(NA_real_, length(tmp)))
- }
- } else {
- # setup data
- if (is.null(at)) {
- data <- data
- } else {
- data <- build_datalist(data, at = at, as.data.frame = TRUE)
- at_specification <- attr(data, "at_specification")
- }
- if (isTRUE(calculate_se)) {
- tmp <- predict(model, newdata = data, se.fit = TRUE, ...)
- pred <- make_data_frame(fitted = tmp[[1L]], se.fitted = tmp[[2L]])
- } else {
- tmp <- predict(model, newdata = data, se.fit = FALSE, ...)
- pred <- make_data_frame(fitted = tmp, se.fitted = rep(NA_real_, length(tmp)))
- }
- }
-
- # variance(s) of average predictions
- vc <- NA_real_
-
- # output
- structure(pred,
- class = c("prediction", "data.frame"),
- at = if (is.null(at)) at else at_specification,
- type = NA_character_,
- call = if ("call" %in% names(model)) model[["call"]] else NULL,
- model_class = class(model),
- row.names = seq_len(nrow(pred)),
- vcov = vc,
- jacobian = NULL,
- weighted = FALSE)
-}
+#' @rdname prediction
+#' @export
+prediction.ar <- function(model, data, at = NULL, calculate_se = TRUE,...) {
+
+ # extract predicted values
+ if (missing(data) || is.null(data)) {
+ if (isTRUE(calculate_se)) {
+ tmp <- predict(object = model, se.fit = TRUE, ...)
+ pred <- make_data_frame(fitted = tmp[[1L]], se.fitted = tmp[[2L]])
+ } else {
+ tmp <- predict(object = model, se.fit = FALSE, ...)
+ pred <- make_data_frame(fitted = tmp, se.fitted = rep(NA_real_, length(tmp)))
+ }
+ } else {
+ # setup data
+ if (is.null(at)) {
+ data <- data
+ } else {
+ data <- build_datalist(data, at = at, as.data.frame = TRUE)
+ at_specification <- attr(data, "at_specification")
+ }
+ if (isTRUE(calculate_se)) {
+ tmp <- predict(model, newdata = data, se.fit = TRUE, ...)
+ pred <- make_data_frame(fitted = tmp[[1L]], se.fitted = tmp[[2L]])
+ } else {
+ tmp <- predict(model, newdata = data, se.fit = FALSE, ...)
+ pred <- make_data_frame(fitted = tmp, se.fitted = rep(NA_real_, length(tmp)))
+ }
+ }
+
+ # variance(s) of average predictions
+ vc <- NA_real_
+
+ # output
+ structure(pred,
+ class = c("prediction", "data.frame"),
+ at = if (is.null(at)) at else at_specification,
+ type = NA_character_,
+ call = if ("call" %in% names(model)) model[["call"]] else NULL,
+ model_class = class(model),
+ row.names = seq_len(nrow(pred)),
+ vcov = vc,
+ jacobian = NULL,
+ weighted = FALSE)
+}
diff --git a/R/prediction_arima0.R b/R/prediction_arima0.R
index 7cfd14c..a03d63c 100644
--- a/R/prediction_arima0.R
+++ b/R/prediction_arima0.R
@@ -1,3 +1,3 @@
-#' @rdname prediction
-#' @export
-prediction.arima0 <- prediction.ar
+#' @rdname prediction
+#' @export
+prediction.arima0 <- prediction.ar
diff --git a/R/prediction_betareg.R b/R/prediction_betareg.R
index 442606e..a2456d7 100644
--- a/R/prediction_betareg.R
+++ b/R/prediction_betareg.R
@@ -1,49 +1,49 @@
-#' @rdname prediction
-#' @export
-prediction.betareg <-
-function(model,
- data = find_data(model, parent.frame()),
- at = NULL,
- type = c("response", "link", "precision", "variance", "quantile"),
- calculate_se = FALSE,
- ...) {
-
- type <- match.arg(type)
-
- # extract predicted value
- data <- data
- if (missing(data) || is.null(data)) {
- pred <- make_data_frame(fitted = predict(model, type = type, ...),
- se.fitted = NA_real_)
- } else {
- # reduce memory profile
- model[["model"]] <- NULL
-
- # setup data
- if (is.null(at)) {
- out <- data
- } else {
- out <- build_datalist(data, at = at, as.data.frame = TRUE)
- at_specification <- attr(out, "at_specification")
- }
- # calculate predictions
- pred <- predict(model, newdata = out, type = type, ...)
- # cbind back together
- pred <- make_data_frame(out, fitted = pred, se.fitted = rep(NA_real_, length(pred)))
- }
-
- # variance(s) of average predictions
- vc <- NA_real_
-
- # output
- structure(pred,
- class = c("prediction", "data.frame"),
- at = if (is.null(at)) at else at_specification,
- type = type,
- call = if ("call" %in% names(model)) model[["call"]] else NULL,
- model_class = class(model),
- row.names = seq_len(nrow(pred)),
- vcov = vc,
- jacobian = NULL,
- weighted = FALSE)
-}
+#' @rdname prediction
+#' @export
+prediction.betareg <-
+function(model,
+ data = find_data(model, parent.frame()),
+ at = NULL,
+ type = c("response", "link", "precision", "variance", "quantile"),
+ calculate_se = FALSE,
+ ...) {
+
+ type <- match.arg(type)
+
+ # extract predicted value
+ data <- data
+ if (missing(data) || is.null(data)) {
+ pred <- make_data_frame(fitted = predict(model, type = type, ...),
+ se.fitted = NA_real_)
+ } else {
+ # reduce memory profile
+ model[["model"]] <- NULL
+
+ # setup data
+ if (is.null(at)) {
+ out <- data
+ } else {
+ out <- build_datalist(data, at = at, as.data.frame = TRUE)
+ at_specification <- attr(out, "at_specification")
+ }
+ # calculate predictions
+ pred <- predict(model, newdata = out, type = type, ...)
+ # cbind back together
+ pred <- make_data_frame(out, fitted = pred, se.fitted = rep(NA_real_, length(pred)))
+ }
+
+ # variance(s) of average predictions
+ vc <- NA_real_
+
+ # output
+ structure(pred,
+ class = c("prediction", "data.frame"),
+ at = if (is.null(at)) at else at_specification,
+ type = type,
+ call = if ("call" %in% names(model)) model[["call"]] else NULL,
+ model_class = class(model),
+ row.names = seq_len(nrow(pred)),
+ vcov = vc,
+ jacobian = NULL,
+ weighted = FALSE)
+}
diff --git a/R/prediction_bigFastLm.R b/R/prediction_bigFastLm.R
index 1be05ed..11e7a5a 100644
--- a/R/prediction_bigFastLm.R
+++ b/R/prediction_bigFastLm.R
@@ -1,38 +1,38 @@
-# @rdname prediction
-# @export
-prediction.bigLm <-
-function(model,
- data = NULL,
- calculate_se = FALSE,
- ...) {
-
- # extract predicted values
- data <- data
- if (missing(data) || is.null(data)) {
- pred <- predict(model, ...)
- pred <- make_data_frame(fitted = pred, se.fitted = rep(NA_real_, length(pred)))
- } else {
- # setup data
- #data <- build_datalist(data, at = at, as.data.frame = TRUE)
- #at_specification <- attr(data, "at_specification")
- # calculate predictions
- tmp <- predict(model, newdata = data, ...)
- # cbind back together
- pred <- make_data_frame(data, fitted = tmp, se.fitted = rep(NA_real_, nrow(data)))
- }
-
- # variance(s) of average predictions
- vc <- NA_real_
-
- # output
- structure(pred,
- class = c("prediction", "data.frame"),
- at = NULL,
- type = "response",
- call = if ("call" %in% names(model)) model[["call"]] else NULL,
- model_class = class(model),
- row.names = seq_len(nrow(pred)),
- vcov = vc,
- jacobian = NULL,
- weighted = FALSE)
+# @rdname prediction
+# @export
+prediction.bigLm <-
+function(model,
+ data = NULL,
+ calculate_se = FALSE,
+ ...) {
+
+ # extract predicted values
+ data <- data
+ if (missing(data) || is.null(data)) {
+ pred <- predict(model, ...)
+ pred <- make_data_frame(fitted = pred, se.fitted = rep(NA_real_, length(pred)))
+ } else {
+ # setup data
+ #data <- build_datalist(data, at = at, as.data.frame = TRUE)
+ #at_specification <- attr(data, "at_specification")
+ # calculate predictions
+ tmp <- predict(model, newdata = data, ...)
+ # cbind back together
+ pred <- make_data_frame(data, fitted = tmp, se.fitted = rep(NA_real_, nrow(data)))
+ }
+
+ # variance(s) of average predictions
+ vc <- NA_real_
+
+ # output
+ structure(pred,
+ class = c("prediction", "data.frame"),
+ at = NULL,
+ type = "response",
+ call = if ("call" %in% names(model)) model[["call"]] else NULL,
+ model_class = class(model),
+ row.names = seq_len(nrow(pred)),
+ vcov = vc,
+ jacobian = NULL,
+ weighted = FALSE)
}
\ No newline at end of file
diff --git a/R/prediction_bigglm.R b/R/prediction_bigglm.R
index eb76a97..88b7522 100644
--- a/R/prediction_bigglm.R
+++ b/R/prediction_bigglm.R
@@ -1,50 +1,50 @@
-# @rdname prediction
-# @export
-prediction.bigglm <-
-function(model,
- data = find_data(model, parent.frame()),
- at = NULL,
- type = "response",
- calculate_se = TRUE,
- ...) {
-
- type <- match.arg(type)
-
- # extract predicted values
- data <- data
- if (missing(data) || is.null(data)) {
- stop("prediction() for objects of class 'bigglm' only work when 'data' is specified")
- } else {
- # reduce memory profile
- model[["model"]] <- NULL
-
- # setup data
- data <- build_datalist(data, at = at, as.data.frame = TRUE)
- at_specification <- attr(data, "at_specification")
- # calculate predictions
- if (isTRUE(calculate_se)) {
- tmp <- predict(model, newdata = data, type = type, se.fit = TRUE, ...)
- # cbind back together
- pred <- make_data_frame(data, fitted = tmp[["fit"]], se.fitted = tmp[["se.fit"]])
- } else {
- tmp <- predict(model, newdata = data, type = type, se.fit = FALSE, ...)
- # cbind back together
- pred <- make_data_frame(data, fitted = tmp, se.fitted = rep(NA_real_, nrow(data)))
- }
- }
-
- # variance(s) of average predictions
- vc <- NA_real_
-
- # output
- structure(pred,
- class = c("prediction", "data.frame"),
- at = if (is.null(at)) at else at_specification,
- type = type,
- call = if ("call" %in% names(model)) model[["call"]] else NULL,
- model_class = class(model),
- row.names = seq_len(nrow(pred)),
- vcov = vc,
- jaccobian = NULL,
- weighted = FALSE)
-}
+# @rdname prediction
+# @export
+prediction.bigglm <-
+function(model,
+ data = find_data(model, parent.frame()),
+ at = NULL,
+ type = "response",
+ calculate_se = TRUE,
+ ...) {
+
+ type <- match.arg(type)
+
+ # extract predicted values
+ data <- data
+ if (missing(data) || is.null(data)) {
+ stop("prediction() for objects of class 'bigglm' only work when 'data' is specified")
+ } else {
+ # reduce memory profile
+ model[["model"]] <- NULL
+
+ # setup data
+ data <- build_datalist(data, at = at, as.data.frame = TRUE)
+ at_specification <- attr(data, "at_specification")
+ # calculate predictions
+ if (isTRUE(calculate_se)) {
+ tmp <- predict(model, newdata = data, type = type, se.fit = TRUE, ...)
+ # cbind back together
+ pred <- make_data_frame(data, fitted = tmp[["fit"]], se.fitted = tmp[["se.fit"]])
+ } else {
+ tmp <- predict(model, newdata = data, type = type, se.fit = FALSE, ...)
+ # cbind back together
+ pred <- make_data_frame(data, fitted = tmp, se.fitted = rep(NA_real_, nrow(data)))
+ }
+ }
+
+ # variance(s) of average predictions
+ vc <- NA_real_
+
+ # output
+ structure(pred,
+ class = c("prediction", "data.frame"),
+ at = if (is.null(at)) at else at_specification,
+ type = type,
+ call = if ("call" %in% names(model)) model[["call"]] else NULL,
+ model_class = class(model),
+ row.names = seq_len(nrow(pred)),
+ vcov = vc,
+ jaccobian = NULL,
+ weighted = FALSE)
+}
diff --git a/R/prediction_biglm.R b/R/prediction_biglm.R
index 97511b7..48ebe45 100644
--- a/R/prediction_biglm.R
+++ b/R/prediction_biglm.R
@@ -1,50 +1,50 @@
-#' @rdname prediction
-#' @export
-prediction.biglm <-
-function(model,
- data = find_data(model, parent.frame()),
- at = NULL,
- type = "response",
- calculate_se = TRUE,
- ...) {
-
- type <- match.arg(type)
-
- # extract predicted values
- data <- data
- if (missing(data) || is.null(data)) {
- stop("prediction() for objects of class 'biglm' only work when 'data' is specified")
- } else {
- # reduce memory profile
- model[["model"]] <- NULL
-
- # setup data
- data <- build_datalist(data, at = at, as.data.frame = TRUE)
- at_specification <- attr(data, "at_specification")
- # calculate predictions
- if (isTRUE(calculate_se)) {
- tmp <- predict(model, newdata = data, se.fit = TRUE, ...)
- # cbind back together
- pred <- make_data_frame(data, fitted = tmp[["fit"]], se.fitted = tmp[["se.fit"]])
- } else {
- tmp <- predict(model, newdata = data, se.fit = FALSE, ...)
- # cbind back together
- pred <- make_data_frame(data, fitted = tmp, se.fitted = rep(NA_real_, nrow(data)))
- }
- }
-
- # variance(s) of average predictions
- vc <- NA_real_
-
- # output
- structure(pred,
- class = c("prediction", "data.frame"),
- at = if (is.null(at)) at else at_specification,
- type = type,
- call = if ("call" %in% names(model)) model[["call"]] else NULL,
- model_class = class(model),
- row.names = seq_len(nrow(pred)),
- vcov = vc,
- jacobian = NULL,
- weighted = FALSE)
-}
+#' @rdname prediction
+#' @export
+prediction.biglm <-
+function(model,
+ data = find_data(model, parent.frame()),
+ at = NULL,
+ type = "response",
+ calculate_se = TRUE,
+ ...) {
+
+ type <- match.arg(type)
+
+ # extract predicted values
+ data <- data
+ if (missing(data) || is.null(data)) {
+ stop("prediction() for objects of class 'biglm' only work when 'data' is specified")
+ } else {
+ # reduce memory profile
+ model[["model"]] <- NULL
+
+ # setup data
+ data <- build_datalist(data, at = at, as.data.frame = TRUE)
+ at_specification <- attr(data, "at_specification")
+ # calculate predictions
+ if (isTRUE(calculate_se)) {
+ tmp <- predict(model, newdata = data, se.fit = TRUE, ...)
+ # cbind back together
+ pred <- make_data_frame(data, fitted = tmp[["fit"]], se.fitted = tmp[["se.fit"]])
+ } else {
+ tmp <- predict(model, newdata = data, se.fit = FALSE, ...)
+ # cbind back together
+ pred <- make_data_frame(data, fitted = tmp, se.fitted = rep(NA_real_, nrow(data)))
+ }
+ }
+
+ # variance(s) of average predictions
+ vc <- NA_real_
+
+ # output
+ structure(pred,
+ class = c("prediction", "data.frame"),
+ at = if (is.null(at)) at else at_specification,
+ type = type,
+ call = if ("call" %in% names(model)) model[["call"]] else NULL,
+ model_class = class(model),
+ row.names = seq_len(nrow(pred)),
+ vcov = vc,
+ jacobian = NULL,
+ weighted = FALSE)
+}
diff --git a/R/prediction_bruto.R b/R/prediction_bruto.R
index 864272c..741931e 100644
--- a/R/prediction_bruto.R
+++ b/R/prediction_bruto.R
@@ -1,45 +1,45 @@
-#' @rdname prediction
-#' @export
-prediction.bruto <-
-function(model,
- data = NULL,
- at = NULL,
- type = "fitted",
- calculate_se = FALSE,
- ...) {
-
- type <- match.arg(type)
-
- # extract predicted values
- data <- data
- if (missing(data) || is.null(data)) {
- pred <- predict(model, type = type, ...)
- pred <- make_data_frame(fitted = pred[,1L], se.fitted = rep(NA_real_, length(pred)))
- } else {
- # setup data
- data <- build_datalist(data, at = at, as.data.frame = TRUE)
- at_specification <- attr(data, "at_specification")
- # calculate predictions
- if (!is.matrix(data)) {
- data <- as.matrix(data)
- }
- tmp <- predict(model, newdata = data, type = type, ...)
- # cbind back together
- pred <- make_data_frame(data, fitted = tmp[,1L], se.fitted = rep(NA_real_, nrow(data)))
- }
-
- # variance(s) of average predictions
- vc <- NA_real_
-
- # output
- structure(pred,
- class = c("prediction", "data.frame"),
- at = if (is.null(at)) at else at_specification,
- type = type,
- call = if ("call" %in% names(model)) model[["call"]] else NULL,
- model_class = class(model),
- row.names = seq_len(nrow(pred)),
- vcov = vc,
- jacobian = NULL,
- weighted = FALSE)
-}
+#' @rdname prediction
+#' @export
+prediction.bruto <-
+function(model,
+ data = NULL,
+ at = NULL,
+ type = "fitted",
+ calculate_se = FALSE,
+ ...) {
+
+ type <- match.arg(type)
+
+ # extract predicted values
+ data <- data
+ if (missing(data) || is.null(data)) {
+ pred <- predict(model, type = type, ...)
+ pred <- make_data_frame(fitted = pred[,1L], se.fitted = rep(NA_real_, length(pred)))
+ } else {
+ # setup data
+ data <- build_datalist(data, at = at, as.data.frame = TRUE)
+ at_specification <- attr(data, "at_specification")
+ # calculate predictions
+ if (!is.matrix(data)) {
+ data <- as.matrix(data)
+ }
+ tmp <- predict(model, newdata = data, type = type, ...)
+ # cbind back together
+ pred <- make_data_frame(data, fitted = tmp[,1L], se.fitted = rep(NA_real_, nrow(data)))
+ }
+
+ # variance(s) of average predictions
+ vc <- NA_real_
+
+ # output
+ structure(pred,
+ class = c("prediction", "data.frame"),
+ at = if (is.null(at)) at else at_specification,
+ type = type,
+ call = if ("call" %in% names(model)) model[["call"]] else NULL,
+ model_class = class(model),
+ row.names = seq_len(nrow(pred)),
+ vcov = vc,
+ jacobian = NULL,
+ weighted = FALSE)
+}
diff --git a/R/prediction_clm.R b/R/prediction_clm.R
index 6288983..4972262 100644
--- a/R/prediction_clm.R
+++ b/R/prediction_clm.R
@@ -1,87 +1,87 @@
-#' @rdname prediction
-#' @export
-prediction.clm <-
-function(model,
- data = find_data(model, parent.frame()),
- at = NULL,
- type = NULL,
- calculate_se = TRUE,
- category,
- ...) {
-
- if (!is.null(type)) {
- warning(sprintf("'type' is ignored for models of class '%s'", class(model)))
- }
-
- # extract predicted values
- data <- data
- if (missing(data) || is.null(data)) {
- pred <- make_data_frame(fitted.class = predict(model, type = "class", se.fit = FALSE, ...)[["fit"]])
- if (isTRUE(calculate_se)) {
- problist <- predict(model, newdata = data, type = "prob", se.fit = TRUE, ...)
- probs <- make_data_frame(problist[["fit"]])
- probs.se <- make_data_frame(problist[["se.fit"]])
- names(probs) <- paste0("Pr(", seq_len(ncol(probs)), ")")
- names(probs.se) <- paste0("se.Pr(", seq_len(ncol(probs)), ")")
- pred <- make_data_frame(pred, probs, probs.se)
- } else {
- problist <- predict(model, newdata = data, type = "prob", se.fit = FALSE, ...)
- probs <- make_data_frame(problist[["fit"]])
- names(probs) <- paste0("Pr(", seq_len(ncol(probs)), ")")
- pred <- make_data_frame(pred, probs)
- }
- } else {
- # setup data
- if (is.null(at)) {
- out <- data
- } else {
- out <- build_datalist(data, at = at, as.data.frame = TRUE)
- at_specification <- attr(out, "at_specification")
- }
- # calculate predictions
- pred <- predict(model, newdata = out, type = "class", se.fit = FALSE, ...)[["fit"]]
- if (isTRUE(calculate_se)) {
- problist <- predict(model, newdata = out, type = "prob", se.fit = TRUE, ...)
- probs <- make_data_frame(problist[["fit"]])
- probs.se <- make_data_frame(problist[["se.fit"]])
- names(probs) <- paste0("Pr(", seq_len(ncol(probs)), ")")
- names(probs.se) <- paste0("se.Pr(", seq_len(ncol(probs)), ")")
- pred <- make_data_frame(out, fitted.class = pred, probs, probs.se)
- } else {
- problist <- predict(model, newdata = out, type = "prob", se.fit = FALSE, ...)
- probs <- make_data_frame(problist[["fit"]])
- names(probs) <- paste0("Pr(", seq_len(ncol(probs)), ")")
- pred <- make_data_frame(out, fitted.class = pred, probs)
- }
- }
-
- # handle category argument
- if (missing(category)) {
- w <- grep("^Pr\\(", names(pred))[1L]
- category <- names(pred)[w]
- pred[["fitted"]] <- pred[[w]]
- } else {
- w <- which(names(pred) == paste0("Pr(", category, ")"))
- if (!length(w)) {
- stop(sprintf("category %s not found", category))
- }
- pred[["fitted"]] <- pred[[ w[1L] ]]
- }
- pred[["se.fitted"]] <- NA_real_
-
- # variance(s) of average predictions
- vc <- NA_real_
-
- # output
- structure(pred,
- class = c("prediction", "data.frame"),
- at = if (is.null(at)) at else at_specification,
- type = NA_character_,
- call = if ("call" %in% names(model)) model[["call"]] else NULL,
- model_class = class(model),
- row.names = seq_len(nrow(pred)),
- vcov = vc,
- jacobian = NULL,
- category = category,
- weighted = FALSE)
-}
+#' @rdname prediction
+#' @export
+prediction.clm <-
+function(model,
+ data = find_data(model, parent.frame()),
+ at = NULL,
+ type = NULL,
+ calculate_se = TRUE,
+ category,
+ ...) {
+
+ if (!is.null(type)) {
+ warning(sprintf("'type' is ignored for models of class '%s'", class(model)))
+ }
+
+ # extract predicted values
+ data <- data
+ if (missing(data) || is.null(data)) {
+ pred <- make_data_frame(fitted.class = predict(model, type = "class", se.fit = FALSE, ...)[["fit"]])
+ if (isTRUE(calculate_se)) {
+ problist <- predict(model, newdata = data, type = "prob", se.fit = TRUE, ...)
+ probs <- make_data_frame(problist[["fit"]])
+ probs.se <- make_data_frame(problist[["se.fit"]])
+ names(probs) <- paste0("Pr(", seq_len(ncol(probs)), ")")
+ names(probs.se) <- paste0("se.Pr(", seq_len(ncol(probs)), ")")
+ pred <- make_data_frame(pred, probs, probs.se)
+ } else {
+ problist <- predict(model, newdata = data, type = "prob", se.fit = FALSE, ...)
+ probs <- make_data_frame(problist[["fit"]])
+ names(probs) <- paste0("Pr(", seq_len(ncol(probs)), ")")
+ pred <- make_data_frame(pred, probs)
+ }
+ } else {
+ # setup data
+ if (is.null(at)) {
+ out <- data
+ } else {
+ out <- build_datalist(data, at = at, as.data.frame = TRUE)
+ at_specification <- attr(out, "at_specification")
+ }
+ # calculate predictions
+ pred <- predict(model, newdata = out, type = "class", se.fit = FALSE, ...)[["fit"]]
+ if (isTRUE(calculate_se)) {
+ problist <- predict(model, newdata = out, type = "prob", se.fit = TRUE, ...)
+ probs <- make_data_frame(problist[["fit"]])
+ probs.se <- make_data_frame(problist[["se.fit"]])
+ names(probs) <- paste0("Pr(", seq_len(ncol(probs)), ")")
+ names(probs.se) <- paste0("se.Pr(", seq_len(ncol(probs)), ")")
+ pred <- make_data_frame(out, fitted.class = pred, probs, probs.se)
+ } else {
+ problist <- predict(model, newdata = out, type = "prob", se.fit = FALSE, ...)
+ probs <- make_data_frame(problist[["fit"]])
+ names(probs) <- paste0("Pr(", seq_len(ncol(probs)), ")")
+ pred <- make_data_frame(out, fitted.class = pred, probs)
+ }
+ }
+
+ # handle category argument
+ if (missing(category)) {
+ w <- grep("^Pr\\(", names(pred))[1L]
+ category <- names(pred)[w]
+ pred[["fitted"]] <- pred[[w]]
+ } else {
+ w <- which(names(pred) == paste0("Pr(", category, ")"))
+ if (!length(w)) {
+ stop(sprintf("category %s not found", category))
+ }
+ pred[["fitted"]] <- pred[[ w[1L] ]]
+ }
+ pred[["se.fitted"]] <- NA_real_
+
+ # variance(s) of average predictions
+ vc <- NA_real_
+
+ # output
+ structure(pred,
+ class = c("prediction", "data.frame"),
+ at = if (is.null(at)) at else at_specification,
+ type = NA_character_,
+ call = if ("call" %in% names(model)) model[["call"]] else NULL,
+ model_class = class(model),
+ row.names = seq_len(nrow(pred)),
+ vcov = vc,
+ jacobian = NULL,
+ category = category,
+ weighted = FALSE)
+}
diff --git a/R/prediction_coxph.R b/R/prediction_coxph.R
index 978c537..93f3fb0 100644
--- a/R/prediction_coxph.R
+++ b/R/prediction_coxph.R
@@ -1,55 +1,55 @@
-#' @rdname prediction
-#' @export
-prediction.coxph <-
-function(model,
- data = find_data(model, parent.frame()),
- at = NULL,
- type = c("risk", "expected", "lp"),
- calculate_se = TRUE,
- ...) {
-
- type <- match.arg(type)
-
- # extract predicted values
- data <- data
- if (missing(data) || is.null(data)) {
- if (isTRUE(calculate_se)) {
- pred <- predict(model, type = type, se.fit = TRUE, ...)
- pred <- make_data_frame(fitted = pred[["fit"]], se.fitted = pred[["se.fit"]])
- } else {
- pred <- predict(model, type = type, se.fit = FALSE, ...)
- pred <- make_data_frame(fitted = pred, se.fitted = rep(NA_real_, length(pred)))
- }
- } else {
- # setup data
- if (is.null(at)) {
- out <- data
- } else {
- out <- build_datalist(data, at = at, as.data.frame = TRUE)
- at_specification <- attr(out, "at_specification")
- }
- # calculate predictions
- if (isTRUE(calculate_se)) {
- pred <- predict(model, newdata = out, type = type, se.fit = TRUE, ...)
- pred <- make_data_frame(out, fitted = pred[["fit"]], se.fitted = pred[["se.fit"]])
- } else {
- pred <- predict(model, newdata = out, type = type, se.fit = FALSE, ...)
- pred <- make_data_frame(out, fitted = pred, se.fitted = rep(NA_real_, length(pred)))
- }
- }
-
- # variance(s) of average predictions
- vc <- NA_real_
-
- # output
- structure(pred,
- class = c("prediction", "data.frame"),
- at = if (is.null(at)) at else at_specification,
- type = type,
- call = if ("call" %in% names(model)) model[["call"]] else NULL,
- model_class = class(model),
- row.names = seq_len(nrow(pred)),
- vcov = vc,
- jacobian = NULL,
- weighted = FALSE)
-}
+#' @rdname prediction
+#' @export
+prediction.coxph <-
+function(model,
+ data = find_data(model, parent.frame()),
+ at = NULL,
+ type = c("risk", "expected", "lp"),
+ calculate_se = TRUE,
+ ...) {
+
+ type <- match.arg(type)
+
+ # extract predicted values
+ data <- data
+ if (missing(data) || is.null(data)) {
+ if (isTRUE(calculate_se)) {
+ pred <- predict(model, type = type, se.fit = TRUE, ...)
+ pred <- make_data_frame(fitted = pred[["fit"]], se.fitted = pred[["se.fit"]])
+ } else {
+ pred <- predict(model, type = type, se.fit = FALSE, ...)
+ pred <- make_data_frame(fitted = pred, se.fitted = rep(NA_real_, length(pred)))
+ }
+ } else {
+ # setup data
+ if (is.null(at)) {
+ out <- data
+ } else {
+ out <- build_datalist(data, at = at, as.data.frame = TRUE)
+ at_specification <- attr(out, "at_specification")
+ }
+ # calculate predictions
+ if (isTRUE(calculate_se)) {
+ pred <- predict(model, newdata = out, type = type, se.fit = TRUE, ...)
+ pred <- make_data_frame(out, fitted = pred[["fit"]], se.fitted = pred[["se.fit"]])
+ } else {
+ pred <- predict(model, newdata = out, type = type, se.fit = FALSE, ...)
+ pred <- make_data_frame(out, fitted = pred, se.fitted = rep(NA_real_, length(pred)))
+ }
+ }
+
+ # variance(s) of average predictions
+ vc <- NA_real_
+
+ # output
+ structure(pred,
+ class = c("prediction", "data.frame"),
+ at = if (is.null(at)) at else at_specification,
+ type = type,
+ call = if ("call" %in% names(model)) model[["call"]] else NULL,
+ model_class = class(model),
+ row.names = seq_len(nrow(pred)),
+ vcov = vc,
+ jacobian = NULL,
+ weighted = FALSE)
+}
diff --git a/R/prediction_crch.R b/R/prediction_crch.R
index 0d8bb95..28b2527 100644
--- a/R/prediction_crch.R
+++ b/R/prediction_crch.R
@@ -1,46 +1,46 @@
-#' @rdname prediction
-#' @export
-prediction.crch <-
-function(model,
- data = find_data(model),
- at = NULL,
- type = c("response", "location", "scale", "quantile"),
- calculate_se = FALSE,
- ...) {
-
- type <- match.arg(type)
-
- # extract predicted values
- data <- data
- if (missing(data) || is.null(data)) {
- pred <- make_data_frame(fitted = predict(model, type = type, ...),
- se.fitted = NA_real_)
- } else {
- # setup data
- if (is.null(at)) {
- out <- data
- } else {
- out <- build_datalist(data, at = at, as.data.frame = TRUE)
- at_specification <- attr(out, "at_specification")
- }
- # calculate predictions
- tmp <- predict(model, newdata = out, type = type, ...)
- # cbind back together
- pred <- make_data_frame(out, fitted = tmp, se.fitted = rep(NA_real_, length(tmp)))
- }
-
- # variance(s) of average predictions
- vc <- NA_real_
-
- # output
- structure(pred,
- class = c("prediction", "data.frame"),
- at = if (is.null(at)) at else at_specification,
- type = type,
- call = if ("call" %in% names(model)) model[["call"]] else NULL,
- model_class = class(model),
- row.names = seq_len(nrow(pred)),
- vcov = vc,
- jacobian = NULL,
- weighted = FALSE)
-}
+#' @rdname prediction
+#' @export
+prediction.crch <-
+function(model,
+ data = find_data(model),
+ at = NULL,
+ type = c("response", "location", "scale", "quantile"),
+ calculate_se = FALSE,
+ ...) {
+
+ type <- match.arg(type)
+
+ # extract predicted values
+ data <- data
+ if (missing(data) || is.null(data)) {
+ pred <- make_data_frame(fitted = predict(model, type = type, ...),
+ se.fitted = NA_real_)
+ } else {
+ # setup data
+ if (is.null(at)) {
+ out <- data
+ } else {
+ out <- build_datalist(data, at = at, as.data.frame = TRUE)
+ at_specification <- attr(out, "at_specification")
+ }
+ # calculate predictions
+ tmp <- predict(model, newdata = out, type = type, ...)
+ # cbind back together
+ pred <- make_data_frame(out, fitted = tmp, se.fitted = rep(NA_real_, length(tmp)))
+ }
+
+ # variance(s) of average predictions
+ vc <- NA_real_
+
+ # output
+ structure(pred,
+ class = c("prediction", "data.frame"),
+ at = if (is.null(at)) at else at_specification,
+ type = type,
+ call = if ("call" %in% names(model)) model[["call"]] else NULL,
+ model_class = class(model),
+ row.names = seq_len(nrow(pred)),
+ vcov = vc,
+ jacobian = NULL,
+ weighted = FALSE)
+}
diff --git a/R/prediction_earth.R b/R/prediction_earth.R
index ec4b66c..f450962 100644
--- a/R/prediction_earth.R
+++ b/R/prediction_earth.R
@@ -1,70 +1,70 @@
-#' @rdname prediction
-#' @export
-prediction.earth <-
-function(model,
- data = find_data(model, parent.frame()),
- at = NULL,
- type = c("response", "link"),
- calculate_se = TRUE,
- category,
- ...) {
-
- type <- match.arg(type)
-
- # extract predicted values
- data <- data
- if (missing(data) || is.null(data)) {
- pred <- make_data_frame(fitted.class = predict(model, type = "class", ...)[,1L])
- probs <- make_data_frame(predict(model, type = type, ...))
- names(probs) <- paste0("Pr(", names(probs), ")")
- pred <- make_data_frame(pred, probs)
- } else {
- # setup data
- if (is.null(at)) {
- out <- data
- } else {
- out <- build_datalist(data, at = at, as.data.frame = TRUE)
- at_specification <- attr(out, "at_specification")
- }
- # calculate predictions
- tmp <- predict(model,
- newdata = out,
- type = "class",
- ...)
- colnames(tmp) <- "fitted.class"
- tmp_probs <- make_data_frame(predict(model, newdata = out, type = type, ...))
- names(tmp_probs) <- paste0("Pr(", names(tmp_probs), ")")
- # cbind back together
- pred <- make_data_frame(out, tmp, tmp_probs)
- pred[["se.fitted"]] <- NA_real_
- }
-
- # handle category argument
- if (missing(category)) {
- w <- grep("^Pr\\(", names(pred))[1L]
- category <- names(pred)[w]
- pred[["fitted"]] <- pred[[w]]
- } else {
- w <- which(names(pred) == paste0("Pr(", category, ")"))
- if (!length(w)) {
- stop(sprintf("category %s not found", category))
- }
- pred[["fitted"]] <- pred[[ w[1L] ]]
- }
-
- # variance(s) of average predictions
- vc <- NA_real_
-
- # output
- structure(pred,
- class = c("prediction", "data.frame"),
- at = if (is.null(at)) at else at_specification,
- type = NA_character_,
- call = if ("call" %in% names(model)) model[["call"]] else NULL,
- model_class = class(model),
- row.names = seq_len(nrow(pred)),
- vcov = vc,
- jacobian = NULL,
- category = category,
- weighted = FALSE)
-}
+#' @rdname prediction
+#' @export
+prediction.earth <-
+function(model,
+ data = find_data(model, parent.frame()),
+ at = NULL,
+ type = c("response", "link"),
+ calculate_se = TRUE,
+ category,
+ ...) {
+
+ type <- match.arg(type)
+
+ # extract predicted values
+ data <- data
+ if (missing(data) || is.null(data)) {
+ pred <- make_data_frame(fitted.class = predict(model, type = "class", ...)[,1L])
+ probs <- make_data_frame(predict(model, type = type, ...))
+ names(probs) <- paste0("Pr(", names(probs), ")")
+ pred <- make_data_frame(pred, probs)
+ } else {
+ # setup data
+ if (is.null(at)) {
+ out <- data
+ } else {
+ out <- build_datalist(data, at = at, as.data.frame = TRUE)
+ at_specification <- attr(out, "at_specification")
+ }
+ # calculate predictions
+ tmp <- predict(model,
+ newdata = out,
+ type = "class",
+ ...)
+ colnames(tmp) <- "fitted.class"
+ tmp_probs <- make_data_frame(predict(model, newdata = out, type = type, ...))
+ names(tmp_probs) <- paste0("Pr(", names(tmp_probs), ")")
+ # cbind back together
+ pred <- make_data_frame(out, tmp, tmp_probs)
+ pred[["se.fitted"]] <- NA_real_
+ }
+
+ # handle category argument
+ if (missing(category)) {
+ w <- grep("^Pr\\(", names(pred))[1L]
+ category <- names(pred)[w]
+ pred[["fitted"]] <- pred[[w]]
+ } else {
+ w <- which(names(pred) == paste0("Pr(", category, ")"))
+ if (!length(w)) {
+ stop(sprintf("category %s not found", category))
+ }
+ pred[["fitted"]] <- pred[[ w[1L] ]]
+ }
+
+ # variance(s) of average predictions
+ vc <- NA_real_
+
+ # output
+ structure(pred,
+ class = c("prediction", "data.frame"),
+ at = if (is.null(at)) at else at_specification,
+ type = NA_character_,
+ call = if ("call" %in% names(model)) model[["call"]] else NULL,
+ model_class = class(model),
+ row.names = seq_len(nrow(pred)),
+ vcov = vc,
+ jacobian = NULL,
+ category = category,
+ weighted = FALSE)
+}
diff --git a/R/prediction_fda.R b/R/prediction_fda.R
index 636dbcd..7426791 100644
--- a/R/prediction_fda.R
+++ b/R/prediction_fda.R
@@ -1,68 +1,68 @@
-#' @rdname prediction
-#' @export
-prediction.fda <-
-function(model,
- data = find_data(model, parent.frame()),
- at = NULL,
- type = NULL,
- calculate_se = FALSE,
- category,
- ...) {
-
- if (!is.null(type)) {
- warning(sprintf("'type' is ignored for models of class '%s'", class(model)))
- }
-
- # extract predicted values
- data <- data
- if (missing(data) || is.null(data)) {
- pred <- make_data_frame(fitted.class = predict(model, type = "class", ...))
- probs <- make_data_frame(predict(model, type = "posterior", ...))
- names(probs) <- paste0("Pr(", names(probs), ")")
- pred <- make_data_frame(pred, probs)
- } else {
- # setup data
- if (is.null(at)) {
- out <- data
- } else {
- out <- build_datalist(data, at = at, as.data.frame = TRUE)
- at_specification <- attr(out, "at_specification")
- }
- # calculate predictions
- tmp <- predict(model, newdata = out, type = "class", ...)
- tmp_probs <- make_data_frame(predict(model, newdata = out, type = "posterior", ...))
- names(tmp_probs) <- paste0("Pr(", names(tmp_probs), ")")
- # cbind back together
- pred <- make_data_frame(out, fitted.class = tmp, se.fitted = rep(NA_real_, nrow(out)), tmp_probs)
- rm(tmp, tmp_probs)
- }
-
- # handle category argument
- if (missing(category)) {
- w <- grep("^Pr\\(", names(pred))[1L]
- category <- names(pred)[w]
- pred[["fitted"]] <- pred[[w]]
- } else {
- w <- which(names(pred) == paste0("Pr(", category, ")"))
- if (!length(w)) {
- stop(sprintf("category %s not found", category))
- }
- pred[["fitted"]] <- pred[[ w[1L] ]]
- }
-
- # variance(s) of average predictions
- vc <- NA_real_
-
- # output
- structure(pred,
- class = c("prediction", "data.frame"),
- at = if (is.null(at)) at else at_specification,
- type = NA_character_,
- call = if ("call" %in% names(model)) model[["call"]] else NULL,
- model_class = class(model),
- row.names = seq_len(nrow(pred)),
- vcov = vc,
- jacobian = NULL,
- category = category,
- weighted = FALSE)
-}
+#' @rdname prediction
+#' @export
+prediction.fda <-
+function(model,
+ data = find_data(model, parent.frame()),
+ at = NULL,
+ type = NULL,
+ calculate_se = FALSE,
+ category,
+ ...) {
+
+ if (!is.null(type)) {
+ warning(sprintf("'type' is ignored for models of class '%s'", class(model)))
+ }
+
+ # extract predicted values
+ data <- data
+ if (missing(data) || is.null(data)) {
+ pred <- make_data_frame(fitted.class = predict(model, type = "class", ...))
+ probs <- make_data_frame(predict(model, type = "posterior", ...))
+ names(probs) <- paste0("Pr(", names(probs), ")")
+ pred <- make_data_frame(pred, probs)
+ } else {
+ # setup data
+ if (is.null(at)) {
+ out <- data
+ } else {
+ out <- build_datalist(data, at = at, as.data.frame = TRUE)
+ at_specification <- attr(out, "at_specification")
+ }
+ # calculate predictions
+ tmp <- predict(model, newdata = out, type = "class", ...)
+ tmp_probs <- make_data_frame(predict(model, newdata = out, type = "posterior", ...))
+ names(tmp_probs) <- paste0("Pr(", names(tmp_probs), ")")
+ # cbind back together
+ pred <- make_data_frame(out, fitted.class = tmp, se.fitted = rep(NA_real_, nrow(out)), tmp_probs)
+ rm(tmp, tmp_probs)
+ }
+
+ # handle category argument
+ if (missing(category)) {
+ w <- grep("^Pr\\(", names(pred))[1L]
+ category <- names(pred)[w]
+ pred[["fitted"]] <- pred[[w]]
+ } else {
+ w <- which(names(pred) == paste0("Pr(", category, ")"))
+ if (!length(w)) {
+ stop(sprintf("category %s not found", category))
+ }
+ pred[["fitted"]] <- pred[[ w[1L] ]]
+ }
+
+ # variance(s) of average predictions
+ vc <- NA_real_
+
+ # output
+ structure(pred,
+ class = c("prediction", "data.frame"),
+ at = if (is.null(at)) at else at_specification,
+ type = NA_character_,
+ call = if ("call" %in% names(model)) model[["call"]] else NULL,
+ model_class = class(model),
+ row.names = seq_len(nrow(pred)),
+ vcov = vc,
+ jacobian = NULL,
+ category = category,
+ weighted = FALSE)
+}
diff --git a/R/prediction_gam.R b/R/prediction_gam.R
index 254ce7b..b19dfbc 100644
--- a/R/prediction_gam.R
+++ b/R/prediction_gam.R
@@ -1,55 +1,55 @@
-#' @rdname prediction
-#' @export
-prediction.Gam <-
-function(model,
- data = find_data(model, parent.frame()),
- at = NULL,
- type = c("response", "link", "terms"),
- calculate_se = TRUE,
- ...) {
-
- type <- match.arg(type)
-
- # extract predicted value
- data <- data
- if (missing(data) || is.null(data)) {
- if (isTRUE(calculate_se)) {
- pred <- predict(model, type = type, se.fit = TRUE, ...)
- pred <- make_data_frame(fitted = pred[["fit"]], se.fitted = pred[["se.fit"]][,1L])
- } else {
- pred <- predict(model, type = type, se.fit = FALSE, ...)
- pred <- make_data_frame(fitted = pred, se.fitted = rep(NA_real_, length(pred)))
- }
- } else {
- # setup data
- if (is.null(at)) {
- out <- data
- } else {
- out <- build_datalist(data, at = at, as.data.frame = TRUE)
- at_specification <- attr(out, "at_specification")
- }
- # calculate predictions
- if (isTRUE(calculate_se)) {
- pred <- predict(model, newdata = out, type = type, se.fit = FALSE, ...)
- pred <- make_data_frame(out, fitted = pred, se.fitted = rep(NA_real_, length(pred)))
- } else {
- pred <- predict(model, newdata = out, type = type, se.fit = FALSE, ...)
- pred <- make_data_frame(out, fitted = pred, se.fitted = rep(NA_real_, length(pred)))
- }
- }
-
- # variance(s) of average predictions
- vc <- NA_real_
-
- # output
- structure(pred,
- class = c("prediction", "data.frame"),
- at = if (is.null(at)) at else at_specification,
- type = type,
- call = if ("call" %in% names(model)) model[["call"]] else NULL,
- model_class = class(model),
- row.names = seq_len(nrow(pred)),
- vcov = vc,
- jacobian = NULL,
- weighted = FALSE)
-}
+#' @rdname prediction
+#' @export
+prediction.Gam <-
+function(model,
+ data = find_data(model, parent.frame()),
+ at = NULL,
+ type = c("response", "link", "terms"),
+ calculate_se = TRUE,
+ ...) {
+
+ type <- match.arg(type)
+
+ # extract predicted value
+ data <- data
+ if (missing(data) || is.null(data)) {
+ if (isTRUE(calculate_se)) {
+ pred <- predict(model, type = type, se.fit = TRUE, ...)
+ pred <- make_data_frame(fitted = pred[["fit"]], se.fitted = pred[["se.fit"]][,1L])
+ } else {
+ pred <- predict(model, type = type, se.fit = FALSE, ...)
+ pred <- make_data_frame(fitted = pred, se.fitted = rep(NA_real_, length(pred)))
+ }
+ } else {
+ # setup data
+ if (is.null(at)) {
+ out <- data
+ } else {
+ out <- build_datalist(data, at = at, as.data.frame = TRUE)
+ at_specification <- attr(out, "at_specification")
+ }
+ # calculate predictions
+ if (isTRUE(calculate_se)) {
+ pred <- predict(model, newdata = out, type = type, se.fit = FALSE, ...)
+ pred <- make_data_frame(out, fitted = pred, se.fitted = rep(NA_real_, length(pred)))
+ } else {
+ pred <- predict(model, newdata = out, type = type, se.fit = FALSE, ...)
+ pred <- make_data_frame(out, fitted = pred, se.fitted = rep(NA_real_, length(pred)))
+ }
+ }
+
+ # variance(s) of average predictions
+ vc <- NA_real_
+
+ # output
+ structure(pred,
+ class = c("prediction", "data.frame"),
+ at = if (is.null(at)) at else at_specification,
+ type = type,
+ call = if ("call" %in% names(model)) model[["call"]] else NULL,
+ model_class = class(model),
+ row.names = seq_len(nrow(pred)),
+ vcov = vc,
+ jacobian = NULL,
+ weighted = FALSE)
+}
diff --git a/R/prediction_gausspr.R b/R/prediction_gausspr.R
index 1cd7046..c6e22fa 100644
--- a/R/prediction_gausspr.R
+++ b/R/prediction_gausspr.R
@@ -1,71 +1,71 @@
-#' @rdname prediction
-#' @export
-prediction.gausspr <-
-function(model,
- data,
- at = NULL,
- type = NULL,
- calculate_se = TRUE,
- category,
- ...) {
-
- requireNamespace("kernlab")
-
- if (!is.null(type)) {
- warning(sprintf("'type' is ignored for models of class '%s'", class(model)))
- }
-
- # extract predicted values
- data <- data
- if (missing(data) || is.null(data)) {
- pred <- make_data_frame(fitted.class = kernlab::predict(model, type = "response", ...))
- probs <- make_data_frame(kernlab::predict(model, type = "probabilities", ...))
- names(probs) <- paste0("Pr(", names(probs), ")")
- pred <- cbind(pred, probs)
- } else {
- # setup data
- if (is.null(at)) {
- out <- data
- } else {
- out <- build_datalist(data, at = at, as.data.frame = TRUE)
- at_specification <- attr(out, "at_specification")
- }
- # calculate predictions
- tmp <- kernlab::predict(model, newdata = out, type = "response", ...)
- tmp_probs <- make_data_frame(kernlab::predict(model, newdata = out, type = "probabilities", ...))
- names(tmp_probs) <- paste0("Pr(", names(tmp_probs), ")")
- # cbind back together
- pred <- make_data_frame(out, fitted.class = tmp, tmp_probs)
- rm(tmp, tmp_probs)
- }
-
- # handle category argument
- if (missing(category)) {
- w <- grep("^Pr\\(", names(pred))[1L]
- category <- names(pred)[w]
- pred[["fitted"]] <- pred[[w]]
- } else {
- w <- which(names(pred) == paste0("Pr(", category, ")"))
- if (!length(w)) {
- stop(sprintf("category %s not found", category))
- }
- pred[["fitted"]] <- pred[[ w[1L] ]]
- }
- pred[["se.fitted"]] <- NA_real_
-
- # variance(s) of average predictions
- vc <- NA_real_
-
- # output
- structure(pred,
- class = c("prediction", "data.frame"),
- at = if (is.null(at)) at else at_specification,
- type = NA_character_,
- call = if ("call" %in% names(model)) model[["call"]] else NULL,
- model_class = class(model),
- row.names = seq_len(nrow(pred)),
- vcov = vc,
- jacobian = NULL,
- category = category,
- weighted = FALSE)
-}
+#' @rdname prediction
+#' @export
+prediction.gausspr <-
+function(model,
+ data,
+ at = NULL,
+ type = NULL,
+ calculate_se = TRUE,
+ category,
+ ...) {
+
+ requireNamespace("kernlab")
+
+ if (!is.null(type)) {
+ warning(sprintf("'type' is ignored for models of class '%s'", class(model)))
+ }
+
+ # extract predicted values
+ data <- data
+ if (missing(data) || is.null(data)) {
+ pred <- make_data_frame(fitted.class = kernlab::predict(model, type = "response", ...))
+ probs <- make_data_frame(kernlab::predict(model, type = "probabilities", ...))
+ names(probs) <- paste0("Pr(", names(probs), ")")
+ pred <- cbind(pred, probs)
+ } else {
+ # setup data
+ if (is.null(at)) {
+ out <- data
+ } else {
+ out <- build_datalist(data, at = at, as.data.frame = TRUE)
+ at_specification <- attr(out, "at_specification")
+ }
+ # calculate predictions
+ tmp <- kernlab::predict(model, newdata = out, type = "response", ...)
+ tmp_probs <- make_data_frame(kernlab::predict(model, newdata = out, type = "probabilities", ...))
+ names(tmp_probs) <- paste0("Pr(", names(tmp_probs), ")")
+ # cbind back together
+ pred <- make_data_frame(out, fitted.class = tmp, tmp_probs)
+ rm(tmp, tmp_probs)
+ }
+
+ # handle category argument
+ if (missing(category)) {
+ w <- grep("^Pr\\(", names(pred))[1L]
+ category <- names(pred)[w]
+ pred[["fitted"]] <- pred[[w]]
+ } else {
+ w <- which(names(pred) == paste0("Pr(", category, ")"))
+ if (!length(w)) {
+ stop(sprintf("category %s not found", category))
+ }
+ pred[["fitted"]] <- pred[[ w[1L] ]]
+ }
+ pred[["se.fitted"]] <- NA_real_
+
+ # variance(s) of average predictions
+ vc <- NA_real_
+
+ # output
+ structure(pred,
+ class = c("prediction", "data.frame"),
+ at = if (is.null(at)) at else at_specification,
+ type = NA_character_,
+ call = if ("call" %in% names(model)) model[["call"]] else NULL,
+ model_class = class(model),
+ row.names = seq_len(nrow(pred)),
+ vcov = vc,
+ jacobian = NULL,
+ category = category,
+ weighted = FALSE)
+}
diff --git a/R/prediction_gee.R b/R/prediction_gee.R
index 88f3ec7..2524f9e 100644
--- a/R/prediction_gee.R
+++ b/R/prediction_gee.R
@@ -1,22 +1,22 @@
-#' @rdname prediction
-#' @export
-prediction.gee <- function(model, calculate_se = FALSE, ...) {
-
- pred <- make_data_frame(fitted = predict(model, ...))
- pred[["se.fitted"]] <- NA_real_
-
- # variance(s) of average predictions
- vc <- NA_real_
-
- # output
- structure(pred,
- class = c("prediction", "data.frame"),
- at = NULL,
- type = NA_character_,
- call = if ("call" %in% names(model)) model[["call"]] else NULL,
- model_class = class(model),
- row.names = seq_len(nrow(pred)),
- vcov = vc,
- jacobian = NULL,
- weighted = FALSE)
-}
+#' @rdname prediction
+#' @export
+prediction.gee <- function(model, calculate_se = FALSE, ...) {
+
+ pred <- make_data_frame(fitted = predict(model, ...))
+ pred[["se.fitted"]] <- NA_real_
+
+ # variance(s) of average predictions
+ vc <- NA_real_
+
+ # output
+ structure(pred,
+ class = c("prediction", "data.frame"),
+ at = NULL,
+ type = NA_character_,
+ call = if ("call" %in% names(model)) model[["call"]] else NULL,
+ model_class = class(model),
+ row.names = seq_len(nrow(pred)),
+ vcov = vc,
+ jacobian = NULL,
+ weighted = FALSE)
+}
diff --git a/R/prediction_glimML.R b/R/prediction_glimML.R
index b5e1fb1..43c95d4 100644
--- a/R/prediction_glimML.R
+++ b/R/prediction_glimML.R
@@ -1,55 +1,55 @@
-#' @rdname prediction
-#' @export
-prediction.glimML <-
-function(model,
- data = find_data(model, parent.frame()),
- at = NULL,
- type = c("response", "link"),
- calculate_se = TRUE,
- ...) {
-
- requireNamespace("aod")
-
- type <- match.arg(type)
-
- # extract predicted values
- data <- data
- if (missing(data) || is.null(data)) {
- if (isTRUE(calculate_se)) {
- pred <- aod::predict(model, type = type, se.fit = TRUE, ...)
- pred <- make_data_frame(fitted = pred[["fit"]], se.fitted = pred[["se.fit"]])
- } else {
- pred <- aod::predict(model, type = type, se.fit = FALSE, ...)
- pred <- make_data_frame(fitted = pred, se.fitted = rep(NA_real_, length(pred)))
- }
- } else {
- # setup data
- data <- build_datalist(data, at = at, as.data.frame = TRUE)
- at_specification <- attr(data, "at_specification")
- # calculate predictions
- if (isTRUE(calculate_se)) {
- tmp <- aod::predict(model, newdata = data, type = type, se.fit = TRUE, ...)
- # cbind back together
- pred <- make_data_frame(data, fitted = tmp[["fit"]], se.fitted = tmp[["se.fit"]])
- } else {
- tmp <- aod::predict(model, newdata = data, type = type, se.fit = FALSE, ...)
- # cbind back together
- pred <- make_data_frame(data, fitted = tmp, se.fitted = rep(NA_real_, nrow(data)))
- }
- }
-
- # variance(s) of average predictions
- vc <- NA_real_
-
- # output
- structure(pred,
- class = c("prediction", "data.frame"),
- at = if (is.null(at)) at else at_specification,
- type = type,
- call = if ("call" %in% names(model)) model[["call"]] else NULL,
- model_class = class(model),
- row.names = seq_len(nrow(pred)),
- vcov = vc,
- jacobian = NULL,
- weighted = FALSE)
-}
+#' @rdname prediction
+#' @export
+prediction.glimML <-
+function(model,
+ data = find_data(model, parent.frame()),
+ at = NULL,
+ type = c("response", "link"),
+ calculate_se = TRUE,
+ ...) {
+
+ requireNamespace("aod")
+
+ type <- match.arg(type)
+
+ # extract predicted values
+ data <- data
+ if (missing(data) || is.null(data)) {
+ if (isTRUE(calculate_se)) {
+ pred <- aod::predict(model, type = type, se.fit = TRUE, ...)
+ pred <- make_data_frame(fitted = pred[["fit"]], se.fitted = pred[["se.fit"]])
+ } else {
+ pred <- aod::predict(model, type = type, se.fit = FALSE, ...)
+ pred <- make_data_frame(fitted = pred, se.fitted = rep(NA_real_, length(pred)))
+ }
+ } else {
+ # setup data
+ data <- build_datalist(data, at = at, as.data.frame = TRUE)
+ at_specification <- attr(data, "at_specification")
+ # calculate predictions
+ if (isTRUE(calculate_se)) {
+ tmp <- aod::predict(model, newdata = data, type = type, se.fit = TRUE, ...)
+ # cbind back together
+ pred <- make_data_frame(data, fitted = tmp[["fit"]], se.fitted = tmp[["se.fit"]])
+ } else {
+ tmp <- aod::predict(model, newdata = data, type = type, se.fit = FALSE, ...)
+ # cbind back together
+ pred <- make_data_frame(data, fitted = tmp, se.fitted = rep(NA_real_, nrow(data)))
+ }
+ }
+
+ # variance(s) of average predictions
+ vc <- NA_real_
+
+ # output
+ structure(pred,
+ class = c("prediction", "data.frame"),
+ at = if (is.null(at)) at else at_specification,
+ type = type,
+ call = if ("call" %in% names(model)) model[["call"]] else NULL,
+ model_class = class(model),
+ row.names = seq_len(nrow(pred)),
+ vcov = vc,
+ jacobian = NULL,
+ weighted = FALSE)
+}
diff --git a/R/prediction_glimQL.R b/R/prediction_glimQL.R
index 1eb67ec..2fd141f 100644
--- a/R/prediction_glimQL.R
+++ b/R/prediction_glimQL.R
@@ -1,55 +1,55 @@
-#' @rdname prediction
-#' @export
-prediction.glimQL <-
-function(model,
- data = find_data(model, parent.frame()),
- at = NULL,
- type = c("response", "link"),
- calculate_se = TRUE,
- ...) {
-
- requireNamespace("aod")
-
- type <- match.arg(type)
-
- # extract predicted values
- data <- data
- if (missing(data) || is.null(data)) {
- if (isTRUE(calculate_se)) {
- pred <- aod::predict(model, type = type, se.fit = TRUE, ...)
- pred <- make_data_frame(fitted = pred[["fit"]], se.fitted = pred[["se.fit"]])
- } else {
- pred <- aod::predict(model, type = type, se.fit = FALSE, ...)
- pred <- make_data_frame(fitted = pred, se.fitted = rep(NA_real_, length(pred)))
- }
- } else {
- # setup data
- data <- build_datalist(data, at = at, as.data.frame = TRUE)
- at_specification <- attr(data, "at_specification")
- # calculate predictions
- if (isTRUE(calculate_se)) {
- tmp <- aod::predict(model, newdata = data, type = type, se.fit = TRUE, ...)
- # cbind back together
- pred <- make_data_frame(data, fitted = tmp[["fit"]], se.fitted = tmp[["se.fit"]])
- } else {
- tmp <- aod::predict(model, newdata = data, type = type, se.fit = FALSE, ...)
- # cbind back together
- pred <- make_data_frame(data, fitted = tmp, se.fitted = rep(NA_real_, nrow(data)))
- }
- }
-
- # variance(s) of average predictions
- vc <- NA_real_
-
- # output
- structure(pred,
- class = c("prediction", "data.frame"),
- at = if (is.null(at)) at else at_specification,
- type = type,
- call = if ("call" %in% names(model)) model[["call"]] else NULL,
- model_class = class(model),
- row.names = seq_len(nrow(pred)),
- vcov = vc,
- jacobian = NULL,
- weighted = FALSE)
-}
+#' @rdname prediction
+#' @export
+prediction.glimQL <-
+function(model,
+ data = find_data(model, parent.frame()),
+ at = NULL,
+ type = c("response", "link"),
+ calculate_se = TRUE,
+ ...) {
+
+ requireNamespace("aod")
+
+ type <- match.arg(type)
+
+ # extract predicted values
+ data <- data
+ if (missing(data) || is.null(data)) {
+ if (isTRUE(calculate_se)) {
+ pred <- aod::predict(model, type = type, se.fit = TRUE, ...)
+ pred <- make_data_frame(fitted = pred[["fit"]], se.fitted = pred[["se.fit"]])
+ } else {
+ pred <- aod::predict(model, type = type, se.fit = FALSE, ...)
+ pred <- make_data_frame(fitted = pred, se.fitted = rep(NA_real_, length(pred)))
+ }
+ } else {
+ # setup data
+ data <- build_datalist(data, at = at, as.data.frame = TRUE)
+ at_specification <- attr(data, "at_specification")
+ # calculate predictions
+ if (isTRUE(calculate_se)) {
+ tmp <- aod::predict(model, newdata = data, type = type, se.fit = TRUE, ...)
+ # cbind back together
+ pred <- make_data_frame(data, fitted = tmp[["fit"]], se.fitted = tmp[["se.fit"]])
+ } else {
+ tmp <- aod::predict(model, newdata = data, type = type, se.fit = FALSE, ...)
+ # cbind back together
+ pred <- make_data_frame(data, fitted = tmp, se.fitted = rep(NA_real_, nrow(data)))
+ }
+ }
+
+ # variance(s) of average predictions
+ vc <- NA_real_
+
+ # output
+ structure(pred,
+ class = c("prediction", "data.frame"),
+ at = if (is.null(at)) at else at_specification,
+ type = type,
+ call = if ("call" %in% names(model)) model[["call"]] else NULL,
+ model_class = class(model),
+ row.names = seq_len(nrow(pred)),
+ vcov = vc,
+ jacobian = NULL,
+ weighted = FALSE)
+}
diff --git a/R/prediction_glm.R b/R/prediction_glm.R
index 5602b62..5e00ffa 100644
--- a/R/prediction_glm.R
+++ b/R/prediction_glm.R
@@ -1,96 +1,96 @@
-#' @rdname prediction
-#' @export
-prediction.glm <-
-function(model,
- data = find_data(model, parent.frame()),
- at = NULL,
- type = c("response", "link"),
- vcov = stats::vcov(model),
- calculate_se = TRUE,
- ...) {
-
- type <- match.arg(type)
-
- # extract predicted values
- data <- data
- if (missing(data) || is.null(data)) {
- if (isTRUE(calculate_se)) {
- pred <- predict(model, type = type, se.fit = TRUE, ...)
- pred <- make_data_frame(fitted = pred[["fit"]], se.fitted = pred[["se.fit"]])
- } else {
- pred <- predict(model, type = type, se.fit = FALSE, ...)
- pred <- make_data_frame(fitted = pred, se.fitted = rep(NA_real_, length(pred)))
- }
- } else {
- # reduce memory profile
- model[["model"]] <- NULL
-
- # setup data
- out <- build_datalist(data, at = at, as.data.frame = TRUE)
- at_specification <- attr(out, "at_specification")
- # calculate predictions
- if (isTRUE(calculate_se)) {
- tmp <- predict(model, newdata = out, type = type, se.fit = TRUE, ...)
- # cbind back together
- pred <- make_data_frame(out, fitted = tmp[["fit"]], se.fitted = tmp[["se.fit"]])
- } else {
- tmp <- predict(model, newdata = out, type = type, se.fit = FALSE, ...)
- # cbind back together
- pred <- make_data_frame(out, fitted = tmp, se.fitted = rep(NA_real_, nrow(out)))
- }
- }
-
- # variance(s) of average predictions
- if (isTRUE(calculate_se)) {
- # handle case where SEs are calculated
- model_terms <- delete.response(terms(model))
- if (is.null(at)) {
- # no 'at_specification', so calculate variance of overall average prediction
- model_frame <- model.frame(model_terms, data, na.action = na.pass, xlev = model$xlevels)
- model_mat <- model.matrix(model_terms, model_frame, contrasts.arg = model$contrasts)
- if (type == "link") {
- means_for_prediction <- colMeans(model_mat)
- } else if (type == "response") {
- predictions_link <- predict(model, newdata = data, type = "link", se.fit = FALSE, ...)
- means_for_prediction <- colMeans(model$family$mu.eta(predictions_link) * model_mat)
- }
- J <- matrix(means_for_prediction, nrow = 1L)
- } else {
- # with 'at_specification', calculate variance of all counterfactual predictions
- datalist <- build_datalist(data, at = at, as.data.frame = FALSE)
- jacobian_list <- lapply(datalist, function(one) {
- model_frame <- model.frame(model_terms, one, na.action = na.pass, xlev = model$xlevels)
- model_mat <- model.matrix(model_terms, model_frame, contrasts.arg = model$contrasts)
- if (type == "link") {
- means_for_prediction <- colMeans(model_mat)
- } else if (type == "response") {
- predictions_link <- predict(model, newdata = one, type = "link", se.fit = FALSE, ...)
- means_for_prediction <- colMeans(model$family$mu.eta(predictions_link) * model_mat)
- }
- means_for_prediction
- })
- J <- do.call("rbind", jacobian_list)
- }
- vc <- diag(J %*% vcov %*% t(J))
- } else {
- # handle case where SEs are *not* calculated
- J <- NULL
- if (length(at)) {
- vc <- rep(NA_real_, nrow(at_specification))
- } else {
- vc <- NA_real_
- }
- }
-
- # output
- structure(pred,
- class = c("prediction", "data.frame"),
- at = if (is.null(at)) at else at_specification,
- type = type,
- call = if ("call" %in% names(model)) model[["call"]] else NULL,
- model_class = class(model),
- row.names = seq_len(nrow(pred)),
- vcov = vc,
- jacobian = J,
- weighted = FALSE)
-}
+#' @rdname prediction
+#' @export
+prediction.glm <-
+function(model,
+ data = find_data(model, parent.frame()),
+ at = NULL,
+ type = c("response", "link"),
+ vcov = stats::vcov(model),
+ calculate_se = TRUE,
+ ...) {
+
+ type <- match.arg(type)
+
+ # extract predicted values
+ data <- data
+ if (missing(data) || is.null(data)) {
+ if (isTRUE(calculate_se)) {
+ pred <- predict(model, type = type, se.fit = TRUE, ...)
+ pred <- make_data_frame(fitted = pred[["fit"]], se.fitted = pred[["se.fit"]])
+ } else {
+ pred <- predict(model, type = type, se.fit = FALSE, ...)
+ pred <- make_data_frame(fitted = pred, se.fitted = rep(NA_real_, length(pred)))
+ }
+ } else {
+ # reduce memory profile
+ model[["model"]] <- NULL
+
+ # setup data
+ out <- build_datalist(data, at = at, as.data.frame = TRUE)
+ at_specification <- attr(out, "at_specification")
+ # calculate predictions
+ if (isTRUE(calculate_se)) {
+ tmp <- predict(model, newdata = out, type = type, se.fit = TRUE, ...)
+ # cbind back together
+ pred <- make_data_frame(out, fitted = tmp[["fit"]], se.fitted = tmp[["se.fit"]])
+ } else {
+ tmp <- predict(model, newdata = out, type = type, se.fit = FALSE, ...)
+ # cbind back together
+ pred <- make_data_frame(out, fitted = tmp, se.fitted = rep(NA_real_, nrow(out)))
+ }
+ }
+
+ # variance(s) of average predictions
+ if (isTRUE(calculate_se)) {
+ # handle case where SEs are calculated
+ model_terms <- delete.response(terms(model))
+ if (is.null(at)) {
+ # no 'at_specification', so calculate variance of overall average prediction
+ model_frame <- model.frame(model_terms, data, na.action = na.pass, xlev = model$xlevels)
+ model_mat <- model.matrix(model_terms, model_frame, contrasts.arg = model$contrasts)
+ if (type == "link") {
+ means_for_prediction <- colMeans(model_mat)
+ } else if (type == "response") {
+ predictions_link <- predict(model, newdata = data, type = "link", se.fit = FALSE, ...)
+ means_for_prediction <- colMeans(model$family$mu.eta(predictions_link) * model_mat)
+ }
+ J <- matrix(means_for_prediction, nrow = 1L)
+ } else {
+ # with 'at_specification', calculate variance of all counterfactual predictions
+ datalist <- build_datalist(data, at = at, as.data.frame = FALSE)
+ jacobian_list <- lapply(datalist, function(one) {
+ model_frame <- model.frame(model_terms, one, na.action = na.pass, xlev = model$xlevels)
+ model_mat <- model.matrix(model_terms, model_frame, contrasts.arg = model$contrasts)
+ if (type == "link") {
+ means_for_prediction <- colMeans(model_mat)
+ } else if (type == "response") {
+ predictions_link <- predict(model, newdata = one, type = "link", se.fit = FALSE, ...)
+ means_for_prediction <- colMeans(model$family$mu.eta(predictions_link) * model_mat)
+ }
+ means_for_prediction
+ })
+ J <- do.call("rbind", jacobian_list)
+ }
+ vc <- diag(J %*% vcov %*% t(J))
+ } else {
+ # handle case where SEs are *not* calculated
+ J <- NULL
+ if (length(at)) {
+ vc <- rep(NA_real_, nrow(at_specification))
+ } else {
+ vc <- NA_real_
+ }
+ }
+
+ # output
+ structure(pred,
+ class = c("prediction", "data.frame"),
+ at = if (is.null(at)) at else at_specification,
+ type = type,
+ call = if ("call" %in% names(model)) model[["call"]] else NULL,
+ model_class = class(model),
+ row.names = seq_len(nrow(pred)),
+ vcov = vc,
+ jacobian = J,
+ weighted = FALSE)
+}
diff --git a/R/prediction_glmnet.R b/R/prediction_glmnet.R
index 72d6e2b..eead187 100644
--- a/R/prediction_glmnet.R
+++ b/R/prediction_glmnet.R
@@ -1,47 +1,47 @@
-#' @rdname prediction
-#' @param lambda For models of class \dQuote{glmnet}, a value of the penalty parameter at which predictions are required.
-#' @export
-prediction.glmnet <-
-function(
- model,
- data,
- lambda = model[["lambda"]][1L],
- at = NULL,
- type = c("response", "link"),
- calculate_se = FALSE,
- ...
-) {
-
- # glmnet models only operate with a matrix interface
-
- type <- match.arg(type)
-
- # extract predicted values
- data <- data
- if (missing(data) || is.null(data)) {
- warning(sprintf("'data' is required for models of class '%s'", class(model)))
- } else {
- # setup data
- out <- build_datalist(data, at = at, as.data.frame = TRUE)
- at_specification <- attr(out, "at_specification")
- # calculate predictions
- tmp <- predict(model, newx = out, type = type, s = lambda, ...)
- # cbind back together
- pred <- make_data_frame(out, fitted = tmp[, 1L, drop = TRUE], se.fitted = rep(NA_real_, nrow(out)))
- }
-
- # variance(s) of average predictions
- vc <- NA_real_
-
- # output
- structure(pred,
- class = c("prediction", "data.frame"),
- at = if (is.null(at)) at else at_specification,
- type = type,
- call = if ("call" %in% names(model)) model[["call"]] else NULL,
- model_class = class(model),
- row.names = seq_len(nrow(pred)),
- vcov = vc,
- jacobian = NULL,
- weighted = FALSE)
-}
+#' @rdname prediction
+#' @param lambda For models of class \dQuote{glmnet}, a value of the penalty parameter at which predictions are required.
+#' @export
+prediction.glmnet <-
+function(
+ model,
+ data,
+ lambda = model[["lambda"]][1L],
+ at = NULL,
+ type = c("response", "link"),
+ calculate_se = FALSE,
+ ...
+) {
+
+ # glmnet models only operate with a matrix interface
+
+ type <- match.arg(type)
+
+ # extract predicted values
+ data <- data
+ if (missing(data) || is.null(data)) {
+ warning(sprintf("'data' is required for models of class '%s'", class(model)))
+ } else {
+ # setup data
+ out <- build_datalist(data, at = at, as.data.frame = TRUE)
+ at_specification <- attr(out, "at_specification")
+ # calculate predictions
+ tmp <- predict(model, newx = out, type = type, s = lambda, ...)
+ # cbind back together
+ pred <- make_data_frame(out, fitted = tmp[, 1L, drop = TRUE], se.fitted = rep(NA_real_, nrow(out)))
+ }
+
+ # variance(s) of average predictions
+ vc <- NA_real_
+
+ # output
+ structure(pred,
+ class = c("prediction", "data.frame"),
+ at = if (is.null(at)) at else at_specification,
+ type = type,
+ call = if ("call" %in% names(model)) model[["call"]] else NULL,
+ model_class = class(model),
+ row.names = seq_len(nrow(pred)),
+ vcov = vc,
+ jacobian = NULL,
+ weighted = FALSE)
+}
diff --git a/R/prediction_glmx.R b/R/prediction_glmx.R
index 38036f1..9d94751 100644
--- a/R/prediction_glmx.R
+++ b/R/prediction_glmx.R
@@ -1,48 +1,48 @@
-#' @rdname prediction
-#' @export
-prediction.glmx <-
-function(model,
- data = find_data(model, parent.frame()),
- at = NULL,
- type = c("response", "link"),
- calculate_se = FALSE,
- ...) {
-
- type <- match.arg(type)
-
- # extract predicted values
- data <- data
- if (missing(data) || is.null(data)) {
- pred <- make_data_frame(fitted = predict(model, newdata = data, type = type, ...))
- } else {
- # setup data
- if (is.null(at)) {
- out <- data
- } else {
- out <- build_datalist(data, at = at, as.data.frame = TRUE)
- at_specification <- attr(out, "at_specification")
- }
- # calculate predictions
- tmp <- predict(model,
- newdata = out,
- type = type,
- ...)
- # cbind back together
- pred <- make_data_frame(out, fitted = tmp, se.fitted = rep(NA_real_, length(tmp)))
- }
-
- # variance(s) of average predictions
- vc <- NA_real_
-
- # output
- structure(pred,
- class = c("prediction", "data.frame"),
- at = if (is.null(at)) at else at_specification,
- type = type,
- call = if ("call" %in% names(model)) model[["call"]] else NULL,
- model_class = class(model),
- row.names = seq_len(nrow(pred)),
- vcov = vc,
- jacobian = NULL,
- weighted = FALSE)
-}
+#' @rdname prediction
+#' @export
+prediction.glmx <-
+function(model,
+ data = find_data(model, parent.frame()),
+ at = NULL,
+ type = c("response", "link"),
+ calculate_se = FALSE,
+ ...) {
+
+ type <- match.arg(type)
+
+ # extract predicted values
+ data <- data
+ if (missing(data) || is.null(data)) {
+ pred <- make_data_frame(fitted = predict(model, newdata = data, type = type, ...))
+ } else {
+ # setup data
+ if (is.null(at)) {
+ out <- data
+ } else {
+ out <- build_datalist(data, at = at, as.data.frame = TRUE)
+ at_specification <- attr(out, "at_specification")
+ }
+ # calculate predictions
+ tmp <- predict(model,
+ newdata = out,
+ type = type,
+ ...)
+ # cbind back together
+ pred <- make_data_frame(out, fitted = tmp, se.fitted = rep(NA_real_, length(tmp)))
+ }
+
+ # variance(s) of average predictions
+ vc <- NA_real_
+
+ # output
+ structure(pred,
+ class = c("prediction", "data.frame"),
+ at = if (is.null(at)) at else at_specification,
+ type = type,
+ call = if ("call" %in% names(model)) model[["call"]] else NULL,
+ model_class = class(model),
+ row.names = seq_len(nrow(pred)),
+ vcov = vc,
+ jacobian = NULL,
+ weighted = FALSE)
+}
diff --git a/R/prediction_gls.R b/R/prediction_gls.R
index 40646ff..d0d0554 100644
--- a/R/prediction_gls.R
+++ b/R/prediction_gls.R
@@ -1,47 +1,47 @@
-#' @rdname prediction
-#' @export
-prediction.gls <-
-function(model,
- data = find_data(model),
- at = NULL,
- calculate_se = FALSE,
- ...) {
-
- # extract predicted values
- data <- data
- if (missing(data) || is.null(data)) {
- pred <- make_data_frame(fitted = predict(model, type = "class", ...),
- se.fitted = NA_real_)
- } else {
- # setup data
- if (is.null(at)) {
- out <- data
- } else {
- out <- build_datalist(data, at = at, as.data.frame = TRUE)
- at_specification <- attr(out, "at_specification")
- }
- # calculate predictions
- tmp <- predict(model,
- newdata = out,
- type = "class",
- ...)
- # cbind back together
- pred <- make_data_frame(out, fitted = tmp, se.fitted = rep(NA_real_, length(tmp)))
- }
-
- # variance(s) of average predictions
- vc <- NA_real_
-
- # output
- structure(pred,
- class = c("prediction", "data.frame"),
- at = if (is.null(at)) at else at_specification,
- type = NA_character_,
- call = if ("call" %in% names(model)) model[["call"]] else NULL,
- model_class = class(model),
- row.names = seq_len(nrow(pred)),
- vcov = vc,
- jacobian = NULL,
- weighted = FALSE)
-}
-
+#' @rdname prediction
+#' @export
+prediction.gls <-
+function(model,
+ data = find_data(model),
+ at = NULL,
+ calculate_se = FALSE,
+ ...) {
+
+ # extract predicted values
+ data <- data
+ if (missing(data) || is.null(data)) {
+ pred <- make_data_frame(fitted = predict(model, type = "class", ...),
+ se.fitted = NA_real_)
+ } else {
+ # setup data
+ if (is.null(at)) {
+ out <- data
+ } else {
+ out <- build_datalist(data, at = at, as.data.frame = TRUE)
+ at_specification <- attr(out, "at_specification")
+ }
+ # calculate predictions
+ tmp <- predict(model,
+ newdata = out,
+ type = "class",
+ ...)
+ # cbind back together
+ pred <- make_data_frame(out, fitted = tmp, se.fitted = rep(NA_real_, length(tmp)))
+ }
+
+ # variance(s) of average predictions
+ vc <- NA_real_
+
+ # output
+ structure(pred,
+ class = c("prediction", "data.frame"),
+ at = if (is.null(at)) at else at_specification,
+ type = NA_character_,
+ call = if ("call" %in% names(model)) model[["call"]] else NULL,
+ model_class = class(model),
+ row.names = seq_len(nrow(pred)),
+ vcov = vc,
+ jacobian = NULL,
+ weighted = FALSE)
+}
+
diff --git a/R/prediction_hetglm.R b/R/prediction_hetglm.R
index ff94ed1..ae636fb 100644
--- a/R/prediction_hetglm.R
+++ b/R/prediction_hetglm.R
@@ -1,48 +1,48 @@
-#' @rdname prediction
-#' @export
-prediction.hetglm <-
-function(model,
- data = find_data(model, parent.frame()),
- at = NULL,
- type = c("response", "link", "scale"),
- calculate_se = FALSE,
- ...) {
-
- type <- match.arg(type)
-
- # extract predicted values
- data <- data
- if (missing(data) || is.null(data)) {
- pred <- make_data_frame(fitted = predict(model, type = type, ...))
- } else {
- # setup data
- if (is.null(at)) {
- out <- data
- } else {
- out <- build_datalist(data, at = at, as.data.frame = TRUE)
- at_specification <- attr(out, "at_specification")
- }
- # calculate predictions
- tmp <- predict(model,
- newdata = out,
- type = type,
- ...)
- # cbind back together
- pred <- make_data_frame(out, fitted = tmp, se.fitted = rep(NA_real_, length(tmp)))
- }
-
- # variance(s) of average predictions
- vc <- NA_real_
-
- # output
- structure(pred,
- class = c("prediction", "data.frame"),
- at = if (is.null(at)) at else at_specification,
- type = type,
- call = if ("call" %in% names(model)) model[["call"]] else NULL,
- model_class = class(model),
- row.names = seq_len(nrow(pred)),
- vcov = vc,
- jacobian = NULL,
- weighted = FALSE)
-}
+#' @rdname prediction
+#' @export
+prediction.hetglm <-
+function(model,
+ data = find_data(model, parent.frame()),
+ at = NULL,
+ type = c("response", "link", "scale"),
+ calculate_se = FALSE,
+ ...) {
+
+ type <- match.arg(type)
+
+ # extract predicted values
+ data <- data
+ if (missing(data) || is.null(data)) {
+ pred <- make_data_frame(fitted = predict(model, type = type, ...))
+ } else {
+ # setup data
+ if (is.null(at)) {
+ out <- data
+ } else {
+ out <- build_datalist(data, at = at, as.data.frame = TRUE)
+ at_specification <- attr(out, "at_specification")
+ }
+ # calculate predictions
+ tmp <- predict(model,
+ newdata = out,
+ type = type,
+ ...)
+ # cbind back together
+ pred <- make_data_frame(out, fitted = tmp, se.fitted = rep(NA_real_, length(tmp)))
+ }
+
+ # variance(s) of average predictions
+ vc <- NA_real_
+
+ # output
+ structure(pred,
+ class = c("prediction", "data.frame"),
+ at = if (is.null(at)) at else at_specification,
+ type = type,
+ call = if ("call" %in% names(model)) model[["call"]] else NULL,
+ model_class = class(model),
+ row.names = seq_len(nrow(pred)),
+ vcov = vc,
+ jacobian = NULL,
+ weighted = FALSE)
+}
diff --git a/R/prediction_hurdle.R b/R/prediction_hurdle.R
index 7085ece..01a349d 100644
--- a/R/prediction_hurdle.R
+++ b/R/prediction_hurdle.R
@@ -1,45 +1,45 @@
-#' @rdname prediction
-#' @export
-prediction.hurdle <-
-function(model,
- data = find_data(model, parent.frame()),
- at = NULL,
- type = c("response", "count", "prob", "zero"),
- calculate_se = FALSE,
- ...) {
-
- type <- match.arg(type)
-
- # extract predicted values
- data <- data
- if (missing(data) || is.null(data)) {
- pred <- predict(model, type = type, ...)
- pred <- make_data_frame(fitted = pred[["fit"]])
- } else {
- # setup data
- if (is.null(at)) {
- out <- data
- } else {
- out <- build_datalist(data, at = at, as.data.frame = TRUE)
- at_specification <- attr(out, "at_specification")
- }
- # calculate predictions
- pred <- predict(model, newdata = out, type = type, ...)
- pred <- make_data_frame(out, fitted = pred, se.fitted = rep(NA_real_, nrow(out)))
- }
-
- # variance(s) of average predictions
- vc <- NA_real_
-
- # output
- structure(pred,
- class = c("prediction", "data.frame"),
- at = if (is.null(at)) at else at_specification,
- type = type,
- call = if ("call" %in% names(model)) model[["call"]] else NULL,
- model_class = class(model),
- row.names = seq_len(nrow(pred)),
- vcov = vc,
- jacobian = NULL,
- weighted = FALSE)
-}
+#' @rdname prediction
+#' @export
+prediction.hurdle <-
+function(model,
+ data = find_data(model, parent.frame()),
+ at = NULL,
+ type = c("response", "count", "prob", "zero"),
+ calculate_se = FALSE,
+ ...) {
+
+ type <- match.arg(type)
+
+ # extract predicted values
+ data <- data
+ if (missing(data) || is.null(data)) {
+ pred <- predict(model, type = type, ...)
+ pred <- make_data_frame(fitted = pred[["fit"]])
+ } else {
+ # setup data
+ if (is.null(at)) {
+ out <- data
+ } else {
+ out <- build_datalist(data, at = at, as.data.frame = TRUE)
+ at_specification <- attr(out, "at_specification")
+ }
+ # calculate predictions
+ pred <- predict(model, newdata = out, type = type, ...)
+ pred <- make_data_frame(out, fitted = pred, se.fitted = rep(NA_real_, nrow(out)))
+ }
+
+ # variance(s) of average predictions
+ vc <- NA_real_
+
+ # output
+ structure(pred,
+ class = c("prediction", "data.frame"),
+ at = if (is.null(at)) at else at_specification,
+ type = type,
+ call = if ("call" %in% names(model)) model[["call"]] else NULL,
+ model_class = class(model),
+ row.names = seq_len(nrow(pred)),
+ vcov = vc,
+ jacobian = NULL,
+ weighted = FALSE)
+}
diff --git a/R/prediction_hxlr.R b/R/prediction_hxlr.R
index 74d8b68..477d6bf 100644
--- a/R/prediction_hxlr.R
+++ b/R/prediction_hxlr.R
@@ -1,46 +1,46 @@
-#' @rdname prediction
-#' @export
-prediction.hxlr <-
-function(model,
- data = find_data(model),
- at = NULL,
- type = c("class", "probability", "cumprob", "location", "scale"),
- calculate_se = FALSE,
- ...) {
-
- type <- match.arg(type)
-
- # extract predicted values
- data <- data
- if (missing(data) || is.null(data)) {
- pred <- make_data_frame(fitted = predict(model, type = type, ...),
- se.fitted = NA_real_)
- } else {
- # setup data
- if (is.null(at)) {
- out <- data
- } else {
- out <- build_datalist(data, at = at, as.data.frame = TRUE)
- at_specification <- attr(out, "at_specification")
- }
- # calculate predictions
- tmp <- predict(model, newdata = out, type = "class", ...)
- # cbind back together
- pred <- make_data_frame(out, fitted = tmp, se.fitted = rep(NA_real_, nrow(out)))
- }
-
- # variance(s) of average predictions
- vc <- NA_real_
-
- # output
- structure(pred,
- class = c("prediction", "data.frame"),
- at = if (is.null(at)) at else at_specification,
- type = type,
- call = if ("call" %in% names(model)) model[["call"]] else NULL,
- model_class = class(model),
- row.names = seq_len(nrow(pred)),
- vcov = vc,
- jacobian = NULL,
- weighted = FALSE)
-}
+#' @rdname prediction
+#' @export
+prediction.hxlr <-
+function(model,
+ data = find_data(model),
+ at = NULL,
+ type = c("class", "probability", "cumprob", "location", "scale"),
+ calculate_se = FALSE,
+ ...) {
+
+ type <- match.arg(type)
+
+ # extract predicted values
+ data <- data
+ if (missing(data) || is.null(data)) {
+ pred <- make_data_frame(fitted = predict(model, type = type, ...),
+ se.fitted = NA_real_)
+ } else {
+ # setup data
+ if (is.null(at)) {
+ out <- data
+ } else {
+ out <- build_datalist(data, at = at, as.data.frame = TRUE)
+ at_specification <- attr(out, "at_specification")
+ }
+ # calculate predictions
+ tmp <- predict(model, newdata = out, type = "class", ...)
+ # cbind back together
+ pred <- make_data_frame(out, fitted = tmp, se.fitted = rep(NA_real_, nrow(out)))
+ }
+
+ # variance(s) of average predictions
+ vc <- NA_real_
+
+ # output
+ structure(pred,
+ class = c("prediction", "data.frame"),
+ at = if (is.null(at)) at else at_specification,
+ type = type,
+ call = if ("call" %in% names(model)) model[["call"]] else NULL,
+ model_class = class(model),
+ row.names = seq_len(nrow(pred)),
+ vcov = vc,
+ jacobian = NULL,
+ weighted = FALSE)
+}
diff --git a/R/prediction_ivreg.R b/R/prediction_ivreg.R
index 1be85fb..9380692 100644
--- a/R/prediction_ivreg.R
+++ b/R/prediction_ivreg.R
@@ -1,38 +1,38 @@
-#' @rdname prediction
-#' @export
-prediction.ivreg <- function(model, data = find_data(model, parent.frame()), at = NULL, calculate_se = FALSE, ...) {
-
- # extract predicted values
- data <- data
- if (missing(data) || is.null(data)) {
- pred <- make_data_frame(fitted = predict(model, ...),
- se.fitted = NA_real_)
- } else {
- # setup data
- if (is.null(at)) {
- out <- data
- } else {
- out <- build_datalist(data, at = at, as.data.frame = TRUE)
- at_specification <- attr(out, "at_specification")
- }
- # calculate predictions
- tmp <- predict(model, newdata = out, ...)
- # cbind back together
- pred <- make_data_frame(out, fitted = tmp, se.fitted = rep(NA_real_, nrow(out)))
- }
-
- # variance(s) of average predictions
- vc <- NA_real_
-
- # output
- structure(pred,
- class = c("prediction", "data.frame"),
- at = if (is.null(at)) at else at_specification,
- type = NA_character_,
- call = if ("call" %in% names(model)) model[["call"]] else NULL,
- model_class = class(model),
- row.names = seq_len(nrow(pred)),
- vcov = vc,
- jacobian = NULL,
- weighted = FALSE)
-}
+#' @rdname prediction
+#' @export
+prediction.ivreg <- function(model, data = find_data(model, parent.frame()), at = NULL, calculate_se = FALSE, ...) {
+
+ # extract predicted values
+ data <- data
+ if (missing(data) || is.null(data)) {
+ pred <- make_data_frame(fitted = predict(model, ...),
+ se.fitted = NA_real_)
+ } else {
+ # setup data
+ if (is.null(at)) {
+ out <- data
+ } else {
+ out <- build_datalist(data, at = at, as.data.frame = TRUE)
+ at_specification <- attr(out, "at_specification")
+ }
+ # calculate predictions
+ tmp <- predict(model, newdata = out, ...)
+ # cbind back together
+ pred <- make_data_frame(out, fitted = tmp, se.fitted = rep(NA_real_, nrow(out)))
+ }
+
+ # variance(s) of average predictions
+ vc <- NA_real_
+
+ # output
+ structure(pred,
+ class = c("prediction", "data.frame"),
+ at = if (is.null(at)) at else at_specification,
+ type = NA_character_,
+ call = if ("call" %in% names(model)) model[["call"]] else NULL,
+ model_class = class(model),
+ row.names = seq_len(nrow(pred)),
+ vcov = vc,
+ jacobian = NULL,
+ weighted = FALSE)
+}
diff --git a/R/prediction_knnreg.R b/R/prediction_knnreg.R
index 509b07d..5c1ff28 100644
--- a/R/prediction_knnreg.R
+++ b/R/prediction_knnreg.R
@@ -1,34 +1,34 @@
-#' @rdname prediction
-#' @export
-prediction.knnreg <- function(model, data, at = NULL, calculate_se = FALSE, ...) {
-
- # extract predicted values
- if (missing(data) || is.null(data)) {
- pred <- make_data_frame(fitted = predict(object = model, ...)[,1L])
- } else {
- # setup data
- if (is.null(at)) {
- out <- data
- } else {
- out <- build_datalist(data, at = at, as.data.frame = TRUE)
- at_specification <- attr(out, "at_specification")
- }
- pred <- make_data_frame(fitted = predict(model, newdata = data, ...))
- }
- pred[["se.fitted"]] <- NA_real_
-
- # variance(s) of average predictions
- vc <- NA_real_
-
- # output
- structure(pred,
- class = c("prediction", "data.frame"),
- at = if (is.null(at)) at else at_specification,
- type = NA_character_,
- call = if ("call" %in% names(model)) model[["call"]] else NULL,
- model_class = class(model),
- row.names = seq_len(nrow(pred)),
- vcov = vc,
- jacobian = NULL,
- weighted = FALSE)
-}
+#' @rdname prediction
+#' @export
+prediction.knnreg <- function(model, data, at = NULL, calculate_se = FALSE, ...) {
+
+ # extract predicted values
+ if (missing(data) || is.null(data)) {
+ pred <- make_data_frame(fitted = predict(object = model, ...)[,1L])
+ } else {
+ # setup data
+ if (is.null(at)) {
+ out <- data
+ } else {
+ out <- build_datalist(data, at = at, as.data.frame = TRUE)
+ at_specification <- attr(out, "at_specification")
+ }
+ pred <- make_data_frame(fitted = predict(model, newdata = data, ...))
+ }
+ pred[["se.fitted"]] <- NA_real_
+
+ # variance(s) of average predictions
+ vc <- NA_real_
+
+ # output
+ structure(pred,
+ class = c("prediction", "data.frame"),
+ at = if (is.null(at)) at else at_specification,
+ type = NA_character_,
+ call = if ("call" %in% names(model)) model[["call"]] else NULL,
+ model_class = class(model),
+ row.names = seq_len(nrow(pred)),
+ vcov = vc,
+ jacobian = NULL,
+ weighted = FALSE)
+}
diff --git a/R/prediction_kqr.R b/R/prediction_kqr.R
index 38cafa6..42630d2 100644
--- a/R/prediction_kqr.R
+++ b/R/prediction_kqr.R
@@ -1,36 +1,36 @@
-#' @rdname prediction
-#' @export
-prediction.kqr <- function(model, data, at = NULL, calculate_se = FALSE, ...) {
-
- requireNamespace("kernlab")
-
- # extract predicted values
- if (missing(data) || is.null(data)) {
- pred <- make_data_frame(fitted = kernlab::predict(object = model, ...)[,1L])
- } else {
- # setup data
- if (is.null(at)) {
- out <- data
- } else {
- out <- build_datalist(data, at = at, as.data.frame = TRUE)
- at_specification <- attr(out, "at_specification")
- }
- pred <- make_data_frame(fitted = kernlab::predict(model, newdata = data,...)[,1L])
- }
- pred[["se.fitted"]] <- NA_real_
-
- # variance(s) of average predictions
- vc <- NA_real_
-
- # output
- structure(pred,
- class = c("prediction", "data.frame"),
- at = if (is.null(at)) at else at_specification,
- type = NA_character_,
- call = if ("call" %in% names(model)) model[["call"]] else NULL,
- model_class = class(model),
- row.names = seq_len(nrow(pred)),
- vcov = vc,
- jacobian = NULL,
- weighted = FALSE)
-}
+#' @rdname prediction
+#' @export
+prediction.kqr <- function(model, data, at = NULL, calculate_se = FALSE, ...) {
+
+ requireNamespace("kernlab")
+
+ # extract predicted values
+ if (missing(data) || is.null(data)) {
+ pred <- make_data_frame(fitted = kernlab::predict(object = model, ...)[,1L])
+ } else {
+ # setup data
+ if (is.null(at)) {
+ out <- data
+ } else {
+ out <- build_datalist(data, at = at, as.data.frame = TRUE)
+ at_specification <- attr(out, "at_specification")
+ }
+ pred <- make_data_frame(fitted = kernlab::predict(model, newdata = data,...)[,1L])
+ }
+ pred[["se.fitted"]] <- NA_real_
+
+ # variance(s) of average predictions
+ vc <- NA_real_
+
+ # output
+ structure(pred,
+ class = c("prediction", "data.frame"),
+ at = if (is.null(at)) at else at_specification,
+ type = NA_character_,
+ call = if ("call" %in% names(model)) model[["call"]] else NULL,
+ model_class = class(model),
+ row.names = seq_len(nrow(pred)),
+ vcov = vc,
+ jacobian = NULL,
+ weighted = FALSE)
+}
diff --git a/R/prediction_ksvm.R b/R/prediction_ksvm.R
index 2335bcd..6f933d5 100644
--- a/R/prediction_ksvm.R
+++ b/R/prediction_ksvm.R
@@ -1,3 +1,3 @@
-#' @rdname prediction
-#' @export
-prediction.ksvm <- prediction.gausspr
+#' @rdname prediction
+#' @export
+prediction.ksvm <- prediction.gausspr
diff --git a/R/prediction_lda.R b/R/prediction_lda.R
index 8cde8d0..1d1f00d 100644
--- a/R/prediction_lda.R
+++ b/R/prediction_lda.R
@@ -1,63 +1,63 @@
-# @rdname prediction
-# @export
-prediction.lda <-
-function(model,
- data = find_data(model, parent.frame()),
- at = NULL,
- calculate_se = FALSE,
- category,
- ...) {
-
- # extract predicted values
- data <- data
- if (missing(data) || is.null(data)) {
- pred <- predict(model, ...)
- colnames(pred[["posterior"]]) <- paste0("Pr(", colnames(pred[["posterior"]]), ")")
- pred <- make_data_frame(class = pred[["class"]],
- pred[["x"]],
- pred[["posterior"]])
- } else {
- # setup data
- if (is.null(at)) {
- out <- data
- } else {
- out <- build_datalist(data, at = at, as.data.frame = TRUE)
- at_specification <- attr(out, "at_specification")
- }
- # calculate predictions
- tmp <- predict(model, newdata = out, ...)
- colnames(tmp[["posterior"]]) <- paste0("Pr(", colnames(tmp[["posterior"]]), ")")
- # cbind back together
- pred <- make_data_frame(out, make_data_frame(tmp[["x"]]), class = tmp[["class"]], tmp[["posterior"]])
- pred[["se.fitted"]] <- NA_real_
- }
-
- # handle category argument
- if (missing(category)) {
- w <- grep("^Pr\\(", names(pred))[1L]
- category <- names(pred)[w]
- pred[["fitted"]] <- pred[[w]]
- } else {
- w <- which(names(pred) == paste0("Pr(", category, ")"))
- if (!length(w)) {
- stop(sprintf("category %s not found", category))
- }
- pred[["fitted"]] <- pred[[ w[1L] ]]
- }
-
- # variance(s) of average predictions
- vc <- NA_real_
-
- # output
- structure(pred,
- class = c("prediction", "data.frame"),
- at = if (is.null(at)) at else at_specification,
- type = NA_character_,
- call = if ("call" %in% names(model)) model[["call"]] else NULL,
- model_class = class(model),
- row.names = seq_len(nrow(pred)),
- vcov = vc,
- jacobian = NULL,
- category = category,
- weighted = FALSE)
-}
+# @rdname prediction
+# @export
+prediction.lda <-
+function(model,
+ data = find_data(model, parent.frame()),
+ at = NULL,
+ calculate_se = FALSE,
+ category,
+ ...) {
+
+ # extract predicted values
+ data <- data
+ if (missing(data) || is.null(data)) {
+ pred <- predict(model, ...)
+ colnames(pred[["posterior"]]) <- paste0("Pr(", colnames(pred[["posterior"]]), ")")
+ pred <- make_data_frame(class = pred[["class"]],
+ pred[["x"]],
+ pred[["posterior"]])
+ } else {
+ # setup data
+ if (is.null(at)) {
+ out <- data
+ } else {
+ out <- build_datalist(data, at = at, as.data.frame = TRUE)
+ at_specification <- attr(out, "at_specification")
+ }
+ # calculate predictions
+ tmp <- predict(model, newdata = out, ...)
+ colnames(tmp[["posterior"]]) <- paste0("Pr(", colnames(tmp[["posterior"]]), ")")
+ # cbind back together
+ pred <- make_data_frame(out, make_data_frame(tmp[["x"]]), class = tmp[["class"]], tmp[["posterior"]])
+ pred[["se.fitted"]] <- NA_real_
+ }
+
+ # handle category argument
+ if (missing(category)) {
+ w <- grep("^Pr\\(", names(pred))[1L]
+ category <- names(pred)[w]
+ pred[["fitted"]] <- pred[[w]]
+ } else {
+ w <- which(names(pred) == paste0("Pr(", category, ")"))
+ if (!length(w)) {
+ stop(sprintf("category %s not found", category))
+ }
+ pred[["fitted"]] <- pred[[ w[1L] ]]
+ }
+
+ # variance(s) of average predictions
+ vc <- NA_real_
+
+ # output
+ structure(pred,
+ class = c("prediction", "data.frame"),
+ at = if (is.null(at)) at else at_specification,
+ type = NA_character_,
+ call = if ("call" %in% names(model)) model[["call"]] else NULL,
+ model_class = class(model),
+ row.names = seq_len(nrow(pred)),
+ vcov = vc,
+ jacobian = NULL,
+ category = category,
+ weighted = FALSE)
+}
diff --git a/R/prediction_lm.R b/R/prediction_lm.R
index 54b638e..7336ff6 100644
--- a/R/prediction_lm.R
+++ b/R/prediction_lm.R
@@ -1,85 +1,85 @@
-#' @rdname prediction
-#' @export
-prediction.lm <-
-function(model,
- data = find_data(model, parent.frame()),
- at = NULL,
- type = "response",
- vcov = stats::vcov(model),
- calculate_se = TRUE,
- ...) {
-
- type <- match.arg(type)
-
- # extract predicted values
- data <- data
- if (missing(data) || is.null(data)) {
- if (isTRUE(calculate_se)) {
- pred <- predict(model, type = type, se.fit = TRUE, ...)
- pred <- make_data_frame(fitted = pred[["fit"]], se.fitted = pred[["se.fit"]])
- } else {
- pred <- predict(model, type = type, se.fit = FALSE, ...)
- pred <- make_data_frame(fitted = pred, se.fitted = rep(NA_real_, length(pred)))
- }
- } else {
- # reduce memory profile
- model[["model"]] <- NULL
-
- # setup data
- datalist <- build_datalist(data, at = at, as.data.frame = TRUE)
- at_specification <- attr(datalist, "at_specification")
- # calculate predictions
- if (isTRUE(calculate_se)) {
- tmp <- predict(model, newdata = datalist, type = type, se.fit = TRUE, ...)
- # cbind back together
- pred <- make_data_frame(datalist, fitted = tmp[["fit"]], se.fitted = tmp[["se.fit"]])
- } else {
- tmp <- predict(model, newdata = datalist, type = type, se.fit = FALSE, ...)
- # cbind back together
- pred <- make_data_frame(datalist, fitted = tmp, se.fitted = rep(NA_real_, nrow(datalist)))
- }
- }
-
- # variance(s) of average predictions
- if (isTRUE(calculate_se)) {
- # handle case where SEs are calculated
- J <- NULL
- model_terms <- delete.response(terms(model))
- if (is.null(at)) {
- # no 'at_specification', so calculate variance of overall average prediction
- model_frame <- model.frame(model_terms, data, na.action = na.pass, xlev = model$xlevels)
- model_mat <- model.matrix(model_terms, model_frame, contrasts.arg = model$contrasts)
- means_for_prediction <- colMeans(model_mat)
- vc <- (means_for_prediction %*% vcov %*% means_for_prediction)[1L, 1L, drop = TRUE]
- } else {
- # with 'at_specification', calculate variance of all counterfactual predictions
- datalist <- build_datalist(data, at = at, as.data.frame = FALSE)
- vc <- unlist(lapply(datalist, function(one) {
- model_frame <- model.frame(model_terms, one, na.action = na.pass, xlev = model$xlevels)
- model_mat <- model.matrix(model_terms, model_frame, contrasts.arg = model$contrasts)
- means_for_prediction <- colMeans(model_mat)
- means_for_prediction %*% vcov %*% means_for_prediction
- }))
- }
- } else {
- # handle case where SEs are *not* calculated
- J <- NULL
- if (length(at)) {
- vc <- rep(NA_real_, nrow(at_specification))
- } else {
- vc <- NA_real_
- }
- }
-
- # output
- structure(pred,
- class = c("prediction", "data.frame"),
- at = if (is.null(at)) at else at_specification,
- type = type,
- call = if ("call" %in% names(model)) model[["call"]] else NULL,
- model_class = class(model),
- row.names = seq_len(nrow(pred)),
- vcov = vc,
- jacobian = J,
- weighted = FALSE)
-}
+#' @rdname prediction
+#' @export
+prediction.lm <-
+function(model,
+ data = find_data(model, parent.frame()),
+ at = NULL,
+ type = "response",
+ vcov = stats::vcov(model),
+ calculate_se = TRUE,
+ ...) {
+
+ type <- match.arg(type)
+
+ # extract predicted values
+ data <- data
+ if (missing(data) || is.null(data)) {
+ if (isTRUE(calculate_se)) {
+ pred <- predict(model, type = type, se.fit = TRUE, ...)
+ pred <- make_data_frame(fitted = pred[["fit"]], se.fitted = pred[["se.fit"]])
+ } else {
+ pred <- predict(model, type = type, se.fit = FALSE, ...)
+ pred <- make_data_frame(fitted = pred, se.fitted = rep(NA_real_, length(pred)))
+ }
+ } else {
+ # reduce memory profile
+ model[["model"]] <- NULL
+
+ # setup data
+ datalist <- build_datalist(data, at = at, as.data.frame = TRUE)
+ at_specification <- attr(datalist, "at_specification")
+ # calculate predictions
+ if (isTRUE(calculate_se)) {
+ tmp <- predict(model, newdata = datalist, type = type, se.fit = TRUE, ...)
+ # cbind back together
+ pred <- make_data_frame(datalist, fitted = tmp[["fit"]], se.fitted = tmp[["se.fit"]])
+ } else {
+ tmp <- predict(model, newdata = datalist, type = type, se.fit = FALSE, ...)
+ # cbind back together
+ pred <- make_data_frame(datalist, fitted = tmp, se.fitted = rep(NA_real_, nrow(datalist)))
+ }
+ }
+
+ # variance(s) of average predictions
+ if (isTRUE(calculate_se)) {
+ # handle case where SEs are calculated
+ J <- NULL
+ model_terms <- delete.response(terms(model))
+ if (is.null(at)) {
+ # no 'at_specification', so calculate variance of overall average prediction
+ model_frame <- model.frame(model_terms, data, na.action = na.pass, xlev = model$xlevels)
+ model_mat <- model.matrix(model_terms, model_frame, contrasts.arg = model$contrasts)
+ means_for_prediction <- colMeans(model_mat)
+ vc <- (means_for_prediction %*% vcov %*% means_for_prediction)[1L, 1L, drop = TRUE]
+ } else {
+ # with 'at_specification', calculate variance of all counterfactual predictions
+ datalist <- build_datalist(data, at = at, as.data.frame = FALSE)
+ vc <- unlist(lapply(datalist, function(one) {
+ model_frame <- model.frame(model_terms, one, na.action = na.pass, xlev = model$xlevels)
+ model_mat <- model.matrix(model_terms, model_frame, contrasts.arg = model$contrasts)
+ means_for_prediction <- colMeans(model_mat)
+ means_for_prediction %*% vcov %*% means_for_prediction
+ }))
+ }
+ } else {
+ # handle case where SEs are *not* calculated
+ J <- NULL
+ if (length(at)) {
+ vc <- rep(NA_real_, nrow(at_specification))
+ } else {
+ vc <- NA_real_
+ }
+ }
+
+ # output
+ structure(pred,
+ class = c("prediction", "data.frame"),
+ at = if (is.null(at)) at else at_specification,
+ type = type,
+ call = if ("call" %in% names(model)) model[["call"]] else NULL,
+ model_class = class(model),
+ row.names = seq_len(nrow(pred)),
+ vcov = vc,
+ jacobian = J,
+ weighted = FALSE)
+}
diff --git a/R/prediction_lme.R b/R/prediction_lme.R
index 4c28f85..afde554 100644
--- a/R/prediction_lme.R
+++ b/R/prediction_lme.R
@@ -1,40 +1,40 @@
-#' @rdname prediction
-#' @export
-prediction.lme <-
-function(model, data = find_data(model), at = NULL, calculate_se = FALSE, ...) {
-
- # extract predicted values
- data <- data
- if (missing(data) || is.null(data)) {
- pred <- make_data_frame(fitted = predict(model, ...))
- } else {
- # setup data
- if (is.null(at)) {
- out <- data
- } else {
- out <- build_datalist(data, at = at, as.data.frame = TRUE)
- at_specification <- attr(out, "at_specification")
- }
- # calculate predictions
- tmp <- predict(model,
- newdata = out,
- ...)
- # cbind back together
- pred <- make_data_frame(out, fitted = tmp, se.fitted = rep(NA_real_, nrow(out)))
- }
-
- # variance(s) of average predictions
- vc <- NA_real_
-
- # output
- structure(pred,
- class = c("prediction", "data.frame"),
- at = if (is.null(at)) at else at_specification,
- type = NA_character_,
- call = if ("call" %in% names(model)) model[["call"]] else NULL,
- model_class = class(model),
- row.names = seq_len(nrow(pred)),
- vcov = vc,
- jacobian = NULL,
- weighted = FALSE)
-}
+#' @rdname prediction
+#' @export
+prediction.lme <-
+function(model, data = find_data(model), at = NULL, calculate_se = FALSE, ...) {
+
+ # extract predicted values
+ data <- data
+ if (missing(data) || is.null(data)) {
+ pred <- make_data_frame(fitted = predict(model, ...))
+ } else {
+ # setup data
+ if (is.null(at)) {
+ out <- data
+ } else {
+ out <- build_datalist(data, at = at, as.data.frame = TRUE)
+ at_specification <- attr(out, "at_specification")
+ }
+ # calculate predictions
+ tmp <- predict(model,
+ newdata = out,
+ ...)
+ # cbind back together
+ pred <- make_data_frame(out, fitted = tmp, se.fitted = rep(NA_real_, nrow(out)))
+ }
+
+ # variance(s) of average predictions
+ vc <- NA_real_
+
+ # output
+ structure(pred,
+ class = c("prediction", "data.frame"),
+ at = if (is.null(at)) at else at_specification,
+ type = NA_character_,
+ call = if ("call" %in% names(model)) model[["call"]] else NULL,
+ model_class = class(model),
+ row.names = seq_len(nrow(pred)),
+ vcov = vc,
+ jacobian = NULL,
+ weighted = FALSE)
+}
diff --git a/R/prediction_loess.R b/R/prediction_loess.R
index 5fe3153..dcef5b3 100644
--- a/R/prediction_loess.R
+++ b/R/prediction_loess.R
@@ -1,41 +1,41 @@
-#' @rdname prediction
-#' @export
-prediction.loess <- function(model, data = find_data(model, parent.frame()), at = NULL, type = "response", calculate_se = TRUE, ...) {
-
- type <- match.arg(type)
-
- # extract predicted values
- data <- data
- if (missing(data) || is.null(data)) {
- pred <- predict(model, type = type, se = TRUE, ...)
- pred <- make_data_frame(fitted = pred[["fit"]], se.fitted = pred[["se.fit"]])
- } else {
- # setup data
- if (is.null(at)) {
- out <- data
- } else {
- out <- build_datalist(data, at = at, as.data.frame = TRUE)
- at_specification <- attr(out, "at_specification")
- }
- # calculate predictions
- tmp <- predict(model, newdata = out, type = type, se = TRUE, ...)
- # cbind back together
- pred <- make_data_frame(out, fitted = tmp[["fit"]], se.fitted = tmp[["se.fit"]])
- }
-
- # variance(s) of average predictions
- J <- NULL
- vc <- NA_real_
-
- # output
- structure(pred,
- class = c("prediction", "data.frame"),
- at = if (is.null(at)) at else at_specification,
- type = type,
- call = if ("call" %in% names(model)) model[["call"]] else NULL,
- model_class = class(model),
- row.names = seq_len(nrow(pred)),
- vcov = vc,
- jacobian = J,
- weighted = FALSE)
-}
+#' @rdname prediction
+#' @export
+prediction.loess <- function(model, data = find_data(model, parent.frame()), at = NULL, type = "response", calculate_se = TRUE, ...) {
+
+ type <- match.arg(type)
+
+ # extract predicted values
+ data <- data
+ if (missing(data) || is.null(data)) {
+ pred <- predict(model, type = type, se = TRUE, ...)
+ pred <- make_data_frame(fitted = pred[["fit"]], se.fitted = pred[["se.fit"]])
+ } else {
+ # setup data
+ if (is.null(at)) {
+ out <- data
+ } else {
+ out <- build_datalist(data, at = at, as.data.frame = TRUE)
+ at_specification <- attr(out, "at_specification")
+ }
+ # calculate predictions
+ tmp <- predict(model, newdata = out, type = type, se = TRUE, ...)
+ # cbind back together
+ pred <- make_data_frame(out, fitted = tmp[["fit"]], se.fitted = tmp[["se.fit"]])
+ }
+
+ # variance(s) of average predictions
+ J <- NULL
+ vc <- NA_real_
+
+ # output
+ structure(pred,
+ class = c("prediction", "data.frame"),
+ at = if (is.null(at)) at else at_specification,
+ type = type,
+ call = if ("call" %in% names(model)) model[["call"]] else NULL,
+ model_class = class(model),
+ row.names = seq_len(nrow(pred)),
+ vcov = vc,
+ jacobian = J,
+ weighted = FALSE)
+}
diff --git a/R/prediction_lqs.R b/R/prediction_lqs.R
index 1bbd05d..1694f3e 100644
--- a/R/prediction_lqs.R
+++ b/R/prediction_lqs.R
@@ -1,44 +1,44 @@
-#' @rdname prediction
-#' @export
-prediction.lqs <-
-function(model,
- data = find_data(model),
- at = NULL,
- calculate_se = FALSE,
- ...) {
-
- # extract predicted values
- data <- data
- if (missing(data) || is.null(data)) {
- pred <- make_data_frame(fitted = predict(model, ...), se.fitted = NA_real_)
- } else {
- # setup data
- if (is.null(at)) {
- out <- data
- } else {
- out <- build_datalist(data, at = at, as.data.frame = TRUE)
- at_specification <- attr(out, "at_specification")
- }
- # calculate predictions
- tmp <- predict(model,
- newdata = out,
- ...)
- # cbind back together
- pred <- make_data_frame(out, fitted = tmp, se.fitted = rep(NA_real_, nrow(out)))
- }
-
- # variance(s) of average predictions
- vc <- NA_real_
-
- # output
- structure(pred,
- class = c("prediction", "data.frame"),
- at = if (is.null(at)) at else at_specification,
- type = NA_character_,
- call = if ("call" %in% names(model)) model[["call"]] else NULL,
- model_class = class(model),
- row.names = seq_len(nrow(pred)),
- vcov = vc,
- jacobian = NULL,
- weighted = FALSE)
-}
+#' @rdname prediction
+#' @export
+prediction.lqs <-
+function(model,
+ data = find_data(model),
+ at = NULL,
+ calculate_se = FALSE,
+ ...) {
+
+ # extract predicted values
+ data <- data
+ if (missing(data) || is.null(data)) {
+ pred <- make_data_frame(fitted = predict(model, ...), se.fitted = NA_real_)
+ } else {
+ # setup data
+ if (is.null(at)) {
+ out <- data
+ } else {
+ out <- build_datalist(data, at = at, as.data.frame = TRUE)
+ at_specification <- attr(out, "at_specification")
+ }
+ # calculate predictions
+ tmp <- predict(model,
+ newdata = out,
+ ...)
+ # cbind back together
+ pred <- make_data_frame(out, fitted = tmp, se.fitted = rep(NA_real_, nrow(out)))
+ }
+
+ # variance(s) of average predictions
+ vc <- NA_real_
+
+ # output
+ structure(pred,
+ class = c("prediction", "data.frame"),
+ at = if (is.null(at)) at else at_specification,
+ type = NA_character_,
+ call = if ("call" %in% names(model)) model[["call"]] else NULL,
+ model_class = class(model),
+ row.names = seq_len(nrow(pred)),
+ vcov = vc,
+ jacobian = NULL,
+ weighted = FALSE)
+}
diff --git a/R/prediction_mars.R b/R/prediction_mars.R
index 97891db..0aa0cf6 100644
--- a/R/prediction_mars.R
+++ b/R/prediction_mars.R
@@ -1,45 +1,45 @@
-#' @rdname prediction
-#' @export
-prediction.mars <-
-function(model,
- data = NULL,
- at = NULL,
- type = "fitted",
- calculate_se = FALSE,
- ...) {
-
- type <- match.arg(type)
-
- # extract predicted values
- data <- data
- if (missing(data) || is.null(data)) {
- pred <- predict(model, type = type, ...)
- pred <- make_data_frame(fitted = pred[,1L], se.fitted = rep(NA_real_, length(pred)))
- } else {
- # setup data
- data <- build_datalist(data, at = at, as.data.frame = TRUE)
- at_specification <- attr(data, "at_specification")
- # calculate predictions
- if (!is.matrix(data)) {
- data <- as.matrix(data)
- }
- tmp <- predict(model, newdata = data, type = type, ...)
- # cbind back together
- pred <- make_data_frame(data, fitted = tmp[,1L], se.fitted = rep(NA_real_, nrow(data)))
- }
-
- # variance(s) of average predictions
- vc <- NA_real_
-
- # output
- structure(pred,
- class = c("prediction", "data.frame"),
- at = if (is.null(at)) at else at_specification,
- type = NA_character_,
- call = if ("call" %in% names(model)) model[["call"]] else NULL,
- model_class = class(model),
- row.names = seq_len(nrow(pred)),
- vcov = vc,
- jacobian = NULL,
- weighted = FALSE)
-}
+#' @rdname prediction
+#' @export
+prediction.mars <-
+function(model,
+ data = NULL,
+ at = NULL,
+ type = "fitted",
+ calculate_se = FALSE,
+ ...) {
+
+ type <- match.arg(type)
+
+ # extract predicted values
+ data <- data
+ if (missing(data) || is.null(data)) {
+ pred <- predict(model, type = type, ...)
+ pred <- make_data_frame(fitted = pred[,1L], se.fitted = rep(NA_real_, length(pred)))
+ } else {
+ # setup data
+ data <- build_datalist(data, at = at, as.data.frame = TRUE)
+ at_specification <- attr(data, "at_specification")
+ # calculate predictions
+ if (!is.matrix(data)) {
+ data <- as.matrix(data)
+ }
+ tmp <- predict(model, newdata = data, type = type, ...)
+ # cbind back together
+ pred <- make_data_frame(data, fitted = tmp[,1L], se.fitted = rep(NA_real_, nrow(data)))
+ }
+
+ # variance(s) of average predictions
+ vc <- NA_real_
+
+ # output
+ structure(pred,
+ class = c("prediction", "data.frame"),
+ at = if (is.null(at)) at else at_specification,
+ type = NA_character_,
+ call = if ("call" %in% names(model)) model[["call"]] else NULL,
+ model_class = class(model),
+ row.names = seq_len(nrow(pred)),
+ vcov = vc,
+ jacobian = NULL,
+ weighted = FALSE)
+}
diff --git a/R/prediction_mca.R b/R/prediction_mca.R
index 9e98e83..c54384f 100644
--- a/R/prediction_mca.R
+++ b/R/prediction_mca.R
@@ -1,39 +1,39 @@
-#' @rdname prediction
-#' @export
-prediction.mca <-
-function(model,
- data = find_data(model),
- at = NULL,
- calculate_se = FALSE,
- ...) {
-
- # extract predicted values
- # setup data
- if (is.null(at)) {
- out <- data
- } else {
- out <- build_datalist(data, at = at, as.data.frame = TRUE)
- at_specification <- attr(out, "at_specification")
- }
- # calculate predictions
- tmp <- predict(model, newdata = out, ...)
- # cbind back together
- pred <- make_data_frame(out, tmp)
- pred[["fitted"]] <- NA_real_
- pred[["se.fitted"]] <- NA_real_
-
- # variance(s) of average predictions
- vc <- NA_real_
-
- # output
- structure(pred,
- class = c("prediction", "data.frame"),
- at = if (is.null(at)) at else at_specification,
- type = NA_character_,
- call = if ("call" %in% names(model)) model[["call"]] else NULL,
- model_class = class(model),
- row.names = seq_len(nrow(pred)),
- vcov = vc,
- jacobian = NULL,
- weighted = FALSE)
-}
+#' @rdname prediction
+#' @export
+prediction.mca <-
+function(model,
+ data = find_data(model),
+ at = NULL,
+ calculate_se = FALSE,
+ ...) {
+
+ # extract predicted values
+ # setup data
+ if (is.null(at)) {
+ out <- data
+ } else {
+ out <- build_datalist(data, at = at, as.data.frame = TRUE)
+ at_specification <- attr(out, "at_specification")
+ }
+ # calculate predictions
+ tmp <- predict(model, newdata = out, ...)
+ # cbind back together
+ pred <- make_data_frame(out, tmp)
+ pred[["fitted"]] <- NA_real_
+ pred[["se.fitted"]] <- NA_real_
+
+ # variance(s) of average predictions
+ vc <- NA_real_
+
+ # output
+ structure(pred,
+ class = c("prediction", "data.frame"),
+ at = if (is.null(at)) at else at_specification,
+ type = NA_character_,
+ call = if ("call" %in% names(model)) model[["call"]] else NULL,
+ model_class = class(model),
+ row.names = seq_len(nrow(pred)),
+ vcov = vc,
+ jacobian = NULL,
+ weighted = FALSE)
+}
diff --git a/R/prediction_mclogit.R b/R/prediction_mclogit.R
index 4cc0113..3ba6049 100644
--- a/R/prediction_mclogit.R
+++ b/R/prediction_mclogit.R
@@ -1,3 +1,3 @@
-#' @rdname prediction
-#' @export
-prediction.mclogit <- prediction.default
+#' @rdname prediction
+#' @export
+prediction.mclogit <- prediction.default
diff --git a/R/prediction_merMod.R b/R/prediction_merMod.R
index 272cde4..d5cf41f 100644
--- a/R/prediction_merMod.R
+++ b/R/prediction_merMod.R
@@ -1,40 +1,40 @@
-#' @rdname prediction
-#' @param re.form An argument passed forward to \code{\link[lme4]{predict.merMod}}.
-#' @export
-prediction.merMod <-
-function(model, data = find_data(model), at = NULL, type = c("response", "link"), re.form = NULL, calculate_se = FALSE, ...) {
-
- type <- match.arg(type)
-
- # extract predicted values
- data <- data
- if (missing(data) || is.null(data)) {
- pred <- make_data_frame(fitted = predict(model, type = type, re.form = re.form, ...))
- } else {
- # setup data
- if (is.null(at)) {
- out <- data
- } else {
- out <- build_datalist(data, at = at, as.data.frame = TRUE)
- at_specification <- attr(out, "at_specification")
- }
- # calculate predictions
- tmp <- predict(model, newdata = out, type = type, re.form = re.form, ...)
- pred <- make_data_frame(out, fitted = tmp, se.fitted = rep(NA_real_, nrow(out)))
- }
-
- # variance(s) of average predictions
- vc <- NA_real_
-
- # output
- structure(pred,
- class = c("prediction", "data.frame"),
- at = if (is.null(at)) at else at_specification,
- type = type,
- call = if ("call" %in% names(model)) model[["call"]] else NULL,
- model_class = class(model),
- row.names = seq_len(nrow(pred)),
- vcov = vc,
- jacobian = NULL,
- weighted = FALSE)
-}
+#' @rdname prediction
+#' @param re.form An argument passed forward to \code{\link[lme4]{predict.merMod}}.
+#' @export
+prediction.merMod <-
+function(model, data = find_data(model), at = NULL, type = c("response", "link"), re.form = NULL, calculate_se = FALSE, ...) {
+
+ type <- match.arg(type)
+
+ # extract predicted values
+ data <- data
+ if (missing(data) || is.null(data)) {
+ pred <- make_data_frame(fitted = predict(model, type = type, re.form = re.form, ...))
+ } else {
+ # setup data
+ if (is.null(at)) {
+ out <- data
+ } else {
+ out <- build_datalist(data, at = at, as.data.frame = TRUE)
+ at_specification <- attr(out, "at_specification")
+ }
+ # calculate predictions
+ tmp <- predict(model, newdata = out, type = type, re.form = re.form, ...)
+ pred <- make_data_frame(out, fitted = tmp, se.fitted = rep(NA_real_, nrow(out)))
+ }
+
+ # variance(s) of average predictions
+ vc <- NA_real_
+
+ # output
+ structure(pred,
+ class = c("prediction", "data.frame"),
+ at = if (is.null(at)) at else at_specification,
+ type = type,
+ call = if ("call" %in% names(model)) model[["call"]] else NULL,
+ model_class = class(model),
+ row.names = seq_len(nrow(pred)),
+ vcov = vc,
+ jacobian = NULL,
+ weighted = FALSE)
+}
diff --git a/R/prediction_mlogit.R b/R/prediction_mlogit.R
index 9b472f7..88903c5 100644
--- a/R/prediction_mlogit.R
+++ b/R/prediction_mlogit.R
@@ -1,59 +1,59 @@
-# @rdname prediction
-# @export
-prediction.mlogit <-
-function(model,
- data = find_data(model, parent.frame()),
- at = NULL,
- calculate_se = FALSE,
- category,
- ...) {
-
- # extract predicted values
- data <- data
- if (missing(data) || is.null(data)) {
- warning(sprintf("'data' is ignored for models of class '%s'", class(model)))
- }
- # setup data
- if (is.null(at)) {
- out <- data
- } else {
- out <- build_datalist(data, at = at, as.data.frame = TRUE)
- at_specification <- attr(out, "at_specification")
- }
- # calculate predictions
- tmp <- make_data_frame(predict(model, newdata = out, ...))
- names(tmp) <- paste0("Pr(", seq_len(ncol(tmp)), ")")
- # cbind back together
- pred <- make_data_frame(out, tmp)
- rm(tmp)
-
- # handle category argument
- if (missing(category)) {
- w <- grep("^Pr\\(", names(pred))[1L]
- category <- names(pred)[w]
- pred[["fitted"]] <- pred[[w]]
- } else {
- w <- which(names(pred) == paste0("Pr(", category, ")"))
- if (!length(w)) {
- stop(sprintf("category %s not found", category))
- }
- pred[["fitted"]] <- pred[[ w[1L] ]]
- }
- pred[["se.fitted"]] <- NA_real_
-
- # variance(s) of average predictions
- vc <- NA_real_
-
- # output
- structure(pred,
- class = c("prediction", "data.frame"),
- at = if (is.null(at)) at else at_specification,
- type = NA_character_,
- call = if ("call" %in% names(model)) model[["call"]] else NULL,
- model_class = class(model),
- row.names = seq_len(nrow(pred)),
- vcov = vc,
- jacobian = NULL,
- category = category,
- weighted = FALSE)
-}
+# @rdname prediction
+# @export
+prediction.mlogit <-
+function(model,
+ data = find_data(model, parent.frame()),
+ at = NULL,
+ calculate_se = FALSE,
+ category,
+ ...) {
+
+ # extract predicted values
+ data <- data
+ if (missing(data) || is.null(data)) {
+ warning(sprintf("'data' is ignored for models of class '%s'", class(model)))
+ }
+ # setup data
+ if (is.null(at)) {
+ out <- data
+ } else {
+ out <- build_datalist(data, at = at, as.data.frame = TRUE)
+ at_specification <- attr(out, "at_specification")
+ }
+ # calculate predictions
+ tmp <- make_data_frame(predict(model, newdata = out, ...))
+ names(tmp) <- paste0("Pr(", seq_len(ncol(tmp)), ")")
+ # cbind back together
+ pred <- make_data_frame(out, tmp)
+ rm(tmp)
+
+ # handle category argument
+ if (missing(category)) {
+ w <- grep("^Pr\\(", names(pred))[1L]
+ category <- names(pred)[w]
+ pred[["fitted"]] <- pred[[w]]
+ } else {
+ w <- which(names(pred) == paste0("Pr(", category, ")"))
+ if (!length(w)) {
+ stop(sprintf("category %s not found", category))
+ }
+ pred[["fitted"]] <- pred[[ w[1L] ]]
+ }
+ pred[["se.fitted"]] <- NA_real_
+
+ # variance(s) of average predictions
+ vc <- NA_real_
+
+ # output
+ structure(pred,
+ class = c("prediction", "data.frame"),
+ at = if (is.null(at)) at else at_specification,
+ type = NA_character_,
+ call = if ("call" %in% names(model)) model[["call"]] else NULL,
+ model_class = class(model),
+ row.names = seq_len(nrow(pred)),
+ vcov = vc,
+ jacobian = NULL,
+ category = category,
+ weighted = FALSE)
+}
diff --git a/R/prediction_mnlogit.R b/R/prediction_mnlogit.R
index 8139cde..c23c7cd 100644
--- a/R/prediction_mnlogit.R
+++ b/R/prediction_mnlogit.R
@@ -1,64 +1,64 @@
-# @rdname prediction
-# @export
-prediction.mnlogit <-
-function(model,
- data = find_data(model, parent.frame()),
- at = NULL,
- calculate_se = FALSE,
- category,
- ...) {
-
- # extract predicted values
- data <- data
- if (missing(data) || is.null(data)) {
- pred <- make_data_frame(fitted.class = predict(model, probability = FALSE, ...))
- probs <- make_data_frame(predict(model, probability = TRUE, ...))
- names(probs) <- paste0("Pr(", names(probs), ")")
- pred <- make_data_frame(pred, probs)
- } else {
- # setup data
- if (is.null(at)) {
- out <- data
- } else {
- out <- build_datalist(data, at = at, as.data.frame = TRUE)
- at_specification <- attr(out, "at_specification")
- }
- # calculate predictions
- tmp <- predict(model, newdata = out, probability = FALSE, ...)
- tmp_probs <- make_data_frame(predict(model, newdata = out, probability = TRUE, ...))
- names(tmp_probs) <- paste0("Pr(", names(tmp_probs), ")")
- # cbind back together
- pred <- make_data_frame(out, fitted.class = tmp, tmp_probs)
- rm(tmp, tmp_probs)
- }
-
- # handle category argument
- if (missing(category)) {
- w <- grep("^Pr\\(", names(pred))[1L]
- category <- names(pred)[w]
- pred[["fitted"]] <- pred[[w]]
- } else {
- w <- which(names(pred) == paste0("Pr(", category, ")"))
- if (!length(w)) {
- stop(sprintf("category %s not found", category))
- }
- pred[["fitted"]] <- pred[[ w[1L] ]]
- }
- pred[["se.fitted"]] <- NA_real_
-
- # variance(s) of average predictions
- vc <- NA_real_
-
- # output
- structure(pred,
- class = c("prediction", "data.frame"),
- at = if (is.null(at)) at else at_specification,
- type = NA_character_,
- call = if ("call" %in% names(model)) model[["call"]] else NULL,
- model_class = class(model),
- row.names = seq_len(nrow(pred)),
- vcov = vc,
- jacobian = NULL,
- category = category,
- weighted = FALSE)
+# @rdname prediction
+# @export
+prediction.mnlogit <-
+function(model,
+ data = find_data(model, parent.frame()),
+ at = NULL,
+ calculate_se = FALSE,
+ category,
+ ...) {
+
+ # extract predicted values
+ data <- data
+ if (missing(data) || is.null(data)) {
+ pred <- make_data_frame(fitted.class = predict(model, probability = FALSE, ...))
+ probs <- make_data_frame(predict(model, probability = TRUE, ...))
+ names(probs) <- paste0("Pr(", names(probs), ")")
+ pred <- make_data_frame(pred, probs)
+ } else {
+ # setup data
+ if (is.null(at)) {
+ out <- data
+ } else {
+ out <- build_datalist(data, at = at, as.data.frame = TRUE)
+ at_specification <- attr(out, "at_specification")
+ }
+ # calculate predictions
+ tmp <- predict(model, newdata = out, probability = FALSE, ...)
+ tmp_probs <- make_data_frame(predict(model, newdata = out, probability = TRUE, ...))
+ names(tmp_probs) <- paste0("Pr(", names(tmp_probs), ")")
+ # cbind back together
+ pred <- make_data_frame(out, fitted.class = tmp, tmp_probs)
+ rm(tmp, tmp_probs)
+ }
+
+ # handle category argument
+ if (missing(category)) {
+ w <- grep("^Pr\\(", names(pred))[1L]
+ category <- names(pred)[w]
+ pred[["fitted"]] <- pred[[w]]
+ } else {
+ w <- which(names(pred) == paste0("Pr(", category, ")"))
+ if (!length(w)) {
+ stop(sprintf("category %s not found", category))
+ }
+ pred[["fitted"]] <- pred[[ w[1L] ]]
+ }
+ pred[["se.fitted"]] <- NA_real_
+
+ # variance(s) of average predictions
+ vc <- NA_real_
+
+ # output
+ structure(pred,
+ class = c("prediction", "data.frame"),
+ at = if (is.null(at)) at else at_specification,
+ type = NA_character_,
+ call = if ("call" %in% names(model)) model[["call"]] else NULL,
+ model_class = class(model),
+ row.names = seq_len(nrow(pred)),
+ vcov = vc,
+ jacobian = NULL,
+ category = category,
+ weighted = FALSE)
}
\ No newline at end of file
diff --git a/R/prediction_mnp.R b/R/prediction_mnp.R
index 32ec869..3be9677 100644
--- a/R/prediction_mnp.R
+++ b/R/prediction_mnp.R
@@ -1,80 +1,80 @@
-#' @rdname prediction
-#' @export
-prediction.mnp <-
-function(model,
- data = find_data(model, parent.frame()),
- at = NULL,
- type = NULL,
- calculate_se = FALSE,
- category,
- ...) {
-
- if (!is.null(type)) {
- warning(sprintf("'type' is ignored for models of class '%s'", class(model)))
- }
-
- # extract predicted values
- data <- data
- if (missing(data) || is.null(data)) {
- probs <- make_data_frame(predict(model, type = "prob", ...)[["p"]])
- names(probs) <- paste0("Pr(", names(probs), ")")
- tmp <- predict(model, type = "choice", ...)[["y"]]
- d <- dim(tmp)
- if (length(d) == 3) {
- stop("'prediction.mnp' only works when 'n.draws = 1'")
- }
- probs[["fitted.class"]] <- lapply(seq_len(d[1L]), function(i) tmp[i,])
- pred <- probs
- rm(probs, tmp)
- } else {
- # setup data
- if (is.null(at)) {
- out <- data
- } else {
- out <- build_datalist(data, at = at, as.data.frame = TRUE)
- at_specification <- attr(out, "at_specification")
- }
- # calculate predictions
- tmp_probs <- make_data_frame(predict(model, newdata = out, type = "prob", ...)[["p"]])
- names(tmp_probs) <- paste0("Pr(", names(tmp_probs), ")")
- tmp <- predict(model, newdata = out, type = "choice", ...)[["y"]]
- d <- dim(tmp)
- if (length(d) == 3) {
- stop("'prediction.mnp' only works when 'n.draws = 1'")
- }
- tmp_probs[["fitted.class"]] <- lapply(seq_len(d[1L]), function(i) tmp[i,])
- # cbind back together
- pred <- make_data_frame(out, tmp_probs)
- rm(tmp, tmp_probs)
- }
-
- # handle category argument
- if (missing(category)) {
- w <- grep("^Pr\\(", names(pred))[1L]
- category <- names(pred)[w]
- pred[["fitted"]] <- pred[[w]]
- } else {
- w <- which(names(pred) == paste0("Pr(", category, ")"))
- if (!length(w)) {
- stop(sprintf("category %s not found", category))
- }
- pred[["fitted"]] <- pred[[ w[1L] ]]
- }
- pred[["se.fitted"]] <- NA_real_
-
- # variance(s) of average predictions
- vc <- NA_real_
-
- # output
- structure(pred,
- class = c("prediction", "data.frame"),
- at = if (is.null(at)) at else at_specification,
- type = NA_character_,
- call = if ("call" %in% names(model)) model[["call"]] else NULL,
- model_class = class(model),
- row.names = seq_len(nrow(pred)),
- vcov = vc,
- jacobian = NULL,
- category = category,
- weighted = FALSE)
-}
+#' @rdname prediction
+#' @export
+prediction.mnp <-
+function(model,
+ data = find_data(model, parent.frame()),
+ at = NULL,
+ type = NULL,
+ calculate_se = FALSE,
+ category,
+ ...) {
+
+ if (!is.null(type)) {
+ warning(sprintf("'type' is ignored for models of class '%s'", class(model)))
+ }
+
+ # extract predicted values
+ data <- data
+ if (missing(data) || is.null(data)) {
+ probs <- make_data_frame(predict(model, type = "prob", ...)[["p"]])
+ names(probs) <- paste0("Pr(", names(probs), ")")
+ tmp <- predict(model, type = "choice", ...)[["y"]]
+ d <- dim(tmp)
+ if (length(d) == 3) {
+ stop("'prediction.mnp' only works when 'n.draws = 1'")
+ }
+ probs[["fitted.class"]] <- lapply(seq_len(d[1L]), function(i) tmp[i,])
+ pred <- probs
+ rm(probs, tmp)
+ } else {
+ # setup data
+ if (is.null(at)) {
+ out <- data
+ } else {
+ out <- build_datalist(data, at = at, as.data.frame = TRUE)
+ at_specification <- attr(out, "at_specification")
+ }
+ # calculate predictions
+ tmp_probs <- make_data_frame(predict(model, newdata = out, type = "prob", ...)[["p"]])
+ names(tmp_probs) <- paste0("Pr(", names(tmp_probs), ")")
+ tmp <- predict(model, newdata = out, type = "choice", ...)[["y"]]
+ d <- dim(tmp)
+ if (length(d) == 3) {
+ stop("'prediction.mnp' only works when 'n.draws = 1'")
+ }
+ tmp_probs[["fitted.class"]] <- lapply(seq_len(d[1L]), function(i) tmp[i,])
+ # cbind back together
+ pred <- make_data_frame(out, tmp_probs)
+ rm(tmp, tmp_probs)
+ }
+
+ # handle category argument
+ if (missing(category)) {
+ w <- grep("^Pr\\(", names(pred))[1L]
+ category <- names(pred)[w]
+ pred[["fitted"]] <- pred[[w]]
+ } else {
+ w <- which(names(pred) == paste0("Pr(", category, ")"))
+ if (!length(w)) {
+ stop(sprintf("category %s not found", category))
+ }
+ pred[["fitted"]] <- pred[[ w[1L] ]]
+ }
+ pred[["se.fitted"]] <- NA_real_
+
+ # variance(s) of average predictions
+ vc <- NA_real_
+
+ # output
+ structure(pred,
+ class = c("prediction", "data.frame"),
+ at = if (is.null(at)) at else at_specification,
+ type = NA_character_,
+ call = if ("call" %in% names(model)) model[["call"]] else NULL,
+ model_class = class(model),
+ row.names = seq_len(nrow(pred)),
+ vcov = vc,
+ jacobian = NULL,
+ category = category,
+ weighted = FALSE)
+}
diff --git a/R/prediction_multinom.R b/R/prediction_multinom.R
index 8df28c7..ef7be45 100644
--- a/R/prediction_multinom.R
+++ b/R/prediction_multinom.R
@@ -1,69 +1,69 @@
-#' @rdname prediction
-#' @export
-prediction.multinom <-
-function(model,
- data = find_data(model, parent.frame()),
- at = NULL,
- type = NULL,
- calculate_se = FALSE,
- category,
- ...) {
-
- if (!is.null(type)) {
- warning(sprintf("'type' is ignored for models of class '%s'", class(model)))
- }
-
- # extract predicted values
- data <- data
- if (missing(data) || is.null(data)) {
- pred <- make_data_frame(fitted.class = predict(model, type = "class", ...))
- probs <- make_data_frame(predict(model, type = "probs", ...))
- names(probs) <- paste0("Pr(", names(probs), ")")
- pred <- make_data_frame(pred, probs)
- } else {
- # setup data
- if (is.null(at)) {
- out <- data
- } else {
- out <- build_datalist(data, at = at, as.data.frame = TRUE)
- at_specification <- attr(out, "at_specification")
- }
- # calculate predictions
- tmp <- predict(model, newdata = out, type = "class", ...)
- tmp_probs <- make_data_frame(predict(model, newdata = out, type = "probs", ...))
- names(tmp_probs) <- paste0("Pr(", names(tmp_probs), ")")
- # cbind back together
- pred <- make_data_frame(out, fitted.class = tmp, tmp_probs)
- rm(tmp, tmp_probs)
- }
-
- # handle category argument
- if (missing(category)) {
- w <- grep("^Pr\\(", names(pred))[1L]
- category <- names(pred)[w]
- pred[["fitted"]] <- pred[[w]]
- } else {
- w <- which(names(pred) == paste0("Pr(", category, ")"))
- if (!length(w)) {
- stop(sprintf("category %s not found", category))
- }
- pred[["fitted"]] <- pred[[ w[1L] ]]
- }
- pred[["se.fitted"]] <- NA_real_
-
- # variance(s) of average predictions
- vc <- NA_real_
-
- # output
- structure(pred,
- class = c("prediction", "data.frame"),
- at = if (is.null(at)) at else at_specification,
- type = NA_character_,
- call = if ("call" %in% names(model)) model[["call"]] else NULL,
- model_class = class(model),
- row.names = seq_len(nrow(pred)),
- vcov = vc,
- jacobian = NULL,
- category = category,
- weighted = FALSE)
-}
+#' @rdname prediction
+#' @export
+prediction.multinom <-
+function(model,
+ data = find_data(model, parent.frame()),
+ at = NULL,
+ type = NULL,
+ calculate_se = FALSE,
+ category,
+ ...) {
+
+ if (!is.null(type)) {
+ warning(sprintf("'type' is ignored for models of class '%s'", class(model)))
+ }
+
+ # extract predicted values
+ data <- data
+ if (missing(data) || is.null(data)) {
+ pred <- make_data_frame(fitted.class = predict(model, type = "class", ...))
+ probs <- make_data_frame(predict(model, type = "probs", ...))
+ names(probs) <- paste0("Pr(", names(probs), ")")
+ pred <- make_data_frame(pred, probs)
+ } else {
+ # setup data
+ if (is.null(at)) {
+ out <- data
+ } else {
+ out <- build_datalist(data, at = at, as.data.frame = TRUE)
+ at_specification <- attr(out, "at_specification")
+ }
+ # calculate predictions
+ tmp <- predict(model, newdata = out, type = "class", ...)
+ tmp_probs <- make_data_frame(predict(model, newdata = out, type = "probs", ...))
+ names(tmp_probs) <- paste0("Pr(", names(tmp_probs), ")")
+ # cbind back together
+ pred <- make_data_frame(out, fitted.class = tmp, tmp_probs)
+ rm(tmp, tmp_probs)
+ }
+
+ # handle category argument
+ if (missing(category)) {
+ w <- grep("^Pr\\(", names(pred))[1L]
+ category <- names(pred)[w]
+ pred[["fitted"]] <- pred[[w]]
+ } else {
+ w <- which(names(pred) == paste0("Pr(", category, ")"))
+ if (!length(w)) {
+ stop(sprintf("category %s not found", category))
+ }
+ pred[["fitted"]] <- pred[[ w[1L] ]]
+ }
+ pred[["se.fitted"]] <- NA_real_
+
+ # variance(s) of average predictions
+ vc <- NA_real_
+
+ # output
+ structure(pred,
+ class = c("prediction", "data.frame"),
+ at = if (is.null(at)) at else at_specification,
+ type = NA_character_,
+ call = if ("call" %in% names(model)) model[["call"]] else NULL,
+ model_class = class(model),
+ row.names = seq_len(nrow(pred)),
+ vcov = vc,
+ jacobian = NULL,
+ category = category,
+ weighted = FALSE)
+}
diff --git a/R/prediction_naiveBayes.R b/R/prediction_naiveBayes.R
index 138fc68..42f5153 100644
--- a/R/prediction_naiveBayes.R
+++ b/R/prediction_naiveBayes.R
@@ -1,63 +1,63 @@
-# @rdname prediction
-# @export
-prediction.naiveBayes <-
-function(model,
- data = find_data(model, parent.frame()),
- at = NULL,
- type = NULL,
- calculate_se = FALSE,
- category,
- ...) {
-
- # extract predicted values
- data <- data
- if (missing(data) || is.null(data)) {
- warning(sprintf("'data' is ignored for models of class '%s'", class(model)))
- }
- if (!is.null(type)) {
- warning(sprintf("'type' is ignored for models of class '%s'", class(model)))
- }
-
- # setup data
- if (is.null(at)) {
- out <- data
- } else {
- out <- build_datalist(data, at = at, as.data.frame = TRUE)
- at_specification <- attr(out, "at_specification")
- }
- # calculate predictions
- pred <- predict(model, newdata = out, type = "class", ...)
- probs <- make_data_frame(predict(model, newdata = out, type = "raw", ...))
- names(probs) <- paste0("Pr(", names(probs), ")")
- # cbind back together
- pred <- make_data_frame(out, probs, fitted.class = pred, se.fitted = rep(NA_real_, nrow(out)))
-
- # handle category argument
- if (missing(category)) {
- w <- grep("^Pr\\(", names(pred))[1L]
- category <- names(pred)[w]
- pred[["fitted"]] <- pred[[w]]
- } else {
- w <- which(names(pred) == paste0("Pr(", category, ")"))
- if (!length(w)) {
- stop(sprintf("category %s not found", category))
- }
- pred[["fitted"]] <- pred[[ w[1L] ]]
- }
-
- # variance(s) of average predictions
- vc <- NA_real_
-
- # output
- structure(pred,
- class = c("prediction", "data.frame"),
- at = if (is.null(at)) at else at_specification,
- type = NA_character_,
- call = if ("call" %in% names(model)) model[["call"]] else NULL,
- model_class = class(model),
- row.names = seq_len(nrow(pred)),
- vcov = vc,
- jacobian = NULL,
- category = category,
- weighted = FALSE)
-}
+# @rdname prediction
+# @export
+prediction.naiveBayes <-
+function(model,
+ data = find_data(model, parent.frame()),
+ at = NULL,
+ type = NULL,
+ calculate_se = FALSE,
+ category,
+ ...) {
+
+ # extract predicted values
+ data <- data
+ if (missing(data) || is.null(data)) {
+ warning(sprintf("'data' is ignored for models of class '%s'", class(model)))
+ }
+ if (!is.null(type)) {
+ warning(sprintf("'type' is ignored for models of class '%s'", class(model)))
+ }
+
+ # setup data
+ if (is.null(at)) {
+ out <- data
+ } else {
+ out <- build_datalist(data, at = at, as.data.frame = TRUE)
+ at_specification <- attr(out, "at_specification")
+ }
+ # calculate predictions
+ pred <- predict(model, newdata = out, type = "class", ...)
+ probs <- make_data_frame(predict(model, newdata = out, type = "raw", ...))
+ names(probs) <- paste0("Pr(", names(probs), ")")
+ # cbind back together
+ pred <- make_data_frame(out, probs, fitted.class = pred, se.fitted = rep(NA_real_, nrow(out)))
+
+ # handle category argument
+ if (missing(category)) {
+ w <- grep("^Pr\\(", names(pred))[1L]
+ category <- names(pred)[w]
+ pred[["fitted"]] <- pred[[w]]
+ } else {
+ w <- which(names(pred) == paste0("Pr(", category, ")"))
+ if (!length(w)) {
+ stop(sprintf("category %s not found", category))
+ }
+ pred[["fitted"]] <- pred[[ w[1L] ]]
+ }
+
+ # variance(s) of average predictions
+ vc <- NA_real_
+
+ # output
+ structure(pred,
+ class = c("prediction", "data.frame"),
+ at = if (is.null(at)) at else at_specification,
+ type = NA_character_,
+ call = if ("call" %in% names(model)) model[["call"]] else NULL,
+ model_class = class(model),
+ row.names = seq_len(nrow(pred)),
+ vcov = vc,
+ jacobian = NULL,
+ category = category,
+ weighted = FALSE)
+}
diff --git a/R/prediction_nls.R b/R/prediction_nls.R
index 7544689..3e61fc7 100644
--- a/R/prediction_nls.R
+++ b/R/prediction_nls.R
@@ -1,41 +1,41 @@
-#' @rdname prediction
-#' @export
-prediction.nls <- function(model, data = find_data(model, parent.frame()), at = NULL, calculate_se = FALSE, ...) {
-
- # extract predicted values
- data <- data
- if (missing(data) || is.null(data)) {
- pred <- make_data_frame(fitted = predict(model, ...),
- se.fitted = NA_real_)
- } else {
- # setup data
- if (is.null(at)) {
- out <- data
- } else {
- out <- build_datalist(data, at = at, as.data.frame = TRUE)
- at_specification <- attr(out, "at_specification")
- }
- # calculate predictions
- tmp <- predict(model,
- newdata = out,
- ...)
- # cbind back together
- pred <- make_data_frame(out, fitted = tmp, se.fitted = rep(NA_real_, length(tmp)))
- }
-
- # variance(s) of average predictions
- vc <- NA_real_
-
- # output
- structure(pred,
- class = c("prediction", "data.frame"),
- at = if (is.null(at)) at else at_specification,
- type = NA_character_,
- call = if ("call" %in% names(model)) model[["call"]] else NULL,
- model_class = class(model),
- row.names = seq_len(nrow(pred)),
- vcov = vc,
- jacobian = NULL,
- weighted = FALSE)
-}
-
+#' @rdname prediction
+#' @export
+prediction.nls <- function(model, data = find_data(model, parent.frame()), at = NULL, calculate_se = FALSE, ...) {
+
+ # extract predicted values
+ data <- data
+ if (missing(data) || is.null(data)) {
+ pred <- make_data_frame(fitted = predict(model, ...),
+ se.fitted = NA_real_)
+ } else {
+ # setup data
+ if (is.null(at)) {
+ out <- data
+ } else {
+ out <- build_datalist(data, at = at, as.data.frame = TRUE)
+ at_specification <- attr(out, "at_specification")
+ }
+ # calculate predictions
+ tmp <- predict(model,
+ newdata = out,
+ ...)
+ # cbind back together
+ pred <- make_data_frame(out, fitted = tmp, se.fitted = rep(NA_real_, length(tmp)))
+ }
+
+ # variance(s) of average predictions
+ vc <- NA_real_
+
+ # output
+ structure(pred,
+ class = c("prediction", "data.frame"),
+ at = if (is.null(at)) at else at_specification,
+ type = NA_character_,
+ call = if ("call" %in% names(model)) model[["call"]] else NULL,
+ model_class = class(model),
+ row.names = seq_len(nrow(pred)),
+ vcov = vc,
+ jacobian = NULL,
+ weighted = FALSE)
+}
+
diff --git a/R/prediction_nnet.R b/R/prediction_nnet.R
index 5ef4d57..38f18a6 100644
--- a/R/prediction_nnet.R
+++ b/R/prediction_nnet.R
@@ -1,68 +1,68 @@
-#' @rdname prediction
-#' @export
-prediction.nnet <-
-function(model,
- data = find_data(model, parent.frame()),
- at = NULL,
- type = NULL,
- calculate_se = FALSE,
- category,
- ...) {
-
- if (!is.null(type)) {
- warning(sprintf("'type' is ignored for models of class '%s'", class(model)))
- }
-
- # extract predicted values
- data <- data
- if (missing(data) || is.null(data)) {
- pred <- make_data_frame(fitted.class = predict(model, type = "class", ...))
- probs <- make_data_frame(predict(model, type = "raw", ...))
- names(probs) <- paste0("Pr(", names(probs), ")")
- pred <- make_data_frame(pred, probs)
- } else {
- # setup data
- if (is.null(at)) {
- out <- data
- } else {
- out <- build_datalist(data, at = at, as.data.frame = TRUE)
- at_specification <- attr(out, "at_specification")
- }
- # calculate predictions
- tmp <- predict(model, newdata = out, type = "class", ...)
- tmp_probs <- make_data_frame(predict(model, newdata = out, type = "raw", ...))
- names(tmp_probs) <- paste0("Pr(", names(tmp_probs), ")")
- # cbind back together
- pred <- make_data_frame(out, fitted.class = tmp, se.fitted = rep(NA_real_, nrow(out)), tmp_probs)
- rm(tmp, tmp_probs)
- }
-
- # handle category argument
- if (missing(category)) {
- w <- grep("^Pr\\(", names(pred))[1L]
- category <- names(pred)[w]
- pred[["fitted"]] <- pred[[w]]
- } else {
- w <- which(names(pred) == paste0("Pr(", category, ")"))
- if (!length(w)) {
- stop(sprintf("category %s not found", category))
- }
- pred[["fitted"]] <- pred[[ w[1L] ]]
- }
-
- # variance(s) of average predictions
- vc <- NA_real_
-
- # output
- structure(pred,
- class = c("prediction", "data.frame"),
- at = if (is.null(at)) at else at_specification,
- type = NA_character_,
- call = if ("call" %in% names(model)) model[["call"]] else NULL,
- model_class = class(model),
- row.names = seq_len(nrow(pred)),
- vcov = vc,
- jacobian = NULL,
- category = category,
- weighted = FALSE)
-}
+#' @rdname prediction
+#' @export
+prediction.nnet <-
+function(model,
+ data = find_data(model, parent.frame()),
+ at = NULL,
+ type = NULL,
+ calculate_se = FALSE,
+ category,
+ ...) {
+
+ if (!is.null(type)) {
+ warning(sprintf("'type' is ignored for models of class '%s'", class(model)))
+ }
+
+ # extract predicted values
+ data <- data
+ if (missing(data) || is.null(data)) {
+ pred <- make_data_frame(fitted.class = predict(model, type = "class", ...))
+ probs <- make_data_frame(predict(model, type = "raw", ...))
+ names(probs) <- paste0("Pr(", names(probs), ")")
+ pred <- make_data_frame(pred, probs)
+ } else {
+ # setup data
+ if (is.null(at)) {
+ out <- data
+ } else {
+ out <- build_datalist(data, at = at, as.data.frame = TRUE)
+ at_specification <- attr(out, "at_specification")
+ }
+ # calculate predictions
+ tmp <- predict(model, newdata = out, type = "class", ...)
+ tmp_probs <- make_data_frame(predict(model, newdata = out, type = "raw", ...))
+ names(tmp_probs) <- paste0("Pr(", names(tmp_probs), ")")
+ # cbind back together
+ pred <- make_data_frame(out, fitted.class = tmp, se.fitted = rep(NA_real_, nrow(out)), tmp_probs)
+ rm(tmp, tmp_probs)
+ }
+
+ # handle category argument
+ if (missing(category)) {
+ w <- grep("^Pr\\(", names(pred))[1L]
+ category <- names(pred)[w]
+ pred[["fitted"]] <- pred[[w]]
+ } else {
+ w <- which(names(pred) == paste0("Pr(", category, ")"))
+ if (!length(w)) {
+ stop(sprintf("category %s not found", category))
+ }
+ pred[["fitted"]] <- pred[[ w[1L] ]]
+ }
+
+ # variance(s) of average predictions
+ vc <- NA_real_
+
+ # output
+ structure(pred,
+ class = c("prediction", "data.frame"),
+ at = if (is.null(at)) at else at_specification,
+ type = NA_character_,
+ call = if ("call" %in% names(model)) model[["call"]] else NULL,
+ model_class = class(model),
+ row.names = seq_len(nrow(pred)),
+ vcov = vc,
+ jacobian = NULL,
+ category = category,
+ weighted = FALSE)
+}
diff --git a/R/prediction_plm.R b/R/prediction_plm.R
index 93a8c2d..83987bb 100644
--- a/R/prediction_plm.R
+++ b/R/prediction_plm.R
@@ -1,42 +1,42 @@
-#' @rdname prediction
-#' @export
-prediction.plm <-
-function(model,
- data = find_data(model, parent.frame()),
- at = NULL,
- calculate_se = FALSE,
- ...) {
-
- # extract predicted values
- data <- data
- if (missing(data) || is.null(data)) {
- pred <- make_data_frame(fitted = predict(model, ...))
- } else {
- # setup data
- if (is.null(at)) {
- out <- data
- } else {
- out <- build_datalist(data, at = at, as.data.frame = TRUE)
- at_specification <- attr(out, "at_specification")
- }
- # calculate predictions
- tmp <- predict(model, newdata = out, ...)
- # cbind back together
- pred <- make_data_frame(out, fitted = tmp, se.fitted = rep(NA_real_, nrow(out)))
- }
-
- # variance(s) of average predictions
- vc <- NA_real_
-
- # output
- structure(pred,
- class = c("prediction", "data.frame"),
- at = if (is.null(at)) at else at_specification,
- type = NA_character_,
- call = if ("call" %in% names(model)) model[["call"]] else NULL,
- model_class = class(model),
- row.names = seq_len(nrow(pred)),
- vcov = vc,
- jacobian = NULL,
- weighted = FALSE)
-}
+#' @rdname prediction
+#' @export
+prediction.plm <-
+function(model,
+ data = find_data(model, parent.frame()),
+ at = NULL,
+ calculate_se = FALSE,
+ ...) {
+
+ # extract predicted values
+ data <- data
+ if (missing(data) || is.null(data)) {
+ pred <- make_data_frame(fitted = predict(model, ...))
+ } else {
+ # setup data
+ if (is.null(at)) {
+ out <- data
+ } else {
+ out <- build_datalist(data, at = at, as.data.frame = TRUE)
+ at_specification <- attr(out, "at_specification")
+ }
+ # calculate predictions
+ tmp <- predict(model, newdata = out, ...)
+ # cbind back together
+ pred <- make_data_frame(out, fitted = tmp, se.fitted = rep(NA_real_, nrow(out)))
+ }
+
+ # variance(s) of average predictions
+ vc <- NA_real_
+
+ # output
+ structure(pred,
+ class = c("prediction", "data.frame"),
+ at = if (is.null(at)) at else at_specification,
+ type = NA_character_,
+ call = if ("call" %in% names(model)) model[["call"]] else NULL,
+ model_class = class(model),
+ row.names = seq_len(nrow(pred)),
+ vcov = vc,
+ jacobian = NULL,
+ weighted = FALSE)
+}
diff --git a/R/prediction_polr.R b/R/prediction_polr.R
index 3fa8325..619241c 100644
--- a/R/prediction_polr.R
+++ b/R/prediction_polr.R
@@ -1,3 +1,3 @@
-#' @rdname prediction
-#' @export
-prediction.polr <- prediction.multinom
+#' @rdname prediction
+#' @export
+prediction.polr <- prediction.multinom
diff --git a/R/prediction_polyreg.R b/R/prediction_polyreg.R
index d17d50b..152cbd4 100644
--- a/R/prediction_polyreg.R
+++ b/R/prediction_polyreg.R
@@ -1,45 +1,45 @@
-#' @rdname prediction
-#' @export
-prediction.polyreg <-
-function(model,
- data = NULL,
- at = NULL,
- type = "fitted",
- calculate_se = FALSE,
- ...) {
-
- type <- match.arg(type)
-
- # extract predicted values
- data <- data
- if (missing(data) || is.null(data)) {
- pred <- predict(model, type = type, ...)
- pred <- make_data_frame(fitted = pred[,1L], se.fitted = rep(NA_real_, length(pred)))
- } else {
- # setup data
- data <- build_datalist(data, at = at, as.data.frame = TRUE)
- at_specification <- attr(data, "at_specification")
- # calculate predictions
- if (!is.matrix(data)) {
- data <- as.matrix(data)
- }
- tmp <- predict(model, newdata = data, type = type, ...)
- # cbind back together
- pred <- make_data_frame(data, fitted = tmp[,1L], se.fitted = rep(NA_real_, nrow(data)))
- }
-
- # variance(s) of average predictions
- vc <- NA_real_
-
- # output
- structure(pred,
- class = c("prediction", "data.frame"),
- at = if (is.null(at)) at else at_specification,
- type = type,
- call = if ("call" %in% names(model)) model[["call"]] else NULL,
- model_class = class(model),
- row.names = seq_len(nrow(pred)),
- vcov = vc,
- jacobian = NULL,
- weighted = FALSE)
-}
+#' @rdname prediction
+#' @export
+prediction.polyreg <-
+function(model,
+ data = NULL,
+ at = NULL,
+ type = "fitted",
+ calculate_se = FALSE,
+ ...) {
+
+ type <- match.arg(type)
+
+ # extract predicted values
+ data <- data
+ if (missing(data) || is.null(data)) {
+ pred <- predict(model, type = type, ...)
+ pred <- make_data_frame(fitted = pred[,1L], se.fitted = rep(NA_real_, length(pred)))
+ } else {
+ # setup data
+ data <- build_datalist(data, at = at, as.data.frame = TRUE)
+ at_specification <- attr(data, "at_specification")
+ # calculate predictions
+ if (!is.matrix(data)) {
+ data <- as.matrix(data)
+ }
+ tmp <- predict(model, newdata = data, type = type, ...)
+ # cbind back together
+ pred <- make_data_frame(data, fitted = tmp[,1L], se.fitted = rep(NA_real_, nrow(data)))
+ }
+
+ # variance(s) of average predictions
+ vc <- NA_real_
+
+ # output
+ structure(pred,
+ class = c("prediction", "data.frame"),
+ at = if (is.null(at)) at else at_specification,
+ type = type,
+ call = if ("call" %in% names(model)) model[["call"]] else NULL,
+ model_class = class(model),
+ row.names = seq_len(nrow(pred)),
+ vcov = vc,
+ jacobian = NULL,
+ weighted = FALSE)
+}
diff --git a/R/prediction_ppr.R b/R/prediction_ppr.R
index 7f394cd..1a47703 100644
--- a/R/prediction_ppr.R
+++ b/R/prediction_ppr.R
@@ -1,40 +1,40 @@
-#' @rdname prediction
-#' @export
-prediction.ppr <- function(model, data = find_data(model, parent.frame()), at = NULL, calculate_se = FALSE, ...) {
-
- # extract predicted values
- data <- data
- if (missing(data) || is.null(data)) {
- pred <- make_data_frame(fitted = predict(model, ...),
- se.fitted = NA_real_)
- } else {
- # setup data
- if (is.null(at)) {
- out <- data
- } else {
- out <- build_datalist(data, at = at, as.data.frame = TRUE)
- at_specification <- attr(out, "at_specification")
- }
- # calculate predictions
- tmp <- predict(model,
- newdata = out,
- ...)
- # cbind back together
- pred <- make_data_frame(out, fitted = tmp, se.fitted = rep(NA_real_, nrow(out)))
- }
-
- # variance(s) of average predictions
- vc <- NA_real_
-
- # output
- structure(pred,
- class = c("prediction", "data.frame"),
- at = if (is.null(at)) at else at_specification,
- type = NA_character_,
- call = if ("call" %in% names(model)) model[["call"]] else NULL,
- model_class = class(model),
- row.names = seq_len(nrow(pred)),
- vcov = vc,
- jacobian = NULL,
- weighted = FALSE)
-}
+#' @rdname prediction
+#' @export
+prediction.ppr <- function(model, data = find_data(model, parent.frame()), at = NULL, calculate_se = FALSE, ...) {
+
+ # extract predicted values
+ data <- data
+ if (missing(data) || is.null(data)) {
+ pred <- make_data_frame(fitted = predict(model, ...),
+ se.fitted = NA_real_)
+ } else {
+ # setup data
+ if (is.null(at)) {
+ out <- data
+ } else {
+ out <- build_datalist(data, at = at, as.data.frame = TRUE)
+ at_specification <- attr(out, "at_specification")
+ }
+ # calculate predictions
+ tmp <- predict(model,
+ newdata = out,
+ ...)
+ # cbind back together
+ pred <- make_data_frame(out, fitted = tmp, se.fitted = rep(NA_real_, nrow(out)))
+ }
+
+ # variance(s) of average predictions
+ vc <- NA_real_
+
+ # output
+ structure(pred,
+ class = c("prediction", "data.frame"),
+ at = if (is.null(at)) at else at_specification,
+ type = NA_character_,
+ call = if ("call" %in% names(model)) model[["call"]] else NULL,
+ model_class = class(model),
+ row.names = seq_len(nrow(pred)),
+ vcov = vc,
+ jacobian = NULL,
+ weighted = FALSE)
+}
diff --git a/R/prediction_princomp.R b/R/prediction_princomp.R
index 6576658..a3127cb 100644
--- a/R/prediction_princomp.R
+++ b/R/prediction_princomp.R
@@ -1,39 +1,39 @@
-#' @rdname prediction
-#' @export
-prediction.princomp <- function(model, data = find_data(model, parent.frame()), at = NULL, calculate_se = FALSE, ...) {
-
- # extract predicted values
- data <- data
- if (missing(data) || is.null(data)) {
- pred <- make_data_frame(predict(model, ...))
- } else {
- # setup data
- if (is.null(at)) {
- out <- data
- } else {
- out <- build_datalist(data, at = at, as.data.frame = TRUE)
- at_specification <- attr(out, "at_specification")
- }
- # calculate predictions
- tmp <- predict(model,
- newdata = out,
- ...)
- # cbind back together
- pred <- make_data_frame(out, tmp, fitted = rep(NA_real_, nrow(out)), se.fitted = rep(NA_real_, nrow(out)))
- }
-
- # variance(s) of average predictions
- vc <- NA_real_
-
- # output
- structure(pred,
- class = c("prediction", "data.frame"),
- at = if (is.null(at)) at else at_specification,
- type = NA_character_,
- call = if ("call" %in% names(model)) model[["call"]] else NULL,
- model_class = class(model),
- row.names = seq_len(nrow(pred)),
- vcov = vc,
- jacobian = NULL,
- weighted = FALSE)
-}
+#' @rdname prediction
+#' @export
+prediction.princomp <- function(model, data = find_data(model, parent.frame()), at = NULL, calculate_se = FALSE, ...) {
+
+ # extract predicted values
+ data <- data
+ if (missing(data) || is.null(data)) {
+ pred <- make_data_frame(predict(model, ...))
+ } else {
+ # setup data
+ if (is.null(at)) {
+ out <- data
+ } else {
+ out <- build_datalist(data, at = at, as.data.frame = TRUE)
+ at_specification <- attr(out, "at_specification")
+ }
+ # calculate predictions
+ tmp <- predict(model,
+ newdata = out,
+ ...)
+ # cbind back together
+ pred <- make_data_frame(out, tmp, fitted = rep(NA_real_, nrow(out)), se.fitted = rep(NA_real_, nrow(out)))
+ }
+
+ # variance(s) of average predictions
+ vc <- NA_real_
+
+ # output
+ structure(pred,
+ class = c("prediction", "data.frame"),
+ at = if (is.null(at)) at else at_specification,
+ type = NA_character_,
+ call = if ("call" %in% names(model)) model[["call"]] else NULL,
+ model_class = class(model),
+ row.names = seq_len(nrow(pred)),
+ vcov = vc,
+ jacobian = NULL,
+ weighted = FALSE)
+}
diff --git a/R/prediction_qda.R b/R/prediction_qda.R
index ec945ab..db99fd9 100644
--- a/R/prediction_qda.R
+++ b/R/prediction_qda.R
@@ -1,61 +1,61 @@
-# @rdname prediction
-# @export
-prediction.qda <-
-function(model,
- data = find_data(model, parent.frame()),
- at = NULL,
- calculate_se = FALSE,
- category,
- ...) {
-
- # extract predicted values
- data <- data
- if (missing(data) || is.null(data)) {
- pred <- predict(model, ...)
- colnames(pred[["posterior"]]) <- paste0("Pr(", colnames(pred[["posterior"]]), ")")
- pred <- make_data_frame(fitted.class = pred[["class"]],
- pred[["posterior"]])
- } else {
- # setup data
- if (is.null(at)) {
- out <- data
- } else {
- out <- build_datalist(data, at = at, as.data.frame = TRUE)
- at_specification <- attr(out, "at_specification")
- }
- # calculate predictions
- tmp <- predict(model, newdata = out, ...)
- colnames(tmp[["posterior"]]) <- paste0("Pr(", colnames(tmp[["posterior"]]), ")")
- # cbind back together
- pred <- make_data_frame(out, fitted.class = tmp[["class"]], tmp[["posterior"]], se.fitted = rep(NA_real_, nrow (out)))
- }
-
- # handle category argument
- if (missing(category)) {
- w <- grep("^Pr\\(", names(pred))[1L]
- category <- names(pred)[w]
- pred[["fitted"]] <- pred[[w]]
- } else {
- w <- which(names(pred) == paste0("Pr(", category, ")"))
- if (!length(w)) {
- stop(sprintf("category %s not found", category))
- }
- pred[["fitted"]] <- pred[[ w[1L] ]]
- }
-
- # variance(s) of average predictions
- vc <- NA_real_
-
- # output
- structure(pred,
- class = c("prediction", "data.frame"),
- at = if (is.null(at)) at else at_specification,
- type = NA_character_,
- call = if ("call" %in% names(model)) model[["call"]] else NULL,
- model_class = class(model),
- row.names = seq_len(nrow(pred)),
- vcov = vc,
- jacobian = NULL,
- category = category,
- weighted = FALSE)
-}
+# @rdname prediction
+# @export
+prediction.qda <-
+function(model,
+ data = find_data(model, parent.frame()),
+ at = NULL,
+ calculate_se = FALSE,
+ category,
+ ...) {
+
+ # extract predicted values
+ data <- data
+ if (missing(data) || is.null(data)) {
+ pred <- predict(model, ...)
+ colnames(pred[["posterior"]]) <- paste0("Pr(", colnames(pred[["posterior"]]), ")")
+ pred <- make_data_frame(fitted.class = pred[["class"]],
+ pred[["posterior"]])
+ } else {
+ # setup data
+ if (is.null(at)) {
+ out <- data
+ } else {
+ out <- build_datalist(data, at = at, as.data.frame = TRUE)
+ at_specification <- attr(out, "at_specification")
+ }
+ # calculate predictions
+ tmp <- predict(model, newdata = out, ...)
+ colnames(tmp[["posterior"]]) <- paste0("Pr(", colnames(tmp[["posterior"]]), ")")
+ # cbind back together
+ pred <- make_data_frame(out, fitted.class = tmp[["class"]], tmp[["posterior"]], se.fitted = rep(NA_real_, nrow (out)))
+ }
+
+ # handle category argument
+ if (missing(category)) {
+ w <- grep("^Pr\\(", names(pred))[1L]
+ category <- names(pred)[w]
+ pred[["fitted"]] <- pred[[w]]
+ } else {
+ w <- which(names(pred) == paste0("Pr(", category, ")"))
+ if (!length(w)) {
+ stop(sprintf("category %s not found", category))
+ }
+ pred[["fitted"]] <- pred[[ w[1L] ]]
+ }
+
+ # variance(s) of average predictions
+ vc <- NA_real_
+
+ # output
+ structure(pred,
+ class = c("prediction", "data.frame"),
+ at = if (is.null(at)) at else at_specification,
+ type = NA_character_,
+ call = if ("call" %in% names(model)) model[["call"]] else NULL,
+ model_class = class(model),
+ row.names = seq_len(nrow(pred)),
+ vcov = vc,
+ jacobian = NULL,
+ category = category,
+ weighted = FALSE)
+}
diff --git a/R/prediction_rlm.R b/R/prediction_rlm.R
index 1102c4f..e42177d 100644
--- a/R/prediction_rlm.R
+++ b/R/prediction_rlm.R
@@ -1,3 +1,3 @@
-#' @rdname prediction
-#' @export
-prediction.rlm <- prediction.default
+#' @rdname prediction
+#' @export
+prediction.rlm <- prediction.default
diff --git a/R/prediction_rpart.R b/R/prediction_rpart.R
index 922159d..5423e2e 100644
--- a/R/prediction_rpart.R
+++ b/R/prediction_rpart.R
@@ -1,69 +1,69 @@
-#' @rdname prediction
-#' @export
-prediction.rpart <-
-function(model,
- data = find_data(model, parent.frame()),
- at = NULL,
- type = NULL,
- calculate_se = FALSE,
- category,
- ...) {
-
- if (!is.null(type)) {
- warning(sprintf("'type' is ignored for models of class '%s'", class(model)))
- }
-
- # extract predicted values
- data <- data
- if (missing(data) || is.null(data)) {
- pred <- make_data_frame(fitted.class = predict(model, type = "class", ...))
- probs <- make_data_frame(predict(model, type = "prob", ...))
- names(probs) <- paste0("Pr(", names(probs), ")")
- pred <- make_data_frame(pred, probs)
- } else {
- # setup data
- if (is.null(at)) {
- out <- data
- } else {
- out <- build_datalist(data, at = at, as.data.frame = TRUE)
- at_specification <- attr(out, "at_specification")
- }
- # calculate predictions
- tmp <- predict(model, newdata = out, type = "class", ...)
- tmp_probs <- make_data_frame(predict(model, newdata = out, type = "prob", ...))
- names(tmp_probs) <- paste0("Pr(", names(tmp_probs), ")")
- # cbind back together
- pred <- make_data_frame(out, fitted.class = tmp, tmp_probs)
- rm(tmp, tmp_probs)
- }
-
- # handle category argument
- if (missing(category)) {
- w <- grep("^Pr\\(", names(pred))[1L]
- category <- names(pred)[w]
- pred[["fitted"]] <- pred[[w]]
- } else {
- w <- which(names(pred) == paste0("Pr(", category, ")"))
- if (!length(w)) {
- stop(sprintf("category %s not found", category))
- }
- pred[["fitted"]] <- pred[[ w[1L] ]]
- }
- pred[["se.fitted"]] <- NA_real_
-
- # variance(s) of average predictions
- vc <- NA_real_
-
- # output
- structure(pred,
- class = c("prediction", "data.frame"),
- at = if (is.null(at)) at else at_specification,
- type = NA_character_,
- call = if ("call" %in% names(model)) model[["call"]] else NULL,
- model_class = class(model),
- row.names = seq_len(nrow(pred)),
- vcov = vc,
- jacobian = NULL,
- category = category,
- weighted = FALSE)
-}
+#' @rdname prediction
+#' @export
+prediction.rpart <-
+function(model,
+ data = find_data(model, parent.frame()),
+ at = NULL,
+ type = NULL,
+ calculate_se = FALSE,
+ category,
+ ...) {
+
+ if (!is.null(type)) {
+ warning(sprintf("'type' is ignored for models of class '%s'", class(model)))
+ }
+
+ # extract predicted values
+ data <- data
+ if (missing(data) || is.null(data)) {
+ pred <- make_data_frame(fitted.class = predict(model, type = "class", ...))
+ probs <- make_data_frame(predict(model, type = "prob", ...))
+ names(probs) <- paste0("Pr(", names(probs), ")")
+ pred <- make_data_frame(pred, probs)
+ } else {
+ # setup data
+ if (is.null(at)) {
+ out <- data
+ } else {
+ out <- build_datalist(data, at = at, as.data.frame = TRUE)
+ at_specification <- attr(out, "at_specification")
+ }
+ # calculate predictions
+ tmp <- predict(model, newdata = out, type = "class", ...)
+ tmp_probs <- make_data_frame(predict(model, newdata = out, type = "prob", ...))
+ names(tmp_probs) <- paste0("Pr(", names(tmp_probs), ")")
+ # cbind back together
+ pred <- make_data_frame(out, fitted.class = tmp, tmp_probs)
+ rm(tmp, tmp_probs)
+ }
+
+ # handle category argument
+ if (missing(category)) {
+ w <- grep("^Pr\\(", names(pred))[1L]
+ category <- names(pred)[w]
+ pred[["fitted"]] <- pred[[w]]
+ } else {
+ w <- which(names(pred) == paste0("Pr(", category, ")"))
+ if (!length(w)) {
+ stop(sprintf("category %s not found", category))
+ }
+ pred[["fitted"]] <- pred[[ w[1L] ]]
+ }
+ pred[["se.fitted"]] <- NA_real_
+
+ # variance(s) of average predictions
+ vc <- NA_real_
+
+ # output
+ structure(pred,
+ class = c("prediction", "data.frame"),
+ at = if (is.null(at)) at else at_specification,
+ type = NA_character_,
+ call = if ("call" %in% names(model)) model[["call"]] else NULL,
+ model_class = class(model),
+ row.names = seq_len(nrow(pred)),
+ vcov = vc,
+ jacobian = NULL,
+ category = category,
+ weighted = FALSE)
+}
diff --git a/R/prediction_rq.R b/R/prediction_rq.R
index 59b065e..f83adf0 100644
--- a/R/prediction_rq.R
+++ b/R/prediction_rq.R
@@ -1,45 +1,45 @@
-#' @rdname prediction
-#' @export
-prediction.rq <-
-function(model,
- data = find_data(model, parent.frame()),
- at = NULL,
- calculate_se = TRUE,
- ...) {
-
- # extract predicted value at input value
- data <- data
- if (missing(data) || is.null(data)) {
- pred <- data.frame(fitted = predict(model, ...),
- se.fitted = NA_real_)
- } else {
- # setup data
- if (is.null(at)) {
- out <- data
- } else {
- out <- build_datalist(data, at = at, as.data.frame = TRUE)
- at_specification <- attr(out, "at_specification")
- }
- # calculate predictions
- tmp <- predict(model,
- newdata = out,
- ...)
- # cbind back together
- pred <- make_data_frame(out, fitted = tmp, se.fitted = rep(NA_real_, nrow(out)))
- }
-
- # variance(s) of average predictions
- vc <- NA_real_
-
- # output
- structure(pred,
- class = c("prediction", "data.frame"),
- at = if (is.null(at)) at else at_specification,
- type = NA_character_,
- call = if ("call" %in% names(model)) model[["call"]] else NULL,
- model_class = class(model),
- row.names = seq_len(nrow(pred)),
- vcov = vc,
- jacobian = NULL,
- weighted = FALSE)
-}
+#' @rdname prediction
+#' @export
+prediction.rq <-
+function(model,
+ data = find_data(model, parent.frame()),
+ at = NULL,
+ calculate_se = TRUE,
+ ...) {
+
+ # extract predicted value at input value
+ data <- data
+ if (missing(data) || is.null(data)) {
+ pred <- data.frame(fitted = predict(model, ...),
+ se.fitted = NA_real_)
+ } else {
+ # setup data
+ if (is.null(at)) {
+ out <- data
+ } else {
+ out <- build_datalist(data, at = at, as.data.frame = TRUE)
+ at_specification <- attr(out, "at_specification")
+ }
+ # calculate predictions
+ tmp <- predict(model,
+ newdata = out,
+ ...)
+ # cbind back together
+ pred <- make_data_frame(out, fitted = tmp, se.fitted = rep(NA_real_, nrow(out)))
+ }
+
+ # variance(s) of average predictions
+ vc <- NA_real_
+
+ # output
+ structure(pred,
+ class = c("prediction", "data.frame"),
+ at = if (is.null(at)) at else at_specification,
+ type = NA_character_,
+ call = if ("call" %in% names(model)) model[["call"]] else NULL,
+ model_class = class(model),
+ row.names = seq_len(nrow(pred)),
+ vcov = vc,
+ jacobian = NULL,
+ weighted = FALSE)
+}
diff --git a/R/prediction_selection.R b/R/prediction_selection.R
index 85a1354..8c70c9f 100644
--- a/R/prediction_selection.R
+++ b/R/prediction_selection.R
@@ -1,41 +1,41 @@
-#' @rdname prediction
-#' @export
-prediction.selection <- function(model, data = find_data(model, parent.frame()), at = NULL, type = "response", calculate_se = FALSE, ...) {
-
- # extract predicted value at input value
- data <- data
- if (missing(data) || is.null(data)) {
- pred <- make_data_frame(fitted = predict(model, type = type, ...),
- se.fitted = NA_real_)
- } else {
- # setup data
- if (is.null(at)) {
- out <- data
- } else {
- out <- build_datalist(data, at = at, as.data.frame = TRUE)
- at_specification <- attr(out, "at_specification")
- }
- # calculate predictions
- tmp <- predict(model,
- newdata = out,
- type = type,
- ...)
- # cbind back together
- pred <- make_data_frame(out, fitted = tmp, se.fitted = rep(NA_real_, length(tmp)))
- }
-
- # variance(s) of average predictions
- vc <- NA_real_
-
- # output
- structure(pred,
- class = c("prediction", "data.frame"),
- at = if (is.null(at)) at else at_specification,
- type = type,
- call = if ("call" %in% names(model)) model[["call"]] else NULL,
- model_class = class(model),
- row.names = seq_len(nrow(pred)),
- vcov = vc,
- jacobian = NULL,
- weighted = FALSE)
-}
+#' @rdname prediction
+#' @export
+prediction.selection <- function(model, data = find_data(model, parent.frame()), at = NULL, type = "response", calculate_se = FALSE, ...) {
+
+ # extract predicted value at input value
+ data <- data
+ if (missing(data) || is.null(data)) {
+ pred <- make_data_frame(fitted = predict(model, type = type, ...),
+ se.fitted = NA_real_)
+ } else {
+ # setup data
+ if (is.null(at)) {
+ out <- data
+ } else {
+ out <- build_datalist(data, at = at, as.data.frame = TRUE)
+ at_specification <- attr(out, "at_specification")
+ }
+ # calculate predictions
+ tmp <- predict(model,
+ newdata = out,
+ type = type,
+ ...)
+ # cbind back together
+ pred <- make_data_frame(out, fitted = tmp, se.fitted = rep(NA_real_, length(tmp)))
+ }
+
+ # variance(s) of average predictions
+ vc <- NA_real_
+
+ # output
+ structure(pred,
+ class = c("prediction", "data.frame"),
+ at = if (is.null(at)) at else at_specification,
+ type = type,
+ call = if ("call" %in% names(model)) model[["call"]] else NULL,
+ model_class = class(model),
+ row.names = seq_len(nrow(pred)),
+ vcov = vc,
+ jacobian = NULL,
+ weighted = FALSE)
+}
diff --git a/R/prediction_speedglm.R b/R/prediction_speedglm.R
index 9bc122c..35dca67 100644
--- a/R/prediction_speedglm.R
+++ b/R/prediction_speedglm.R
@@ -1,45 +1,45 @@
-#' @rdname prediction
-#' @export
-prediction.speedglm <-
-function(model,
- data = find_data(model, parent.frame()),
- at = NULL,
- type = c("response", "link"),
- calculate_se = FALSE,
- ...) {
-
- type <- match.arg(type)
-
- # extract predicted values
- data <- data
- if (missing(data) || is.null(data)) {
- pred <- predict(model, type = type, ...)
- pred <- make_data_frame(fitted = pred, se.fitted = rep(NA_real_, length(pred)))
- } else {
- # reduce memory profile
- model[["model"]] <- NULL
-
- # setup data
- out <- build_datalist(data, at = at, as.data.frame = TRUE)
- at_specification <- attr(out, "at_specification")
- # calculate predictions
- tmp <- predict(model, newdata = out, type = type, se.fit = FALSE, ...)
- # cbind back together
- pred <- make_data_frame(out, fitted = tmp, se.fitted = rep(NA_real_, nrow(out)))
- }
-
- # variance(s) of average predictions
- vc <- NA_real_
-
- # output
- structure(pred,
- class = c("prediction", "data.frame"),
- at = if (is.null(at)) at else at_specification,
- type = type,
- call = if ("call" %in% names(model)) model[["call"]] else NULL,
- model_class = class(model),
- row.names = seq_len(nrow(pred)),
- vcov = vc,
- jacobian = NULL,
- weighted = FALSE)
-}
+#' @rdname prediction
+#' @export
+prediction.speedglm <-
+function(model,
+ data = find_data(model, parent.frame()),
+ at = NULL,
+ type = c("response", "link"),
+ calculate_se = FALSE,
+ ...) {
+
+ type <- match.arg(type)
+
+ # extract predicted values
+ data <- data
+ if (missing(data) || is.null(data)) {
+ pred <- predict(model, type = type, ...)
+ pred <- make_data_frame(fitted = pred, se.fitted = rep(NA_real_, length(pred)))
+ } else {
+ # reduce memory profile
+ model[["model"]] <- NULL
+
+ # setup data
+ out <- build_datalist(data, at = at, as.data.frame = TRUE)
+ at_specification <- attr(out, "at_specification")
+ # calculate predictions
+ tmp <- predict(model, newdata = out, type = type, se.fit = FALSE, ...)
+ # cbind back together
+ pred <- make_data_frame(out, fitted = tmp, se.fitted = rep(NA_real_, nrow(out)))
+ }
+
+ # variance(s) of average predictions
+ vc <- NA_real_
+
+ # output
+ structure(pred,
+ class = c("prediction", "data.frame"),
+ at = if (is.null(at)) at else at_specification,
+ type = type,
+ call = if ("call" %in% names(model)) model[["call"]] else NULL,
+ model_class = class(model),
+ row.names = seq_len(nrow(pred)),
+ vcov = vc,
+ jacobian = NULL,
+ weighted = FALSE)
+}
diff --git a/R/prediction_speedlm.R b/R/prediction_speedlm.R
index 7d54e51..16654c6 100644
--- a/R/prediction_speedlm.R
+++ b/R/prediction_speedlm.R
@@ -1,39 +1,39 @@
-#' @rdname prediction
-#' @export
-prediction.speedlm <-
-function(model,
- data = find_data(model, parent.frame()),
- at = NULL,
- calculate_se = FALSE,
- ...) {
-
- # extract predicted values
- data <- data
- if (missing(data) || is.null(data)) {
- pred <- predict(model, ...)
- pred <- make_data_frame(fitted = pred, se.fitted = rep(NA_real_, length(pred)))
- } else {
- # setup data
- data <- build_datalist(data, at = at, as.data.frame = TRUE)
- at_specification <- attr(data, "at_specification")
- # calculate predictions
- tmp <- predict(model, newdata = data, ...)
- # cbind back together
- pred <- make_data_frame(data, fitted = tmp, se.fitted = rep(NA_real_, nrow(data)))
- }
-
- # variance(s) of average predictions
- vc <- NA_real_
-
- # output
- structure(pred,
- class = c("prediction", "data.frame"),
- at = if (is.null(at)) at else at_specification,
- type = "response",
- call = if ("call" %in% names(model)) model[["call"]] else NULL,
- model_class = class(model),
- row.names = seq_len(nrow(pred)),
- vcov = vc,
- jacobian = NULL,
- weighted = FALSE)
-}
+#' @rdname prediction
+#' @export
+prediction.speedlm <-
+function(model,
+ data = find_data(model, parent.frame()),
+ at = NULL,
+ calculate_se = FALSE,
+ ...) {
+
+ # extract predicted values
+ data <- data
+ if (missing(data) || is.null(data)) {
+ pred <- predict(model, ...)
+ pred <- make_data_frame(fitted = pred, se.fitted = rep(NA_real_, length(pred)))
+ } else {
+ # setup data
+ data <- build_datalist(data, at = at, as.data.frame = TRUE)
+ at_specification <- attr(data, "at_specification")
+ # calculate predictions
+ tmp <- predict(model, newdata = data, ...)
+ # cbind back together
+ pred <- make_data_frame(data, fitted = tmp, se.fitted = rep(NA_real_, nrow(data)))
+ }
+
+ # variance(s) of average predictions
+ vc <- NA_real_
+
+ # output
+ structure(pred,
+ class = c("prediction", "data.frame"),
+ at = if (is.null(at)) at else at_specification,
+ type = "response",
+ call = if ("call" %in% names(model)) model[["call"]] else NULL,
+ model_class = class(model),
+ row.names = seq_len(nrow(pred)),
+ vcov = vc,
+ jacobian = NULL,
+ weighted = FALSE)
+}
diff --git a/R/prediction_survreg.R b/R/prediction_survreg.R
index 99c806e..9695cae 100644
--- a/R/prediction_survreg.R
+++ b/R/prediction_survreg.R
@@ -1,46 +1,46 @@
-#' @rdname prediction
-#' @export
-prediction.survreg <-
-function(model,
- data = find_data(model, parent.frame()),
- at = NULL,
- type = c("response", "lp", "quantile", "uquantile"),
- calculate_se = TRUE,
- ...) {
-
- type <- match.arg(type)
-
- # extract predicted values
- data <- data
- if (missing(data) || is.null(data)) {
- pred <- predict(model, type = type, se.fit = TRUE, ...)
- pred <- make_data_frame(fitted = pred[["fit"]], se.fitted = pred[["se.fit"]])
- } else {
- # setup data
- if (is.null(at)) {
- out <- data
- } else {
- out <- build_datalist(data, at = at, as.data.frame = TRUE)
- at_specification <- attr(out, "at_specification")
- }
- # calculate predictions
- tmp <- predict(model, newdata = out, type = type, se.fit = TRUE, ...)
- # cbind back together
- pred <- make_data_frame(out, fitted = tmp[["fit"]], se.fitted = tmp[["se.fit"]])
- }
-
- # variance(s) of average predictions
- vc <- NA_real_
-
- # output
- structure(pred,
- class = c("prediction", "data.frame"),
- at = if (is.null(at)) at else at_specification,
- type = type,
- call = if ("call" %in% names(model)) model[["call"]] else NULL,
- model_class = class(model),
- row.names = seq_len(nrow(pred)),
- vcov = vc,
- jacobian = NULL,
- weighted = FALSE)
-}
+#' @rdname prediction
+#' @export
+prediction.survreg <-
+function(model,
+ data = find_data(model, parent.frame()),
+ at = NULL,
+ type = c("response", "lp", "quantile", "uquantile"),
+ calculate_se = TRUE,
+ ...) {
+
+ type <- match.arg(type)
+
+ # extract predicted values
+ data <- data
+ if (missing(data) || is.null(data)) {
+ pred <- predict(model, type = type, se.fit = TRUE, ...)
+ pred <- make_data_frame(fitted = pred[["fit"]], se.fitted = pred[["se.fit"]])
+ } else {
+ # setup data
+ if (is.null(at)) {
+ out <- data
+ } else {
+ out <- build_datalist(data, at = at, as.data.frame = TRUE)
+ at_specification <- attr(out, "at_specification")
+ }
+ # calculate predictions
+ tmp <- predict(model, newdata = out, type = type, se.fit = TRUE, ...)
+ # cbind back together
+ pred <- make_data_frame(out, fitted = tmp[["fit"]], se.fitted = tmp[["se.fit"]])
+ }
+
+ # variance(s) of average predictions
+ vc <- NA_real_
+
+ # output
+ structure(pred,
+ class = c("prediction", "data.frame"),
+ at = if (is.null(at)) at else at_specification,
+ type = type,
+ call = if ("call" %in% names(model)) model[["call"]] else NULL,
+ model_class = class(model),
+ row.names = seq_len(nrow(pred)),
+ vcov = vc,
+ jacobian = NULL,
+ weighted = FALSE)
+}
diff --git a/R/prediction_svm.R b/R/prediction_svm.R
index 8ec3fce..85b8337 100644
--- a/R/prediction_svm.R
+++ b/R/prediction_svm.R
@@ -1,90 +1,90 @@
-#' @rdname prediction
-#' @export
-prediction.svm <-
-function(model,
- data = NULL,
- at = NULL,
- calculate_se = TRUE,
- category,
- ...) {
-
- # extract predicted value
- data <- data
- anyp <- grep("prob.+", names(model))
- if (length(anyp) && !is.null(model[[ anyp[1L] ]])) {
- probability <- TRUE
- } else {
- probability <- FALSE
- }
- if (missing(data) || is.null(data)) {
- tmp <- predict(model, decision.values = TRUE, probability = probability, ...)
- pred <- data.frame(fitted.class = tmp)
- attributes(pred[["fitted.class"]]) <- NULL
- if (!is.null(attributes(tmp)[["probabilities"]])) {
- probs <- data.frame(attributes(tmp)[["probabilities"]])
- names(probs) <- paste0("Pr(", names(probs), ")")
- pred <- make_data_frame(pred, probs)
- }
- if (!is.null(attributes(tmp)[["decision.values"]])) {
- dvs <- data.frame(attributes(tmp)[["decision.values"]])
- names(dvs) <- paste0("dv(", names(dvs), ")")
- pred <- make_data_frame(pred, dvs)
- }
- } else {
- if (is.null(at)) {
- out <- data
- } else {
- out <- build_datalist(data, at = at, as.data.frame = TRUE)
- at_specification <- attr(out, "at_specification")
- }
- tmp <- predict(model, newdata = out, decision.values = TRUE, probability = probability, ...)
- pred <- make_data_frame(out, fitted.class = tmp)
- attributes(pred[["fitted.class"]]) <- NULL
- if (!is.null(attributes(tmp)[["probabilities"]])) {
- probs <- data.frame(attributes(tmp)[["probabilities"]])
- names(probs) <- paste0("Pr(", names(probs), ")")
- pred <- make_data_frame(pred, probs)
- }
- if (!is.null(attributes(tmp)[["decision.values"]])) {
- dvs <- data.frame(attributes(tmp)[["decision.values"]])
- names(dvs) <- paste0("dv(", names(dvs), ")")
- pred <- make_data_frame(pred, dvs)
- }
- }
-
- # handle category argument
- if (missing(category)) {
- w <- grep("^Pr\\(", names(pred))[1L]
- if (is.na(w)) {
- pred[["fitted"]] <- NA_real_
- category <- NULL
- } else {
- category <- names(pred)[w]
- pred[["fitted"]] <- pred[[w]]
- }
- } else {
- w <- which(names(pred) == paste0("Pr(", category, ")"))
- if (!length(w)) {
- stop(sprintf("category %s not found", category))
- }
- pred[["fitted"]] <- pred[[ w[1L] ]]
- }
- pred[["se.fitted"]] <- NA_real_
-
- # obs-x-(ncol(data)+2+nlevels(outcome)) data.frame of predictions
- # variance(s) of average predictions
- vc <- NA_real_
-
- # output
- structure(pred,
- class = c("prediction", "data.frame"),
- at = if (is.null(at)) at else at_specification,
- type = NA_character_,
- call = if ("call" %in% names(model)) model[["call"]] else NULL,
- model_class = class(model),
- row.names = seq_len(nrow(pred)),
- vcov = vc,
- jacobian = NULL,
- category = category,
- weighted = FALSE)
-}
+#' @rdname prediction
+#' @export
+prediction.svm <-
+function(model,
+ data = NULL,
+ at = NULL,
+ calculate_se = TRUE,
+ category,
+ ...) {
+
+ # extract predicted value
+ data <- data
+ anyp <- grep("prob.+", names(model))
+ if (length(anyp) && !is.null(model[[ anyp[1L] ]])) {
+ probability <- TRUE
+ } else {
+ probability <- FALSE
+ }
+ if (missing(data) || is.null(data)) {
+ tmp <- predict(model, decision.values = TRUE, probability = probability, ...)
+ pred <- data.frame(fitted.class = tmp)
+ attributes(pred[["fitted.class"]]) <- NULL
+ if (!is.null(attributes(tmp)[["probabilities"]])) {
+ probs <- data.frame(attributes(tmp)[["probabilities"]])
+ names(probs) <- paste0("Pr(", names(probs), ")")
+ pred <- make_data_frame(pred, probs)
+ }
+ if (!is.null(attributes(tmp)[["decision.values"]])) {
+ dvs <- data.frame(attributes(tmp)[["decision.values"]])
+ names(dvs) <- paste0("dv(", names(dvs), ")")
+ pred <- make_data_frame(pred, dvs)
+ }
+ } else {
+ if (is.null(at)) {
+ out <- data
+ } else {
+ out <- build_datalist(data, at = at, as.data.frame = TRUE)
+ at_specification <- attr(out, "at_specification")
+ }
+ tmp <- predict(model, newdata = out, decision.values = TRUE, probability = probability, ...)
+ pred <- make_data_frame(out, fitted.class = tmp)
+ attributes(pred[["fitted.class"]]) <- NULL
+ if (!is.null(attributes(tmp)[["probabilities"]])) {
+ probs <- data.frame(attributes(tmp)[["probabilities"]])
+ names(probs) <- paste0("Pr(", names(probs), ")")
+ pred <- make_data_frame(pred, probs)
+ }
+ if (!is.null(attributes(tmp)[["decision.values"]])) {
+ dvs <- data.frame(attributes(tmp)[["decision.values"]])
+ names(dvs) <- paste0("dv(", names(dvs), ")")
+ pred <- make_data_frame(pred, dvs)
+ }
+ }
+
+ # handle category argument
+ if (missing(category)) {
+ w <- grep("^Pr\\(", names(pred))[1L]
+ if (is.na(w)) {
+ pred[["fitted"]] <- NA_real_
+ category <- NULL
+ } else {
+ category <- names(pred)[w]
+ pred[["fitted"]] <- pred[[w]]
+ }
+ } else {
+ w <- which(names(pred) == paste0("Pr(", category, ")"))
+ if (!length(w)) {
+ stop(sprintf("category %s not found", category))
+ }
+ pred[["fitted"]] <- pred[[ w[1L] ]]
+ }
+ pred[["se.fitted"]] <- NA_real_
+
+ # obs-x-(ncol(data)+2+nlevels(outcome)) data.frame of predictions
+ # variance(s) of average predictions
+ vc <- NA_real_
+
+ # output
+ structure(pred,
+ class = c("prediction", "data.frame"),
+ at = if (is.null(at)) at else at_specification,
+ type = NA_character_,
+ call = if ("call" %in% names(model)) model[["call"]] else NULL,
+ model_class = class(model),
+ row.names = seq_len(nrow(pred)),
+ vcov = vc,
+ jacobian = NULL,
+ category = category,
+ weighted = FALSE)
+}
diff --git a/R/prediction_svyglm.R b/R/prediction_svyglm.R
index ca1934f..3e017e1 100644
--- a/R/prediction_svyglm.R
+++ b/R/prediction_svyglm.R
@@ -1,46 +1,46 @@
-#' @rdname prediction
-#' @export
-prediction.svyglm <-
-function(model,
- data = find_data(model, parent.frame()),
- at = NULL,
- type = c("response", "link"),
- calculate_se = TRUE,
- ...) {
-
- type <- match.arg(type)
-
- # extract predicted values
- data <- data
- if (missing(data) || is.null(data)) {
- pred <- predict(model, type = type, se.fit = TRUE, ...)
- pred <- data.frame(fitted = unclass(pred),
- se.fitted = sqrt(unname(attributes(pred)[["var"]])))
- } else {
- # setup data
- if (is.null(at)) {
- out <- data
- } else {
- out <- build_datalist(data, at = at, as.data.frame = TRUE)
- at_specification <- attr(out, "at_specification")
- }
- # calculate predictions
- tmp <- predict(model, newdata = out, type = type, se.fit = TRUE, ...)
- pred <- make_data_frame(out, fitted = unclass(tmp), se.fitted = sqrt(unname(attributes(tmp)[["var"]])))
- }
-
- # variance(s) of average predictions
- vc <- NA_real_
-
- # output
- structure(pred,
- class = c("prediction", "data.frame"),
- at = if (is.null(at)) at else at_specification,
- type = type,
- call = if ("call" %in% names(model)) model[["call"]] else NULL,
- model_class = class(model),
- row.names = seq_len(nrow(pred)),
- vcov = vc,
- jacobian = NULL,
- weighted = TRUE)
-}
+#' @rdname prediction
+#' @export
+prediction.svyglm <-
+function(model,
+ data = find_data(model, parent.frame()),
+ at = NULL,
+ type = c("response", "link"),
+ calculate_se = TRUE,
+ ...) {
+
+ type <- match.arg(type)
+
+ # extract predicted values
+ data <- data
+ if (missing(data) || is.null(data)) {
+ pred <- predict(model, type = type, se.fit = TRUE, ...)
+ pred <- data.frame(fitted = unclass(pred),
+ se.fitted = sqrt(unname(attributes(pred)[["var"]])))
+ } else {
+ # setup data
+ if (is.null(at)) {
+ out <- data
+ } else {
+ out <- build_datalist(data, at = at, as.data.frame = TRUE)
+ at_specification <- attr(out, "at_specification")
+ }
+ # calculate predictions
+ tmp <- predict(model, newdata = out, type = type, se.fit = TRUE, ...)
+ pred <- make_data_frame(out, fitted = unclass(tmp), se.fitted = sqrt(unname(attributes(tmp)[["var"]])))
+ }
+
+ # variance(s) of average predictions
+ vc <- NA_real_
+
+ # output
+ structure(pred,
+ class = c("prediction", "data.frame"),
+ at = if (is.null(at)) at else at_specification,
+ type = type,
+ call = if ("call" %in% names(model)) model[["call"]] else NULL,
+ model_class = class(model),
+ row.names = seq_len(nrow(pred)),
+ vcov = vc,
+ jacobian = NULL,
+ weighted = TRUE)
+}
diff --git a/R/prediction_train.R b/R/prediction_train.R
index 0933f96..2ccecc2 100644
--- a/R/prediction_train.R
+++ b/R/prediction_train.R
@@ -1,41 +1,41 @@
-#' @rdname prediction
-#' @export
-prediction.train <-
-function(model,
- data = find_data(model),
- at = NULL,
- type = c("raw", "prob"),
- ...) {
-
- type <- match.arg(type)
-
- # extract predicted values
- data <- data
- if (missing(data) || is.null(data)) {
- pred <- predict(model, type = type, se.fit = FALSE, ...)
- pred <- make_data_frame(fitted = pred, se.fitted = rep(NA_real_, length(pred)))
- } else {
- # setup data
- data <- build_datalist(data, at = at, as.data.frame = TRUE)
- at_specification <- attr(data, "at_specification")
- # calculate predictions
- tmp <- predict(model, newdata = data, type = type, se.fit = FALSE, ...)
- # cbind back together
- pred <- make_data_frame(data, fitted = tmp, se.fitted = rep(NA_real_, nrow(data)))
- }
-
- # variance(s) of average predictions
- vc <- NA_real_
-
- # output
- structure(pred,
- class = c("prediction", "data.frame"),
- at = if (is.null(at)) at else at_specification,
- type = type,
- call = if ("call" %in% names(model)) model[["call"]] else NULL,
- model_class = class(model),
- row.names = seq_len(nrow(pred)),
- vcov = vc,
- jacobian = NULL,
- weighted = FALSE)
-}
+#' @rdname prediction
+#' @export
+prediction.train <-
+function(model,
+ data = find_data(model),
+ at = NULL,
+ type = c("raw", "prob"),
+ ...) {
+
+ type <- match.arg(type)
+
+ # extract predicted values
+ data <- data
+ if (missing(data) || is.null(data)) {
+ pred <- predict(model, type = type, se.fit = FALSE, ...)
+ pred <- make_data_frame(fitted = pred, se.fitted = rep(NA_real_, length(pred)))
+ } else {
+ # setup data
+ data <- build_datalist(data, at = at, as.data.frame = TRUE)
+ at_specification <- attr(data, "at_specification")
+ # calculate predictions
+ tmp <- predict(model, newdata = data, type = type, se.fit = FALSE, ...)
+ # cbind back together
+ pred <- make_data_frame(data, fitted = tmp, se.fitted = rep(NA_real_, nrow(data)))
+ }
+
+ # variance(s) of average predictions
+ vc <- NA_real_
+
+ # output
+ structure(pred,
+ class = c("prediction", "data.frame"),
+ at = if (is.null(at)) at else at_specification,
+ type = type,
+ call = if ("call" %in% names(model)) model[["call"]] else NULL,
+ model_class = class(model),
+ row.names = seq_len(nrow(pred)),
+ vcov = vc,
+ jacobian = NULL,
+ weighted = FALSE)
+}
diff --git a/R/prediction_tree.R b/R/prediction_tree.R
index a315522..33b2ed8 100644
--- a/R/prediction_tree.R
+++ b/R/prediction_tree.R
@@ -1,74 +1,74 @@
-# @rdname prediction
-# @export
-prediction.tree <-
-function(model,
- data = find_data(model, parent.frame()),
- at = NULL,
- type = NULL,
- calculate_se = FALSE,
- category,
- ...) {
-
- if (!is.null(type)) {
- warning(sprintf("'type' is ignored for models of class '%s'", class(model)))
- }
-
- # extract predicted values
- data <- data
- if (missing(data) || is.null(data)) {
- if (is.factor(model[["y"]])) {
- pred <- make_data_frame(fitted.class = predict(model, type = "class", ...))
- probs <- make_data_frame(predict(model, type = "vector", ...))
- names(probs) <- paste0("Pr(", names(probs), ")")
- } else {
- pred <- make_data_frame(fitted = predict(model, type = "vector"),
- fitted.class = predict(model, type = "class", ...))
- }
- pred <- make_data_frame(pred, probs)
- } else {
- # setup data
- if (is.null(at)) {
- out <- data
- } else {
- out <- build_datalist(data, at = at, as.data.frame = TRUE)
- at_specification <- attr(out, "at_specification")
- }
- # calculate predictions
- tmp <- predict(model, newdata = out, type = "class", ...)
- tmp_probs <- make_data_frame(predict(model, newdata = out, type = "probs", ...))
- names(tmp_probs) <- paste0("Pr(", names(tmp_probs), ")")
- # cbind back together
- pred <- make_data_frame(out, fitted.class = tmp, tmp_probs)
- rm(tmp, tmp_probs)
- }
-
- # handle category argument
- if (missing(category)) {
- w <- grep("^Pr\\(", names(pred))[1L]
- category <- names(pred)[w]
- pred[["fitted"]] <- pred[[w]]
- } else {
- w <- which(names(pred) == paste0("Pr(", category, ")"))
- if (!length(w)) {
- stop(sprintf("category %s not found", category))
- }
- pred[["fitted"]] <- pred[[ w[1L] ]]
- }
- pred[["se.fitted"]] <- NA_real_
-
- # variance(s) of average predictions
- vc <- NA_real_
-
- # output
- structure(pred,
- class = c("prediction", "data.frame"),
- at = if (is.null(at)) at else at_specification,
- type = NA_character_,
- call = if ("call" %in% names(model)) model[["call"]] else NULL,
- model_class = class(model),
- row.names = seq_len(nrow(pred)),
- vcov = vc,
- jacobian = NULL,
- category = category,
- weighted = FALSE)
-}
+# @rdname prediction
+# @export
+prediction.tree <-
+function(model,
+ data = find_data(model, parent.frame()),
+ at = NULL,
+ type = NULL,
+ calculate_se = FALSE,
+ category,
+ ...) {
+
+ if (!is.null(type)) {
+ warning(sprintf("'type' is ignored for models of class '%s'", class(model)))
+ }
+
+ # extract predicted values
+ data <- data
+ if (missing(data) || is.null(data)) {
+ if (is.factor(model[["y"]])) {
+ pred <- make_data_frame(fitted.class = predict(model, type = "class", ...))
+ probs <- make_data_frame(predict(model, type = "vector", ...))
+ names(probs) <- paste0("Pr(", names(probs), ")")
+ } else {
+ pred <- make_data_frame(fitted = predict(model, type = "vector"),
+ fitted.class = predict(model, type = "class", ...))
+ }
+ pred <- make_data_frame(pred, probs)
+ } else {
+ # setup data
+ if (is.null(at)) {
+ out <- data
+ } else {
+ out <- build_datalist(data, at = at, as.data.frame = TRUE)
+ at_specification <- attr(out, "at_specification")
+ }
+ # calculate predictions
+ tmp <- predict(model, newdata = out, type = "class", ...)
+ tmp_probs <- make_data_frame(predict(model, newdata = out, type = "probs", ...))
+ names(tmp_probs) <- paste0("Pr(", names(tmp_probs), ")")
+ # cbind back together
+ pred <- make_data_frame(out, fitted.class = tmp, tmp_probs)
+ rm(tmp, tmp_probs)
+ }
+
+ # handle category argument
+ if (missing(category)) {
+ w <- grep("^Pr\\(", names(pred))[1L]
+ category <- names(pred)[w]
+ pred[["fitted"]] <- pred[[w]]
+ } else {
+ w <- which(names(pred) == paste0("Pr(", category, ")"))
+ if (!length(w)) {
+ stop(sprintf("category %s not found", category))
+ }
+ pred[["fitted"]] <- pred[[ w[1L] ]]
+ }
+ pred[["se.fitted"]] <- NA_real_
+
+ # variance(s) of average predictions
+ vc <- NA_real_
+
+ # output
+ structure(pred,
+ class = c("prediction", "data.frame"),
+ at = if (is.null(at)) at else at_specification,
+ type = NA_character_,
+ call = if ("call" %in% names(model)) model[["call"]] else NULL,
+ model_class = class(model),
+ row.names = seq_len(nrow(pred)),
+ vcov = vc,
+ jacobian = NULL,
+ category = category,
+ weighted = FALSE)
+}
diff --git a/R/prediction_truncreg.R b/R/prediction_truncreg.R
index 5467282..a36e275 100644
--- a/R/prediction_truncreg.R
+++ b/R/prediction_truncreg.R
@@ -1,34 +1,34 @@
-#' @rdname prediction
-#' @export
-prediction.truncreg <- function(model, data, at = NULL, calculate_se = FALSE, ...) {
-
- # extract predicted values
- if (missing(data) || is.null(data)) {
- pred <- make_data_frame(fitted = predict(object = model, ...))
- } else {
- # setup data
- if (is.null(at)) {
- out <- data
- } else {
- out <- build_datalist(data, at = at, as.data.frame = TRUE)
- at_specification <- attr(out, "at_specification")
- }
- pred <- make_data_frame(fitted = predict(model, newdata = data, ...))
- }
- pred[["se.fitted"]] <- NA_real_
-
- # variance(s) of average predictions
- vc <- NA_real_
-
- # output
- structure(pred,
- class = c("prediction", "data.frame"),
- at = if (is.null(at)) at else at_specification,
- type = NA_character_,
- call = if ("call" %in% names(model)) model[["call"]] else NULL,
- model_class = class(model),
- row.names = seq_len(nrow(pred)),
- vcov = vc,
- jacobian = NULL,
- weighted = FALSE)
-}
+#' @rdname prediction
+#' @export
+prediction.truncreg <- function(model, data, at = NULL, calculate_se = FALSE, ...) {
+
+ # extract predicted values
+ if (missing(data) || is.null(data)) {
+ pred <- make_data_frame(fitted = predict(object = model, ...))
+ } else {
+ # setup data
+ if (is.null(at)) {
+ out <- data
+ } else {
+ out <- build_datalist(data, at = at, as.data.frame = TRUE)
+ at_specification <- attr(out, "at_specification")
+ }
+ pred <- make_data_frame(fitted = predict(model, newdata = data, ...))
+ }
+ pred[["se.fitted"]] <- NA_real_
+
+ # variance(s) of average predictions
+ vc <- NA_real_
+
+ # output
+ structure(pred,
+ class = c("prediction", "data.frame"),
+ at = if (is.null(at)) at else at_specification,
+ type = NA_character_,
+ call = if ("call" %in% names(model)) model[["call"]] else NULL,
+ model_class = class(model),
+ row.names = seq_len(nrow(pred)),
+ vcov = vc,
+ jacobian = NULL,
+ weighted = FALSE)
+}
diff --git a/R/prediction_vgam.R b/R/prediction_vgam.R
index 660f35f..3c885b2 100644
--- a/R/prediction_vgam.R
+++ b/R/prediction_vgam.R
@@ -1,62 +1,62 @@
-# @rdname prediction
-# @export
-prediction.vgam <-
-function(model,
- data = find_data(model, parent.frame()),
- at = NULL,
- type = c("response", "link"),
- calculate_se = FALSE,
- category,
- ...) {
-
- type <- match.arg(type)
-
- # extract predicted values
- data <- data
- if (missing(data) || is.null(data)) {
- pred <- make_data_frame(predict(model, type = type, se.fit = FALSE, ...))
- } else {
- # setup data
- if (is.null(at)) {
- out <- data
- } else {
- out <- build_datalist(data, at = at, as.data.frame = TRUE)
- at_specification <- attr(out, "at_specification")
- }
- # calculate predictions
- tmp <- predict(model, newdata = out, type = type, se.fit = FALSE, ...)
- if (!is.null(dim(tmp))) {
- tmp <- as.matrix(tmp, ncol = 1)
- }
- # cbind back together
- pred <- make_data_frame(out, fitted = make_data_frame(tmp), se.fitted = rep(NA_real_, nrow(out)))
- }
-
- # handle category argument
- if (missing(category)) {
- category <- names(pred)[!names(pred) %in% names(data)][1L]
- pred[["fitted"]] <- pred[[category]]
- } else {
- w <- grep(category, names(pred))
- if (!length(w)) {
- stop(sprintf("category %s not found", category))
- }
- pred[["fitted"]] <- pred[[ w[1L] ]]
- }
-
- # variance(s) of average predictions
- vc <- NA_real_
-
- # output
- structure(pred,
- class = c("prediction", "data.frame"),
- at = if (is.null(at)) at else at_specification,
- type = type,
- call = if ("call" %in% names(model)) model[["call"]] else NULL,
- model_class = class(model),
- row.names = seq_len(nrow(pred)),
- vcov = vc,
- jacobian = NULL,
- category = category,
- weighted = FALSE)
-}
+# @rdname prediction
+# @export
+prediction.vgam <-
+function(model,
+ data = find_data(model, parent.frame()),
+ at = NULL,
+ type = c("response", "link"),
+ calculate_se = FALSE,
+ category,
+ ...) {
+
+ type <- match.arg(type)
+
+ # extract predicted values
+ data <- data
+ if (missing(data) || is.null(data)) {
+ pred <- make_data_frame(predict(model, type = type, se.fit = FALSE, ...))
+ } else {
+ # setup data
+ if (is.null(at)) {
+ out <- data
+ } else {
+ out <- build_datalist(data, at = at, as.data.frame = TRUE)
+ at_specification <- attr(out, "at_specification")
+ }
+ # calculate predictions
+ tmp <- predict(model, newdata = out, type = type, se.fit = FALSE, ...)
+ if (!is.null(dim(tmp))) {
+ tmp <- as.matrix(tmp, ncol = 1)
+ }
+ # cbind back together
+ pred <- make_data_frame(out, fitted = make_data_frame(tmp), se.fitted = rep(NA_real_, nrow(out)))
+ }
+
+ # handle category argument
+ if (missing(category)) {
+ category <- names(pred)[!names(pred) %in% names(data)][1L]
+ pred[["fitted"]] <- pred[[category]]
+ } else {
+ w <- grep(category, names(pred))
+ if (!length(w)) {
+ stop(sprintf("category %s not found", category))
+ }
+ pred[["fitted"]] <- pred[[ w[1L] ]]
+ }
+
+ # variance(s) of average predictions
+ vc <- NA_real_
+
+ # output
+ structure(pred,
+ class = c("prediction", "data.frame"),
+ at = if (is.null(at)) at else at_specification,
+ type = type,
+ call = if ("call" %in% names(model)) model[["call"]] else NULL,
+ model_class = class(model),
+ row.names = seq_len(nrow(pred)),
+ vcov = vc,
+ jacobian = NULL,
+ category = category,
+ weighted = FALSE)
+}
diff --git a/R/prediction_vglm.R b/R/prediction_vglm.R
index ca18ee8..af8f4ce 100644
--- a/R/prediction_vglm.R
+++ b/R/prediction_vglm.R
@@ -1,72 +1,72 @@
-# @rdname prediction
-# @export
-prediction.vglm <-
-function(model,
- data = find_data(model, parent.frame()),
- at = NULL,
- type = c("response", "link"),
- calculate_se = TRUE,
- category,
- ...) {
-
- type <- match.arg(type)
-
- # extract predicted values
- data <- data
- arg <- list(...)
- if (missing(data) || is.null(data)) {
- if ("se.fit" %in% names(arg)) {
- tmp <- predict(model, type = type, ...)
- pred <- make_data_frame(tmp[["fitted.values"]], se.fitted = tmp[["se.fit"]])
- } else {
- pred <- make_data_frame(predict(model, type = type, se.fit = FALSE, ...))
- }
- } else {
- # setup data
- if (is.null(at)) {
- out <- data
- } else {
- out <- build_datalist(data, at = at, as.data.frame = TRUE)
- at_specification <- attr(out, "at_specification")
- }
- # calculate predictions
- if ("se.fit" %in% names(arg)) {
- tmp <- predict(model, newdata = out, type = type, ...)
- # cbind back together
- pred <- make_data_frame(out, tmp[["fitted.values"]], se.fitted = tmp[["se.fit"]])
- } else {
- tmp <- predict(model, newdata = out, type = type, ...)
- # cbind back together
- pred <- make_data_frame(out, tmp[["fitted.values"]], se.fitted = rep(NA_real_, nrow(out)))
- }
- rm(tmp)
- }
-
- # handle category argument
- if (missing(category)) {
- category <- names(pred)[!names(pred) %in% names(data)][1L]
- pred[["fitted"]] <- pred[[category]]
- } else {
- w <- grep(category, names(pred))
- if (!length(w)) {
- stop(sprintf("category %s not found", category))
- }
- pred[["fitted"]] <- pred[[ w[1L] ]]
- }
-
- # variance(s) of average predictions
- vc <- NA_real_
-
- # output
- structure(pred,
- class = c("prediction", "data.frame"),
- at = if (is.null(at)) at else at_specification,
- type = type,
- call = if ("call" %in% names(model)) model[["call"]] else NULL,
- model_class = class(model),
- row.names = seq_len(nrow(pred)),
- vcov = vc,
- jacobian = NULL,
- category = category,
- weighted = FALSE)
-}
+# @rdname prediction
+# @export
+prediction.vglm <-
+function(model,
+ data = find_data(model, parent.frame()),
+ at = NULL,
+ type = c("response", "link"),
+ calculate_se = TRUE,
+ category,
+ ...) {
+
+ type <- match.arg(type)
+
+ # extract predicted values
+ data <- data
+ arg <- list(...)
+ if (missing(data) || is.null(data)) {
+ if ("se.fit" %in% names(arg)) {
+ tmp <- predict(model, type = type, ...)
+ pred <- make_data_frame(tmp[["fitted.values"]], se.fitted = tmp[["se.fit"]])
+ } else {
+ pred <- make_data_frame(predict(model, type = type, se.fit = FALSE, ...))
+ }
+ } else {
+ # setup data
+ if (is.null(at)) {
+ out <- data
+ } else {
+ out <- build_datalist(data, at = at, as.data.frame = TRUE)
+ at_specification <- attr(out, "at_specification")
+ }
+ # calculate predictions
+ if ("se.fit" %in% names(arg)) {
+ tmp <- predict(model, newdata = out, type = type, ...)
+ # cbind back together
+ pred <- make_data_frame(out, tmp[["fitted.values"]], se.fitted = tmp[["se.fit"]])
+ } else {
+ tmp <- predict(model, newdata = out, type = type, ...)
+ # cbind back together
+ pred <- make_data_frame(out, tmp[["fitted.values"]], se.fitted = rep(NA_real_, nrow(out)))
+ }
+ rm(tmp)
+ }
+
+ # handle category argument
+ if (missing(category)) {
+ category <- names(pred)[!names(pred) %in% names(data)][1L]
+ pred[["fitted"]] <- pred[[category]]
+ } else {
+ w <- grep(category, names(pred))
+ if (!length(w)) {
+ stop(sprintf("category %s not found", category))
+ }
+ pred[["fitted"]] <- pred[[ w[1L] ]]
+ }
+
+ # variance(s) of average predictions
+ vc <- NA_real_
+
+ # output
+ structure(pred,
+ class = c("prediction", "data.frame"),
+ at = if (is.null(at)) at else at_specification,
+ type = type,
+ call = if ("call" %in% names(model)) model[["call"]] else NULL,
+ model_class = class(model),
+ row.names = seq_len(nrow(pred)),
+ vcov = vc,
+ jacobian = NULL,
+ category = category,
+ weighted = FALSE)
+}
diff --git a/R/prediction_zeroinfl.R b/R/prediction_zeroinfl.R
index ef2c796..7fb2068 100644
--- a/R/prediction_zeroinfl.R
+++ b/R/prediction_zeroinfl.R
@@ -1,3 +1,3 @@
-#' @rdname prediction
-#' @export
-prediction.zeroinfl <- prediction.hurdle
+#' @rdname prediction
+#' @export
+prediction.zeroinfl <- prediction.hurdle
diff --git a/R/print.R b/R/print.R
index 21909fa..c90c250 100644
--- a/R/print.R
+++ b/R/print.R
@@ -1,81 +1,81 @@
-#' @export
-print.prediction <- function(x, digits = 4, ...) {
-
- # gather metadata
- f <- x[["fitted"]]
- fc <- x[["fitted.class"]]
- ## at
- at <- attributes(x)[["at"]]
- at_names <- setdiff(names(attr(x, "at")), "index")
-
- ## weights
- is_weighted <- attr(x, "weighted")
- if (isTRUE(is_weighted)) {
- wts <- x[["_weights"]]
- }
-
- # calculate overall predictions
- ## if no 'at_specification', simply calculate overall average/mode and print
- if (is.null(at)) {
- # object is a single replication with no 'at' specification
- if ("fitted.class" %in% names(x) || is.list(fc)) {
- # factor outcome
- m <- sort(table(x[["fitted.class"]]), decreasing = TRUE)[1L]
- message(
- sprintf("Data frame with %d %s%swith modal prediction (of %d %s):",
- length(fc),
- ngettext(length(fc), "prediction", "predictions"),
- if (!is.null(attr(x, "call"))) sprintf(" from\n %s\n", paste0(deparse(attr(x, "call")), collapse = "\n")) else "",
- nlevels(factor(fc)),
- ngettext(nlevels(f), "level", "levels"),
- shQuote(names(m))
- )
- )
- } else {
- # numeric outcome
- message(
- sprintf("Data frame with %d %s%swith average prediction: %s",
- length(f),
- ngettext(length(fc), "prediction", "predictions"),
- if (!is.null(attr(x, "call"))) sprintf(" from\n %s\n", paste0(deparse(attr(x, "call")), collapse = "\n")) else "",
- sprintf(paste0("%0.", digits, "f"), mean(f, na.rm = TRUE))
- )
- )
- }
- } else {
- # otherwise, object has an 'at' specification, reflecting multiple requested predictions
-
- # convert 'at_specification' into data frame
- xby <- x[ , setdiff(names(at), "index"), drop = FALSE]
-
- if ("fitted.class" %in% names(x) || is.list(fc)) {
- # factor outcome
- out <- aggregate(x[["fitted.class"]], xby, FUN = function(set) names(sort(table(set), decreasing = TRUE))[1L])
- message(
- sprintf("Data frame with %d %s%swith modal %s (of %d %s):",
- nrow(x),
- ngettext(nrow(x), "prediction", "predictions"),
- if (!is.null(attr(x, "call"))) sprintf(" from\n %s\n", paste0(deparse(attr(x, "call")), collapse = "\n")) else "",
- ngettext(nrow(out), "prediction", "predictions"),
- nlevels(factor(fc)),
- ngettext(nlevels(fc), "level", "levels")
- )
- )
- } else {
- # numeric outcome
- out <- aggregate(x[["fitted"]], xby, FUN = mean, na.rm = TRUE)
- message(
- sprintf("Data frame with %d %s%swith average %s:",
- nrow(x),
- ngettext(nrow(x), "prediction", "predictions"),
- if (!is.null(attr(x, "call"))) sprintf(" from\n %s\n", paste0(deparse(attr(x, "call")), collapse = "\n")) else "",
- ngettext(nrow(out), "prediction", "predictions")
- )
- )
- }
- print(out, digits = digits, row.names = FALSE, ...)
- }
-
- # return invisibly
- invisible(x)
-}
+#' @export
+print.prediction <- function(x, digits = 4, ...) {
+
+ # gather metadata
+ f <- x[["fitted"]]
+ fc <- x[["fitted.class"]]
+ ## at
+ at <- attributes(x)[["at"]]
+ at_names <- setdiff(names(attr(x, "at")), "index")
+
+ ## weights
+ is_weighted <- attr(x, "weighted")
+ if (isTRUE(is_weighted)) {
+ wts <- x[["_weights"]]
+ }
+
+ # calculate overall predictions
+ ## if no 'at_specification', simply calculate overall average/mode and print
+ if (is.null(at)) {
+ # object is a single replication with no 'at' specification
+ if ("fitted.class" %in% names(x) || is.list(fc)) {
+ # factor outcome
+ m <- sort(table(x[["fitted.class"]]), decreasing = TRUE)[1L]
+ message(
+ sprintf("Data frame with %d %s%swith modal prediction (of %d %s):",
+ length(fc),
+ ngettext(length(fc), "prediction", "predictions"),
+ if (!is.null(attr(x, "call"))) sprintf(" from\n %s\n", paste0(deparse(attr(x, "call")), collapse = "\n")) else "",
+ nlevels(factor(fc)),
+ ngettext(nlevels(f), "level", "levels"),
+ shQuote(names(m))
+ )
+ )
+ } else {
+ # numeric outcome
+ message(
+ sprintf("Data frame with %d %s%swith average prediction: %s",
+ length(f),
+ ngettext(length(fc), "prediction", "predictions"),
+ if (!is.null(attr(x, "call"))) sprintf(" from\n %s\n", paste0(deparse(attr(x, "call")), collapse = "\n")) else "",
+ sprintf(paste0("%0.", digits, "f"), mean(f, na.rm = TRUE))
+ )
+ )
+ }
+ } else {
+ # otherwise, object has an 'at' specification, reflecting multiple requested predictions
+
+ # convert 'at_specification' into data frame
+ xby <- x[ , setdiff(names(at), "index"), drop = FALSE]
+
+ if ("fitted.class" %in% names(x) || is.list(fc)) {
+ # factor outcome
+ out <- aggregate(x[["fitted.class"]], xby, FUN = function(set) names(sort(table(set), decreasing = TRUE))[1L])
+ message(
+ sprintf("Data frame with %d %s%swith modal %s (of %d %s):",
+ nrow(x),
+ ngettext(nrow(x), "prediction", "predictions"),
+ if (!is.null(attr(x, "call"))) sprintf(" from\n %s\n", paste0(deparse(attr(x, "call")), collapse = "\n")) else "",
+ ngettext(nrow(out), "prediction", "predictions"),
+ nlevels(factor(fc)),
+ ngettext(nlevels(fc), "level", "levels")
+ )
+ )
+ } else {
+ # numeric outcome
+ out <- aggregate(x[["fitted"]], xby, FUN = mean, na.rm = TRUE)
+ message(
+ sprintf("Data frame with %d %s%swith average %s:",
+ nrow(x),
+ ngettext(nrow(x), "prediction", "predictions"),
+ if (!is.null(attr(x, "call"))) sprintf(" from\n %s\n", paste0(deparse(attr(x, "call")), collapse = "\n")) else "",
+ ngettext(nrow(out), "prediction", "predictions")
+ )
+ )
+ }
+ print(out, digits = digits, row.names = FALSE, ...)
+ }
+
+ # return invisibly
+ invisible(x)
+}
diff --git a/R/seq_range.R b/R/seq_range.R
index ea315a2..b3565d1 100644
--- a/R/seq_range.R
+++ b/R/seq_range.R
@@ -1,16 +1,16 @@
-#' @title Create a sequence over the range of a vector
-#' @description Define a sequence of evenly spaced values from the minimum to the maximum of a vector
-#' @param x A numeric vector
-#' @param n An integer specifying the length of sequence (i.e., number of points across the range of \code{x})
-#' @return A vector of length \code{n}.
-#' @examples
-#' identical(range(1:5), seq_range(1:5, n = 2))
-#' seq_range(1:5, n = 3)
-#'
-#' @seealso \code{\link{mean_or_mode}}, \code{\link{build_datalist}}
-#' @export
-seq_range <- function(x, n = 2) {
- seq(min(x, na.rm = TRUE),
- max(x, na.rm = TRUE),
- length.out = n)
-}
+#' @title Create a sequence over the range of a vector
+#' @description Define a sequence of evenly spaced values from the minimum to the maximum of a vector
+#' @param x A numeric vector
+#' @param n An integer specifying the length of sequence (i.e., number of points across the range of \code{x})
+#' @return A vector of length \code{n}.
+#' @examples
+#' identical(range(1:5), seq_range(1:5, n = 2))
+#' seq_range(1:5, n = 3)
+#'
+#' @seealso \code{\link{mean_or_mode}}, \code{\link{build_datalist}}
+#' @export
+seq_range <- function(x, n = 2) {
+ seq(min(x, na.rm = TRUE),
+ max(x, na.rm = TRUE),
+ length.out = n)
+}
diff --git a/R/summary.R b/R/summary.R
index 57c1666..945b91a 100644
--- a/R/summary.R
+++ b/R/summary.R
@@ -1,65 +1,65 @@
-#' @import stats
-#' @export
-summary.prediction <- function(object, level = 0.95, ...) {
- # summary method
-
- # gather metadata
- f <- object[["fitted"]]
- fc <- object[["fitted.class"]]
- vc <- attributes(object)[["vcov"]]
- if (is.null(vc)) {
- vc <- NA_real_
- }
-
- # convert 'at_specification' into data frame
- at <- attributes(object)[["at"]]
- # aggregate average predictions from data
- if (is.null(at)) {
- objectby <- list(rep(1L, nrow(object)))
- out <- aggregate(object[["fitted"]], objectby, FUN = mean, na.rm = TRUE)
- out[["Group.1"]] <- NULL
- } else {
- objectby <- object[ , setdiff(names(at), "index"), drop = FALSE]
-
- out <- aggregate(object[["fitted"]], objectby, FUN = mean, na.rm = TRUE)
- }
-
- # extract calculated variance from object
- out[["SE"]] <- sqrt(vc)
-
- # cleanup output
- names(out)[names(out) == "x"] <- "Prediction"
- at_names <- names(out)[!names(out) %in% c("Prediction", "SE")]
- at_names <- if (length(at_names)) paste0("at(", at_names, ")") else NULL
- names(out)[!names(out) %in% c("Prediction", "SE")] <- at_names
-
- # add z and p
- out[["z"]] <- out[,"Prediction"]/out[,"SE"]
- out[["p"]] <- 2 * pnorm(abs(out[,"z"]), lower.tail = FALSE)
-
- # add CI
- a <- (1 - level)/2
- a <- c(a, 1 - a)
- fac <- qnorm(a)
- ci <- array(NA_real_, dim = c(nrow(out), 2L))
- ci[] <- out[["Prediction"]] + out[["SE"]] %o% fac
- colnames(ci) <- c("lower", "upper")
- out <- cbind(out, ci)
-
- # return
- structure(out[, c(at_names, "Prediction", "SE", "z", "p", "lower", "upper"), drop = FALSE],
- class = c("summary.prediction", "data.frame"))
-}
-
-#' @export
-print.summary.prediction <- function(x, digits = 4, ...) {
- print(`class<-`(x, "data.frame"), digits = digits, row.names = FALSE, ...)
-}
-
-#' @rdname prediction
-#' @param level A numeric value specifying the confidence level for calculating p-values and confidence intervals.
-#' @export
-prediction_summary <- function(model, ..., level = 0.95) {
- predictions <- prediction(model, ...)
- summary(predictions, level = 0.95)
-}
+#' @import stats
+#' @export
+summary.prediction <- function(object, level = 0.95, ...) {
+ # summary method
+
+ # gather metadata
+ f <- object[["fitted"]]
+ fc <- object[["fitted.class"]]
+ vc <- attributes(object)[["vcov"]]
+ if (is.null(vc)) {
+ vc <- NA_real_
+ }
+
+ # convert 'at_specification' into data frame
+ at <- attributes(object)[["at"]]
+ # aggregate average predictions from data
+ if (is.null(at)) {
+ objectby <- list(rep(1L, nrow(object)))
+ out <- aggregate(object[["fitted"]], objectby, FUN = mean, na.rm = TRUE)
+ out[["Group.1"]] <- NULL
+ } else {
+ objectby <- object[ , setdiff(names(at), "index"), drop = FALSE]
+
+ out <- aggregate(object[["fitted"]], objectby, FUN = mean, na.rm = TRUE)
+ }
+
+ # extract calculated variance from object
+ out[["SE"]] <- sqrt(vc)
+
+ # cleanup output
+ names(out)[names(out) == "x"] <- "Prediction"
+ at_names <- names(out)[!names(out) %in% c("Prediction", "SE")]
+ at_names <- if (length(at_names)) paste0("at(", at_names, ")") else NULL
+ names(out)[!names(out) %in% c("Prediction", "SE")] <- at_names
+
+ # add z and p
+ out[["z"]] <- out[,"Prediction"]/out[,"SE"]
+ out[["p"]] <- 2 * pnorm(abs(out[,"z"]), lower.tail = FALSE)
+
+ # add CI
+ a <- (1 - level)/2
+ a <- c(a, 1 - a)
+ fac <- qnorm(a)
+ ci <- array(NA_real_, dim = c(nrow(out), 2L))
+ ci[] <- out[["Prediction"]] + out[["SE"]] %o% fac
+ colnames(ci) <- c("lower", "upper")
+ out <- cbind(out, ci)
+
+ # return
+ structure(out[, c(at_names, "Prediction", "SE", "z", "p", "lower", "upper"), drop = FALSE],
+ class = c("summary.prediction", "data.frame"))
+}
+
+#' @export
+print.summary.prediction <- function(x, digits = 4, ...) {
+ print(`class<-`(x, "data.frame"), digits = digits, row.names = FALSE, ...)
+}
+
+#' @rdname prediction
+#' @param level A numeric value specifying the confidence level for calculating p-values and confidence intervals.
+#' @export
+prediction_summary <- function(model, ..., level = 0.95) {
+ predictions <- prediction(model, ...)
+ summary(predictions, level = 0.95)
+}
diff --git a/R/utils.R b/R/utils.R
index 14e2a13..ebb19cb 100644
--- a/R/utils.R
+++ b/R/utils.R
@@ -1,11 +1,11 @@
-#' @importFrom utils head
-#' @export
-head.prediction <- function(x, ...) {
- head(`class<-`(x, "data.frame"), ...)
-}
-
-#' @importFrom utils tail
-#' @export
-tail.prediction <- function(x, ...) {
- tail(`class<-`(x, "data.frame"), ...)
-}
+#' @importFrom utils head
+#' @export
+head.prediction <- function(x, ...) {
+ head(`class<-`(x, "data.frame"), ...)
+}
+
+#' @importFrom utils tail
+#' @export
+tail.prediction <- function(x, ...) {
+ tail(`class<-`(x, "data.frame"), ...)
+}
diff --git a/README.md b/README.md
index c11eca7..20612b4 100644
--- a/README.md
+++ b/README.md
@@ -1,185 +1,185 @@
----
-title: "Tidy, Type-Safe 'prediction()' Methods"
-output: github_document
----
-
-<img src="man/figures/logo.png" align="right" />
-
-The **prediction** and **margins** packages are a combined effort to port the functionality of Stata's (closed source) [`margins`](http://www.stata.com/help.cgi?margins) command to (open source) R. **prediction** is focused on one function - `prediction()` - that provides type-safe methods for generating predictions from fitted regression models. `prediction()` is an S3 generic, which always return a `"data.frame"` class object rather than the mix of vectors, lists, etc. that are returned by the `predict()` methods for various model types. It provides a key piece of underlying infrastructure for the **margins** package. Users interested in generating marginal (partial) effects, like those generated by Stata's `margins, dydx(*)` command, should consider using `margins()` from the sibling project, [**margins**](https://cran.r-project.org/package=margins).
-
-In addition to `prediction()`, this package provides a number of utility functions for generating useful predictions:
-
- - `find_data()`, an S3 generic with methods that find the data frame used to estimate a regression model. This is a wrapper around `get_all_vars()` that attempts to locate data as well as modify it according to `subset` and `na.action` arguments used in the original modelling call.
- - `mean_or_mode()` and `median_or_mode()`, which provide a convenient way to compute the data needed for predicted values *at means* (or *at medians*), respecting the differences between factor and numeric variables.
- - `seq_range()`, which generates a vector of *n* values based upon the range of values in a variable
- - `build_datalist()`, which generates a list of data frames from an input data frame and a specified set of replacement `at` values (mimicking the `atlist` option of Stata's `margins` command)
-
-## Simple code examples
-
-
-
-A major downside of the `predict()` methods for common modelling classes is that the result is not type-safe. Consider the following simple example:
-
-
-```r
-library("stats")
-library("datasets")
-x <- lm(mpg ~ cyl * hp + wt, data = mtcars)
-class(predict(x))
-```
-
-```
-## [1] "numeric"
-```
-
-```r
-class(predict(x, se.fit = TRUE))
-```
-
-```
-## [1] "list"
-```
-
-**prediction** solves this issue by providing a wrapper around `predict()`, called `prediction()`, that always returns a tidy data frame with a very simple `print()` method:
-
-
-```r
-library("prediction")
-(p <- prediction(x))
-```
-
-```
-## Data frame with 32 predictions from
-## lm(formula = mpg ~ cyl * hp + wt, data = mtcars)
-## with average prediction: 20.0906
-```
-
-```r
-class(p)
-```
-
-```
-## [1] "prediction" "data.frame"
-```
-
-```r
-head(p)
-```
-
-```
-## mpg cyl disp hp drat wt qsec vs am gear carb fitted se.fitted
-## 1 21.0 6 160 110 3.90 2.620 16.46 0 1 4 4 21.90488 0.6927034
-## 2 21.0 6 160 110 3.90 2.875 17.02 0 1 4 4 21.10933 0.6266557
-## 3 22.8 4 108 93 3.85 2.320 18.61 1 1 4 1 25.64753 0.6652076
-## 4 21.4 6 258 110 3.08 3.215 19.44 1 0 3 1 20.04859 0.6041400
-## 5 18.7 8 360 175 3.15 3.440 17.02 0 0 3 2 17.25445 0.7436172
-## 6 18.1 6 225 105 2.76 3.460 20.22 1 0 3 1 19.53360 0.6436862
-```
-
-The output always contains the original data (i.e., either data found using the `find_data()` function or passed to the `data` argument to `prediction()`). This makes it much simpler to pass predictions to, e.g., further summary or plotting functions.
-
-Additionally the vast majority of methods allow the passing of an `at` argument, which can be used to obtain predicted values using modified version of `data` held to specific values:
-
-
-```r
-prediction(x, at = list(hp = seq_range(mtcars$hp, 5)))
-```
-
-```
-## Data frame with 160 predictions from
-## lm(formula = mpg ~ cyl * hp + wt, data = mtcars)
-## with average predictions:
-```
-
-```
-## hp x
-## 52.0 22.605
-## 122.8 19.328
-## 193.5 16.051
-## 264.2 12.774
-## 335.0 9.497
-```
-
-This more or less serves as a direct R port of (the subset of functionality of) Stata's `margins` command that calculates predictive marginal means, etc. For calculation of marginal or partial effects, see the [**margins**](https://cran.r-project.org/package=margins) package.
-
-## Supported model classes
-
-The currently supported model classes are:
-
- - "lm" from `stats::lm()`
- - "glm" from `stats::glm()`, `MASS::glm.nb()`, `glmx::glmx()`, `glmx::hetglm()`, `brglm::brglm()`
- - "ar" from `stats::ar()`
- - "Arima" from `stats::arima()`
- - "arima0" from `stats::arima0()`
- - "biglm" from `biglm::biglm()` (including `"ffdf"` backed models)
- - "betareg" from `betareg::betareg()`
- - "bruto" from `mda::bruto()`
- - "clm" from `ordinal::clm()`
- - "coxph" from `survival::coxph()`
- - "crch" from `crch::crch()`
- - "earth" from `earth::earth()`
- - "fda" from `mda::fda()`
- - "Gam" from `gam::gam()`
- - "gausspr" from `kernlab::gausspr()`
- - "gee" from `gee::gee()`
- - "glimML" from `aod::betabin()`, `aod::negbin()`
- - "glimQL" from `aod::quasibin()`, `aod::quasipois()`
- - "glmnet" from `glmnet::glmnet()`
- - "gls" from `nlme::gls()`
- - "hurdle" from `pscl::hurdle()`
- - "hxlr" from `crch::hxlr()`
- - "ivreg" from `AER::ivreg()`
- - "knnreg" from `caret::knnreg()`
- - "kqr" from `kernlab::kqr()`
- - "ksvm" from `kernlab::ksvm()`
- - "lda" from `MASS:lda()`
- - "lme" from `nlme::lme()`
- - "loess" from `stats::loess()`
- - "lqs" from `MASS::lqs()`
- - "mars" from `mda::mars()`
- - "mca" from `MASS::mca()`
- - "mclogit" from `mclogit::mclogit()`
- - "mda" from `mda::mda()`
- - "merMod" from `lme4::lmer()` and `lme4::glmer()`
- - "mnlogit" from `mnlogit::mnlogit()`
- - "mnp" from `MNP::mnp()`
- - "naiveBayes" from `e1071::naiveBayes()`
- - "nlme" from `nlme::nlme()`
- - "nls" from `stats::nls()`
- - "nnet" from `nnet::nnet()`, `nnet::multinom()`
- - "plm" from `plm::plm()`
- - "polr" from `MASS::polr()`
- - "ppr" from `stats::ppr()`
- - "princomp" from `stats::princomp()`
- - "qda" from `MASS:qda()`
- - "rlm" from `MASS::rlm()`
- - "rpart" from `rpart::rpart()`
- - "rq" from `quantreg::rq()`
- - "selection" from `sampleSelection::selection()`
- - "speedglm" from `speedglm::speedglm()`
- - "speedlm" from `speedglm::speedlm()`
- - "survreg" from `survival::survreg()`
- - "svm" from `e1071::svm()`
- - "svyglm" from `survey::svyglm()`
- - "tobit" from `AER::tobit()`
- - "train" from `caret::train()`
- - "truncreg" from `truncreg::truncreg()`
- - "zeroinfl" from `pscl::zeroinfl()`
-
-## Requirements and Installation
-
-[](https://cran.r-project.org/package=prediction)
-
-[](https://travis-ci.org/leeper/prediction)
-[](https://ci.appveyor.com/project/leeper/prediction/branch/master)
-[](https://codecov.io/github/leeper/prediction?branch=master)
-[](http://www.repostatus.org/#active)
-
-The development version of this package can be installed directly from GitHub using `remotes`:
-
-``` r
-if (!require("remotes")) {
- install.packages("remotes")
-}
-remotes::install_github("leeper/prediction")
-```
+---
+title: "Tidy, Type-Safe 'prediction()' Methods"
+output: github_document
+---
+
+<img src="man/figures/logo.png" align="right" />
+
+The **prediction** and **margins** packages are a combined effort to port the functionality of Stata's (closed source) [`margins`](http://www.stata.com/help.cgi?margins) command to (open source) R. **prediction** is focused on one function - `prediction()` - that provides type-safe methods for generating predictions from fitted regression models. `prediction()` is an S3 generic, which always return a `"data.frame"` class object rather than the mix of vectors, lists, etc. that are returned by the `predict()` methods for various model types. It provides a key piece of underlying infrastructure for the **margins** package. Users interested in generating marginal (partial) effects, like those generated by Stata's `margins, dydx(*)` command, should consider using `margins()` from the sibling project, [**margins**](https://cran.r-project.org/package=margins).
+
+In addition to `prediction()`, this package provides a number of utility functions for generating useful predictions:
+
+ - `find_data()`, an S3 generic with methods that find the data frame used to estimate a regression model. This is a wrapper around `get_all_vars()` that attempts to locate data as well as modify it according to `subset` and `na.action` arguments used in the original modelling call.
+ - `mean_or_mode()` and `median_or_mode()`, which provide a convenient way to compute the data needed for predicted values *at means* (or *at medians*), respecting the differences between factor and numeric variables.
+ - `seq_range()`, which generates a vector of *n* values based upon the range of values in a variable
+ - `build_datalist()`, which generates a list of data frames from an input data frame and a specified set of replacement `at` values (mimicking the `atlist` option of Stata's `margins` command)
+
+## Simple code examples
+
+
+
+A major downside of the `predict()` methods for common modelling classes is that the result is not type-safe. Consider the following simple example:
+
+
+```r
+library("stats")
+library("datasets")
+x <- lm(mpg ~ cyl * hp + wt, data = mtcars)
+class(predict(x))
+```
+
+```
+## [1] "numeric"
+```
+
+```r
+class(predict(x, se.fit = TRUE))
+```
+
+```
+## [1] "list"
+```
+
+**prediction** solves this issue by providing a wrapper around `predict()`, called `prediction()`, that always returns a tidy data frame with a very simple `print()` method:
+
+
+```r
+library("prediction")
+(p <- prediction(x))
+```
+
+```
+## Data frame with 32 predictions from
+## lm(formula = mpg ~ cyl * hp + wt, data = mtcars)
+## with average prediction: 20.0906
+```
+
+```r
+class(p)
+```
+
+```
+## [1] "prediction" "data.frame"
+```
+
+```r
+head(p)
+```
+
+```
+## mpg cyl disp hp drat wt qsec vs am gear carb fitted se.fitted
+## 1 21.0 6 160 110 3.90 2.620 16.46 0 1 4 4 21.90488 0.6927034
+## 2 21.0 6 160 110 3.90 2.875 17.02 0 1 4 4 21.10933 0.6266557
+## 3 22.8 4 108 93 3.85 2.320 18.61 1 1 4 1 25.64753 0.6652076
+## 4 21.4 6 258 110 3.08 3.215 19.44 1 0 3 1 20.04859 0.6041400
+## 5 18.7 8 360 175 3.15 3.440 17.02 0 0 3 2 17.25445 0.7436172
+## 6 18.1 6 225 105 2.76 3.460 20.22 1 0 3 1 19.53360 0.6436862
+```
+
+The output always contains the original data (i.e., either data found using the `find_data()` function or passed to the `data` argument to `prediction()`). This makes it much simpler to pass predictions to, e.g., further summary or plotting functions.
+
+Additionally the vast majority of methods allow the passing of an `at` argument, which can be used to obtain predicted values using modified version of `data` held to specific values:
+
+
+```r
+prediction(x, at = list(hp = seq_range(mtcars$hp, 5)))
+```
+
+```
+## Data frame with 160 predictions from
+## lm(formula = mpg ~ cyl * hp + wt, data = mtcars)
+## with average predictions:
+```
+
+```
+## hp x
+## 52.0 22.605
+## 122.8 19.328
+## 193.5 16.051
+## 264.2 12.774
+## 335.0 9.497
+```
+
+This more or less serves as a direct R port of (the subset of functionality of) Stata's `margins` command that calculates predictive marginal means, etc. For calculation of marginal or partial effects, see the [**margins**](https://cran.r-project.org/package=margins) package.
+
+## Supported model classes
+
+The currently supported model classes are:
+
+ - "lm" from `stats::lm()`
+ - "glm" from `stats::glm()`, `MASS::glm.nb()`, `glmx::glmx()`, `glmx::hetglm()`, `brglm::brglm()`
+ - "ar" from `stats::ar()`
+ - "Arima" from `stats::arima()`
+ - "arima0" from `stats::arima0()`
+ - "biglm" from `biglm::biglm()` (including `"ffdf"` backed models)
+ - "betareg" from `betareg::betareg()`
+ - "bruto" from `mda::bruto()`
+ - "clm" from `ordinal::clm()`
+ - "coxph" from `survival::coxph()`
+ - "crch" from `crch::crch()`
+ - "earth" from `earth::earth()`
+ - "fda" from `mda::fda()`
+ - "Gam" from `gam::gam()`
+ - "gausspr" from `kernlab::gausspr()`
+ - "gee" from `gee::gee()`
+ - "glimML" from `aod::betabin()`, `aod::negbin()`
+ - "glimQL" from `aod::quasibin()`, `aod::quasipois()`
+ - "glmnet" from `glmnet::glmnet()`
+ - "gls" from `nlme::gls()`
+ - "hurdle" from `pscl::hurdle()`
+ - "hxlr" from `crch::hxlr()`
+ - "ivreg" from `AER::ivreg()`
+ - "knnreg" from `caret::knnreg()`
+ - "kqr" from `kernlab::kqr()`
+ - "ksvm" from `kernlab::ksvm()`
+ - "lda" from `MASS:lda()`
+ - "lme" from `nlme::lme()`
+ - "loess" from `stats::loess()`
+ - "lqs" from `MASS::lqs()`
+ - "mars" from `mda::mars()`
+ - "mca" from `MASS::mca()`
+ - "mclogit" from `mclogit::mclogit()`
+ - "mda" from `mda::mda()`
+ - "merMod" from `lme4::lmer()` and `lme4::glmer()`
+ - "mnlogit" from `mnlogit::mnlogit()`
+ - "mnp" from `MNP::mnp()`
+ - "naiveBayes" from `e1071::naiveBayes()`
+ - "nlme" from `nlme::nlme()`
+ - "nls" from `stats::nls()`
+ - "nnet" from `nnet::nnet()`, `nnet::multinom()`
+ - "plm" from `plm::plm()`
+ - "polr" from `MASS::polr()`
+ - "ppr" from `stats::ppr()`
+ - "princomp" from `stats::princomp()`
+ - "qda" from `MASS:qda()`
+ - "rlm" from `MASS::rlm()`
+ - "rpart" from `rpart::rpart()`
+ - "rq" from `quantreg::rq()`
+ - "selection" from `sampleSelection::selection()`
+ - "speedglm" from `speedglm::speedglm()`
+ - "speedlm" from `speedglm::speedlm()`
+ - "survreg" from `survival::survreg()`
+ - "svm" from `e1071::svm()`
+ - "svyglm" from `survey::svyglm()`
+ - "tobit" from `AER::tobit()`
+ - "train" from `caret::train()`
+ - "truncreg" from `truncreg::truncreg()`
+ - "zeroinfl" from `pscl::zeroinfl()`
+
+## Requirements and Installation
+
+[](https://cran.r-project.org/package=prediction)
+
+[](https://travis-ci.org/leeper/prediction)
+[](https://ci.appveyor.com/project/leeper/prediction/branch/master)
+[](https://codecov.io/github/leeper/prediction?branch=master)
+[](http://www.repostatus.org/#active)
+
+The development version of this package can be installed directly from GitHub using `remotes`:
+
+``` r
+if (!require("remotes")) {
+ install.packages("remotes")
+}
+remotes::install_github("leeper/prediction")
+```
diff --git a/debian/changelog b/debian/changelog
index 0fcc1a9..386f1a6 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,3 +1,9 @@
+r-cran-prediction (0.3.14+git20191224.1.c239565-1) UNRELEASED; urgency=low
+
+ * New upstream snapshot.
+
+ -- Debian Janitor <janitor@jelmer.uk> Fri, 20 Jan 2023 01:23:27 -0000
+
r-cran-prediction (0.3.14-2) unstable; urgency=medium
* Standards-Version: 4.5.0 (routine-update)
diff --git a/inst/CITATION b/inst/CITATION
index 7b98a82..a2dfe3d 100644
--- a/inst/CITATION
+++ b/inst/CITATION
@@ -1,15 +1,15 @@
-citHeader("To cite package 'prediction' in publications use:")
-
- year <- sub(".*(2[[:digit:]]{3})-.*", "\\1", meta$Date, perl = TRUE)
- vers <- paste("R package version", meta$Version)
-
- citEntry(entry="Manual",
- title = "prediction: Tidy, Type-Safe 'prediction()' Methods",
- author = personList(as.person("Thomas J. Leeper")),
- year = year,
- note = vers,
- textVersion =
- paste("Thomas J. Leeper (",
- year,
- "). prediction: Tidy, Type-Safe 'prediction()' Methods. ",
+citHeader("To cite package 'prediction' in publications use:")
+
+ year <- sub(".*(2[[:digit:]]{3})-.*", "\\1", meta$Date, perl = TRUE)
+ vers <- paste("R package version", meta$Version)
+
+ citEntry(entry="Manual",
+ title = "prediction: Tidy, Type-Safe 'prediction()' Methods",
+ author = personList(as.person("Thomas J. Leeper")),
+ year = year,
+ note = vers,
+ textVersion =
+ paste("Thomas J. Leeper (",
+ year,
+ "). prediction: Tidy, Type-Safe 'prediction()' Methods. ",
vers, ".", sep=""))
\ No newline at end of file
diff --git a/man/build_datalist.Rd b/man/build_datalist.Rd
index 028ed7b..202cab3 100644
--- a/man/build_datalist.Rd
+++ b/man/build_datalist.Rd
@@ -1,41 +1,41 @@
-% Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/build_datalist.R
-\name{build_datalist}
-\alias{build_datalist}
-\title{Build list of data.frames}
-\usage{
-build_datalist(data, at = NULL, as.data.frame = FALSE, ...)
-}
-\arguments{
-\item{data}{A data.frame containing the original data.}
-
-\item{at}{A list of one or more named vectors of values, which will be used to specify values of variables in \code{data}. All possible combinations are generated. Alternatively, this can be a data frame of combination levels if only a subset of combinations are desired. See examples.}
-
-\item{as.data.frame}{A logical indicating whether to return a single stacked data frame rather than a list of data frames}
-
-\item{\dots}{Ignored.}
-}
-\value{
-A list of data.frames, unless \code{as.data.frame = TRUE} in which case a single, stacked data frame is returned.
-}
-\description{
-Construct a list of data.frames based upon an input data.frame and a list of one or more \code{at} values
-}
-\examples{
-# basic examples
-require("datasets")
-build_datalist(head(mtcars), at = list(cyl = c(4, 6)))
-
-str(build_datalist(head(mtcars), at = list(cyl = c(4,6), wt = c(2.75,3,3.25))), 1)
-
-str(build_datalist(head(mtcars), at = data.frame(cyl = c(4,4), wt = c(2.75,3))))
-
-}
-\seealso{
-\code{\link{find_data}}, \code{\link{mean_or_mode}}, \code{\link{seq_range}}
-}
-\author{
-Thomas J. Leeper
-}
-\keyword{data}
-\keyword{manip}
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/build_datalist.R
+\name{build_datalist}
+\alias{build_datalist}
+\title{Build list of data.frames}
+\usage{
+build_datalist(data, at = NULL, as.data.frame = FALSE, ...)
+}
+\arguments{
+\item{data}{A data.frame containing the original data.}
+
+\item{at}{A list of one or more named vectors of values, which will be used to specify values of variables in \code{data}. All possible combinations are generated. Alternatively, this can be a data frame of combination levels if only a subset of combinations are desired. See examples.}
+
+\item{as.data.frame}{A logical indicating whether to return a single stacked data frame rather than a list of data frames}
+
+\item{\dots}{Ignored.}
+}
+\value{
+A list of data.frames, unless \code{as.data.frame = TRUE} in which case a single, stacked data frame is returned.
+}
+\description{
+Construct a list of data.frames based upon an input data.frame and a list of one or more \code{at} values
+}
+\examples{
+# basic examples
+require("datasets")
+build_datalist(head(mtcars), at = list(cyl = c(4, 6)))
+
+str(build_datalist(head(mtcars), at = list(cyl = c(4,6), wt = c(2.75,3,3.25))), 1)
+
+str(build_datalist(head(mtcars), at = data.frame(cyl = c(4,4), wt = c(2.75,3))))
+
+}
+\seealso{
+\code{\link{find_data}}, \code{\link{mean_or_mode}}, \code{\link{seq_range}}
+}
+\author{
+Thomas J. Leeper
+}
+\keyword{data}
+\keyword{manip}
diff --git a/man/figures/logo.svg b/man/figures/logo.svg
index a1a83f5..6326c41 100644
--- a/man/figures/logo.svg
+++ b/man/figures/logo.svg
@@ -1,572 +1,572 @@
-<?xml version="1.0" encoding="UTF-8" standalone="no"?>
-<!-- Created with Inkscape (http://www.inkscape.org/) -->
-
-<svg
- xmlns:dc="http://purl.org/dc/elements/1.1/"
- xmlns:cc="http://creativecommons.org/ns#"
- xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#"
- xmlns:svg="http://www.w3.org/2000/svg"
- xmlns="http://www.w3.org/2000/svg"
- xmlns:sodipodi="http://sodipodi.sourceforge.net/DTD/sodipodi-0.dtd"
- xmlns:inkscape="http://www.inkscape.org/namespaces/inkscape"
- id="svg3336"
- version="1.1"
- inkscape:version="0.91 r13725"
- width="219.375"
- height="253.125"
- viewBox="0 0 219.375 253.125"
- sodipodi:docname="logo.svg"
- inkscape:export-filename="C:\Users\THOMAS\Dropbox\Software\prediction\man\figures\logo.png"
- inkscape:export-xdpi="60.490585"
- inkscape:export-ydpi="60.490585">
- <metadata
- id="metadata3342">
- <rdf:RDF>
- <cc:Work
- rdf:about="">
- <dc:format>image/svg+xml</dc:format>
- <dc:type
- rdf:resource="http://purl.org/dc/dcmitype/StillImage" />
- <dc:title />
- </cc:Work>
- </rdf:RDF>
- </metadata>
- <defs
- id="defs3340" />
- <sodipodi:namedview
- pagecolor="#ffffff"
- bordercolor="#666666"
- borderopacity="1"
- objecttolerance="10"
- gridtolerance="10"
- guidetolerance="10"
- inkscape:pageopacity="0"
- inkscape:pageshadow="2"
- inkscape:window-width="1304"
- inkscape:window-height="746"
- id="namedview3338"
- showgrid="false"
- inkscape:zoom="1.4142136"
- inkscape:cx="-139.07607"
- inkscape:cy="74.710669"
- inkscape:window-x="-8"
- inkscape:window-y="-8"
- inkscape:window-maximized="1"
- inkscape:current-layer="svg3336" />
- <path
- style="fill:#2380ee;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:2.5;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1;stroke-miterlimit:4;stroke-dasharray:none"
- d="m 0.5,64.625 109.5,-64.5 109.5,65 1,122 -111,66 L 0,187.625 Z"
- id="path3348"
- inkscape:connector-curvature="0"
- sodipodi:nodetypes="ccccccc" />
- <flowRoot
- xml:space="preserve"
- id="flowRoot4173"
- style="font-style:normal;font-weight:normal;font-size:22.5px;line-height:125%;font-family:sans-serif;letter-spacing:0px;word-spacing:0px;fill:#000000;fill-opacity:1;stroke:#c8c8c8;stroke-width:1px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1;"
- transform="matrix(0.99569019,0,0,1.4293743,-23.726523,-106.43577)"><flowRegion
- id="flowRegion4175"><rect
- id="rect4177"
- width="203.0627"
- height="36.446659"
- x="39"
- y="113.125"
- style="stroke:#c8c8c8;stroke-opacity:1;" /></flowRegion><flowPara
- id="flowPara4179"
- style="font-style:normal;font-variant:normal;font-weight:bold;font-stretch:normal;font-size:31.43374825px;font-family:sans-serif;-inkscape-font-specification:'sans-serif Bold';letter-spacing:1.25734997px;stroke:#c8c8c8;stroke-opacity:1;">prediction</flowPara></flowRoot> <flowRoot
- xml:space="preserve"
- id="flowRoot4173-4"
- style="font-style:normal;font-weight:normal;font-size:22.5px;line-height:125%;font-family:sans-serif;letter-spacing:0px;word-spacing:0px;fill:#000000;fill-opacity:1;stroke:#c8c8c8;stroke-width:1px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1;"
- transform="matrix(0.99569019,0,0,1.4293743,-25.76908,-115.96209)"><flowRegion
- id="flowRegion4175-5"><rect
- id="rect4177-2"
- width="203.0627"
- height="36.446659"
- x="39"
- y="113.125"
- style="stroke:#c8c8c8;stroke-opacity:1;" /></flowRegion><flowPara
- id="flowPara4179-5"
- style="font-style:normal;font-variant:normal;font-weight:bold;font-stretch:normal;font-size:31.43374825px;font-family:sans-serif;-inkscape-font-specification:'sans-serif Bold';letter-spacing:1.25734997px;stroke:#c8c8c8;stroke-opacity:1;">^</flowPara></flowRoot> <g
- id="g4608"
- transform="translate(-4,0)"
- style="fill:#c8c8c8;fill-opacity:1">
- <g
- id="g4271"
- style="fill:#c8c8c8;fill-opacity:1">
- <rect
- style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
- id="rect4172-0-5"
- width="15"
- height="15"
- x="24.5"
- y="144.125" />
- <rect
- style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
- id="rect4172"
- width="15"
- height="15"
- x="24.5"
- y="114.625" />
- <rect
- style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
- id="rect4172-0"
- width="15"
- height="15"
- x="24.5"
- y="129.625" />
- <rect
- style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
- id="rect4172-0-5-8"
- width="15"
- height="15"
- x="24.5"
- y="159.125" />
- <rect
- style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
- id="rect4172-0-5-8-5"
- width="15"
- height="15"
- x="24.5"
- y="174.125" />
- </g>
- <g
- id="g4271-3"
- transform="translate(14.881282,-0.01516505)"
- style="fill:#c8c8c8;fill-opacity:1">
- <rect
- style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
- id="rect4172-0-5-1"
- width="15"
- height="15"
- x="24.5"
- y="144.125" />
- <rect
- style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
- id="rect4172-5"
- width="15"
- height="15"
- x="24.5"
- y="114.625" />
- <rect
- style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
- id="rect4172-0-3"
- width="15"
- height="15"
- x="24.5"
- y="129.625" />
- <rect
- style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
- id="rect4172-0-5-8-6"
- width="15"
- height="15"
- x="24.5"
- y="159.125" />
- <rect
- style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
- id="rect4172-0-5-8-5-8"
- width="15"
- height="15"
- x="24.5"
- y="174.125" />
- </g>
- <g
- id="g4271-3-5"
- transform="translate(29.871844,-0.04304649)"
- style="fill:#c8c8c8;fill-opacity:1">
- <rect
- style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
- id="rect4172-0-5-1-0"
- width="15"
- height="15"
- x="24.5"
- y="144.125" />
- <rect
- style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
- id="rect4172-5-5"
- width="15"
- height="15"
- x="24.5"
- y="114.625" />
- <rect
- style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
- id="rect4172-0-3-5"
- width="15"
- height="15"
- x="24.5"
- y="129.625" />
- <rect
- style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
- id="rect4172-0-5-8-6-3"
- width="15"
- height="15"
- x="24.5"
- y="159.125" />
- <rect
- style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
- id="rect4172-0-5-8-5-8-6"
- width="15"
- height="15"
- x="24.5"
- y="174.125" />
- </g>
- <g
- id="g4271-3-5-6"
- transform="translate(44.765279,-0.04304588)"
- style="fill:#c8c8c8;fill-opacity:1">
- <rect
- style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
- id="rect4172-0-5-1-0-8"
- width="15"
- height="15"
- x="24.5"
- y="144.125" />
- <rect
- style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
- id="rect4172-5-5-9"
- width="15"
- height="15"
- x="24.5"
- y="114.625" />
- <rect
- style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
- id="rect4172-0-3-5-8"
- width="15"
- height="15"
- x="24.5"
- y="129.625" />
- <rect
- style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
- id="rect4172-0-5-8-6-3-9"
- width="15"
- height="15"
- x="24.5"
- y="159.125" />
- <rect
- style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
- id="rect4172-0-5-8-5-8-6-0"
- width="15"
- height="15"
- x="24.5"
- y="174.125" />
- </g>
- <g
- id="g4271-3-5-6-9"
- transform="translate(59.75,0)"
- style="fill:#c8c8c8;fill-opacity:1">
- <rect
- style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
- id="rect4172-0-5-1-0-8-6"
- width="15"
- height="15"
- x="24.5"
- y="144.125" />
- <rect
- style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
- id="rect4172-5-5-9-9"
- width="15"
- height="15"
- x="24.5"
- y="114.625" />
- <rect
- style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
- id="rect4172-0-3-5-8-9"
- width="15"
- height="15"
- x="24.5"
- y="129.625" />
- <rect
- style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
- id="rect4172-0-5-8-6-3-9-6"
- width="15"
- height="15"
- x="24.5"
- y="159.125" />
- <rect
- style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
- id="rect4172-0-5-8-5-8-6-0-2"
- width="15"
- height="15"
- x="24.5"
- y="174.125" />
- </g>
- <g
- id="g4271-3-5-6-9-9"
- transform="translate(74.790803,-0.00334599)"
- style="fill:#c8c8c8;fill-opacity:1">
- <rect
- style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
- id="rect4172-0-5-1-0-8-6-8"
- width="15"
- height="15"
- x="24.5"
- y="144.125" />
- <rect
- style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
- id="rect4172-5-5-9-9-8"
- width="15"
- height="15"
- x="24.5"
- y="114.625" />
- <rect
- style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
- id="rect4172-0-3-5-8-9-4"
- width="15"
- height="15"
- x="24.5"
- y="129.625" />
- <rect
- style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
- id="rect4172-0-5-8-6-3-9-6-2"
- width="15"
- height="15"
- x="24.5"
- y="159.125" />
- <rect
- style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
- id="rect4172-0-5-8-5-8-6-0-2-2"
- width="15"
- height="15"
- x="24.5"
- y="174.125" />
- </g>
- <g
- id="g4271-3-5-6-9-9-2"
- transform="translate(89.8125,0)"
- style="fill:#c8c8c8;fill-opacity:1">
- <rect
- style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
- id="rect4172-0-5-1-0-8-6-8-8"
- width="15"
- height="15"
- x="24.5"
- y="144.125" />
- <rect
- style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
- id="rect4172-5-5-9-9-8-3"
- width="15"
- height="15"
- x="24.5"
- y="114.625" />
- <rect
- style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
- id="rect4172-0-3-5-8-9-4-2"
- width="15"
- height="15"
- x="24.5"
- y="129.625" />
- <rect
- style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
- id="rect4172-0-5-8-6-3-9-6-2-7"
- width="15"
- height="15"
- x="24.5"
- y="159.125" />
- <rect
- style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
- id="rect4172-0-5-8-5-8-6-0-2-2-6"
- width="15"
- height="15"
- x="24.5"
- y="174.125" />
- </g>
- <g
- id="g4271-3-5-6-9-9-2-0"
- transform="translate(104.875,-1.0395729e-7)"
- style="fill:#c8c8c8;fill-opacity:1">
- <rect
- style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
- id="rect4172-0-5-1-0-8-6-8-8-6"
- width="15"
- height="15"
- x="24.5"
- y="144.125" />
- <rect
- style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
- id="rect4172-5-5-9-9-8-3-2"
- width="15"
- height="15"
- x="24.5"
- y="114.625" />
- <rect
- style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
- id="rect4172-0-3-5-8-9-4-2-7"
- width="15"
- height="15"
- x="24.5"
- y="129.625" />
- <rect
- style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
- id="rect4172-0-5-8-6-3-9-6-2-7-6"
- width="15"
- height="15"
- x="24.5"
- y="159.125" />
- <rect
- style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
- id="rect4172-0-5-8-5-8-6-0-2-2-6-5"
- width="15"
- height="15"
- x="24.5"
- y="174.125" />
- </g>
- <g
- id="g4271-3-5-6-9-9-2-0-8"
- transform="translate(120,0)"
- style="fill:#c8c8c8;fill-opacity:1">
- <rect
- style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
- id="rect4172-0-5-1-0-8-6-8-8-6-5"
- width="15"
- height="15"
- x="24.5"
- y="144.125" />
- <rect
- style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
- id="rect4172-5-5-9-9-8-3-2-8"
- width="15"
- height="15"
- x="24.5"
- y="114.625" />
- <rect
- style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
- id="rect4172-0-3-5-8-9-4-2-7-9"
- width="15"
- height="15"
- x="24.5"
- y="129.625" />
- <rect
- style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
- id="rect4172-0-5-8-6-3-9-6-2-7-6-4"
- width="15"
- height="15"
- x="24.5"
- y="159.125" />
- <rect
- style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
- id="rect4172-0-5-8-5-8-6-0-2-2-6-5-5"
- width="15"
- height="15"
- x="24.5"
- y="174.125" />
- </g>
- <g
- id="g4271-3-5-6-9-9-2-0-8-8"
- transform="translate(135,0)"
- style="fill:#c8c8c8;fill-opacity:1">
- <rect
- style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
- id="rect4172-0-5-1-0-8-6-8-8-6-5-0"
- width="15"
- height="15"
- x="24.5"
- y="144.125" />
- <rect
- style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
- id="rect4172-5-5-9-9-8-3-2-8-0"
- width="15"
- height="15"
- x="24.5"
- y="114.625" />
- <rect
- style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
- id="rect4172-0-3-5-8-9-4-2-7-9-5"
- width="15"
- height="15"
- x="24.5"
- y="129.625" />
- <rect
- style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
- id="rect4172-0-5-8-6-3-9-6-2-7-6-4-2"
- width="15"
- height="15"
- x="24.5"
- y="159.125" />
- <rect
- style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
- id="rect4172-0-5-8-5-8-6-0-2-2-6-5-5-3"
- width="15"
- height="15"
- x="24.5"
- y="174.125" />
- </g>
- <g
- id="g4271-3-5-6-9-9-2-0-8-8-8"
- transform="translate(150,1.2663293e-8)"
- style="fill:#c8c8c8;fill-opacity:1">
- <rect
- style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
- id="rect4172-0-5-1-0-8-6-8-8-6-5-0-9"
- width="15"
- height="15"
- x="24.5"
- y="144.125" />
- <rect
- style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
- id="rect4172-5-5-9-9-8-3-2-8-0-8"
- width="15"
- height="15"
- x="24.5"
- y="114.625" />
- <rect
- style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
- id="rect4172-0-3-5-8-9-4-2-7-9-5-2"
- width="15"
- height="15"
- x="24.5"
- y="129.625" />
- <rect
- style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
- id="rect4172-0-5-8-6-3-9-6-2-7-6-4-2-5"
- width="15"
- height="15"
- x="24.5"
- y="159.125" />
- <rect
- style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
- id="rect4172-0-5-8-5-8-6-0-2-2-6-5-5-3-4"
- width="15"
- height="15"
- x="24.5"
- y="174.125" />
- </g>
- <g
- id="g4271-3-5-6-9-9-2-0-8-8-8-7"
- transform="translate(165,0)"
- style="fill:#c8c8c8;fill-opacity:1">
- <rect
- style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
- id="rect4172-0-5-1-0-8-6-8-8-6-5-0-9-5"
- width="15"
- height="15"
- x="24.5"
- y="144.125" />
- <rect
- style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
- id="rect4172-5-5-9-9-8-3-2-8-0-8-3"
- width="15"
- height="15"
- x="24.5"
- y="114.625" />
- <rect
- style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
- id="rect4172-0-3-5-8-9-4-2-7-9-5-2-2"
- width="15"
- height="15"
- x="24.5"
- y="129.625" />
- <rect
- style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
- id="rect4172-0-5-8-6-3-9-6-2-7-6-4-2-5-8"
- width="15"
- height="15"
- x="24.5"
- y="159.125" />
- <rect
- style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
- id="rect4172-0-5-8-5-8-6-0-2-2-6-5-5-3-4-6"
- width="15"
- height="15"
- x="24.5"
- y="174.125" />
- </g>
- </g>
-</svg>
+<?xml version="1.0" encoding="UTF-8" standalone="no"?>
+<!-- Created with Inkscape (http://www.inkscape.org/) -->
+
+<svg
+ xmlns:dc="http://purl.org/dc/elements/1.1/"
+ xmlns:cc="http://creativecommons.org/ns#"
+ xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#"
+ xmlns:svg="http://www.w3.org/2000/svg"
+ xmlns="http://www.w3.org/2000/svg"
+ xmlns:sodipodi="http://sodipodi.sourceforge.net/DTD/sodipodi-0.dtd"
+ xmlns:inkscape="http://www.inkscape.org/namespaces/inkscape"
+ id="svg3336"
+ version="1.1"
+ inkscape:version="0.91 r13725"
+ width="219.375"
+ height="253.125"
+ viewBox="0 0 219.375 253.125"
+ sodipodi:docname="logo.svg"
+ inkscape:export-filename="C:\Users\THOMAS\Dropbox\Software\prediction\man\figures\logo.png"
+ inkscape:export-xdpi="60.490585"
+ inkscape:export-ydpi="60.490585">
+ <metadata
+ id="metadata3342">
+ <rdf:RDF>
+ <cc:Work
+ rdf:about="">
+ <dc:format>image/svg+xml</dc:format>
+ <dc:type
+ rdf:resource="http://purl.org/dc/dcmitype/StillImage" />
+ <dc:title />
+ </cc:Work>
+ </rdf:RDF>
+ </metadata>
+ <defs
+ id="defs3340" />
+ <sodipodi:namedview
+ pagecolor="#ffffff"
+ bordercolor="#666666"
+ borderopacity="1"
+ objecttolerance="10"
+ gridtolerance="10"
+ guidetolerance="10"
+ inkscape:pageopacity="0"
+ inkscape:pageshadow="2"
+ inkscape:window-width="1304"
+ inkscape:window-height="746"
+ id="namedview3338"
+ showgrid="false"
+ inkscape:zoom="1.4142136"
+ inkscape:cx="-139.07607"
+ inkscape:cy="74.710669"
+ inkscape:window-x="-8"
+ inkscape:window-y="-8"
+ inkscape:window-maximized="1"
+ inkscape:current-layer="svg3336" />
+ <path
+ style="fill:#2380ee;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:2.5;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1;stroke-miterlimit:4;stroke-dasharray:none"
+ d="m 0.5,64.625 109.5,-64.5 109.5,65 1,122 -111,66 L 0,187.625 Z"
+ id="path3348"
+ inkscape:connector-curvature="0"
+ sodipodi:nodetypes="ccccccc" />
+ <flowRoot
+ xml:space="preserve"
+ id="flowRoot4173"
+ style="font-style:normal;font-weight:normal;font-size:22.5px;line-height:125%;font-family:sans-serif;letter-spacing:0px;word-spacing:0px;fill:#000000;fill-opacity:1;stroke:#c8c8c8;stroke-width:1px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1;"
+ transform="matrix(0.99569019,0,0,1.4293743,-23.726523,-106.43577)"><flowRegion
+ id="flowRegion4175"><rect
+ id="rect4177"
+ width="203.0627"
+ height="36.446659"
+ x="39"
+ y="113.125"
+ style="stroke:#c8c8c8;stroke-opacity:1;" /></flowRegion><flowPara
+ id="flowPara4179"
+ style="font-style:normal;font-variant:normal;font-weight:bold;font-stretch:normal;font-size:31.43374825px;font-family:sans-serif;-inkscape-font-specification:'sans-serif Bold';letter-spacing:1.25734997px;stroke:#c8c8c8;stroke-opacity:1;">prediction</flowPara></flowRoot> <flowRoot
+ xml:space="preserve"
+ id="flowRoot4173-4"
+ style="font-style:normal;font-weight:normal;font-size:22.5px;line-height:125%;font-family:sans-serif;letter-spacing:0px;word-spacing:0px;fill:#000000;fill-opacity:1;stroke:#c8c8c8;stroke-width:1px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1;"
+ transform="matrix(0.99569019,0,0,1.4293743,-25.76908,-115.96209)"><flowRegion
+ id="flowRegion4175-5"><rect
+ id="rect4177-2"
+ width="203.0627"
+ height="36.446659"
+ x="39"
+ y="113.125"
+ style="stroke:#c8c8c8;stroke-opacity:1;" /></flowRegion><flowPara
+ id="flowPara4179-5"
+ style="font-style:normal;font-variant:normal;font-weight:bold;font-stretch:normal;font-size:31.43374825px;font-family:sans-serif;-inkscape-font-specification:'sans-serif Bold';letter-spacing:1.25734997px;stroke:#c8c8c8;stroke-opacity:1;">^</flowPara></flowRoot> <g
+ id="g4608"
+ transform="translate(-4,0)"
+ style="fill:#c8c8c8;fill-opacity:1">
+ <g
+ id="g4271"
+ style="fill:#c8c8c8;fill-opacity:1">
+ <rect
+ style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
+ id="rect4172-0-5"
+ width="15"
+ height="15"
+ x="24.5"
+ y="144.125" />
+ <rect
+ style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
+ id="rect4172"
+ width="15"
+ height="15"
+ x="24.5"
+ y="114.625" />
+ <rect
+ style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
+ id="rect4172-0"
+ width="15"
+ height="15"
+ x="24.5"
+ y="129.625" />
+ <rect
+ style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
+ id="rect4172-0-5-8"
+ width="15"
+ height="15"
+ x="24.5"
+ y="159.125" />
+ <rect
+ style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
+ id="rect4172-0-5-8-5"
+ width="15"
+ height="15"
+ x="24.5"
+ y="174.125" />
+ </g>
+ <g
+ id="g4271-3"
+ transform="translate(14.881282,-0.01516505)"
+ style="fill:#c8c8c8;fill-opacity:1">
+ <rect
+ style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
+ id="rect4172-0-5-1"
+ width="15"
+ height="15"
+ x="24.5"
+ y="144.125" />
+ <rect
+ style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
+ id="rect4172-5"
+ width="15"
+ height="15"
+ x="24.5"
+ y="114.625" />
+ <rect
+ style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
+ id="rect4172-0-3"
+ width="15"
+ height="15"
+ x="24.5"
+ y="129.625" />
+ <rect
+ style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
+ id="rect4172-0-5-8-6"
+ width="15"
+ height="15"
+ x="24.5"
+ y="159.125" />
+ <rect
+ style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
+ id="rect4172-0-5-8-5-8"
+ width="15"
+ height="15"
+ x="24.5"
+ y="174.125" />
+ </g>
+ <g
+ id="g4271-3-5"
+ transform="translate(29.871844,-0.04304649)"
+ style="fill:#c8c8c8;fill-opacity:1">
+ <rect
+ style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
+ id="rect4172-0-5-1-0"
+ width="15"
+ height="15"
+ x="24.5"
+ y="144.125" />
+ <rect
+ style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
+ id="rect4172-5-5"
+ width="15"
+ height="15"
+ x="24.5"
+ y="114.625" />
+ <rect
+ style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
+ id="rect4172-0-3-5"
+ width="15"
+ height="15"
+ x="24.5"
+ y="129.625" />
+ <rect
+ style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
+ id="rect4172-0-5-8-6-3"
+ width="15"
+ height="15"
+ x="24.5"
+ y="159.125" />
+ <rect
+ style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
+ id="rect4172-0-5-8-5-8-6"
+ width="15"
+ height="15"
+ x="24.5"
+ y="174.125" />
+ </g>
+ <g
+ id="g4271-3-5-6"
+ transform="translate(44.765279,-0.04304588)"
+ style="fill:#c8c8c8;fill-opacity:1">
+ <rect
+ style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
+ id="rect4172-0-5-1-0-8"
+ width="15"
+ height="15"
+ x="24.5"
+ y="144.125" />
+ <rect
+ style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
+ id="rect4172-5-5-9"
+ width="15"
+ height="15"
+ x="24.5"
+ y="114.625" />
+ <rect
+ style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
+ id="rect4172-0-3-5-8"
+ width="15"
+ height="15"
+ x="24.5"
+ y="129.625" />
+ <rect
+ style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
+ id="rect4172-0-5-8-6-3-9"
+ width="15"
+ height="15"
+ x="24.5"
+ y="159.125" />
+ <rect
+ style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
+ id="rect4172-0-5-8-5-8-6-0"
+ width="15"
+ height="15"
+ x="24.5"
+ y="174.125" />
+ </g>
+ <g
+ id="g4271-3-5-6-9"
+ transform="translate(59.75,0)"
+ style="fill:#c8c8c8;fill-opacity:1">
+ <rect
+ style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
+ id="rect4172-0-5-1-0-8-6"
+ width="15"
+ height="15"
+ x="24.5"
+ y="144.125" />
+ <rect
+ style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
+ id="rect4172-5-5-9-9"
+ width="15"
+ height="15"
+ x="24.5"
+ y="114.625" />
+ <rect
+ style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
+ id="rect4172-0-3-5-8-9"
+ width="15"
+ height="15"
+ x="24.5"
+ y="129.625" />
+ <rect
+ style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
+ id="rect4172-0-5-8-6-3-9-6"
+ width="15"
+ height="15"
+ x="24.5"
+ y="159.125" />
+ <rect
+ style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
+ id="rect4172-0-5-8-5-8-6-0-2"
+ width="15"
+ height="15"
+ x="24.5"
+ y="174.125" />
+ </g>
+ <g
+ id="g4271-3-5-6-9-9"
+ transform="translate(74.790803,-0.00334599)"
+ style="fill:#c8c8c8;fill-opacity:1">
+ <rect
+ style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
+ id="rect4172-0-5-1-0-8-6-8"
+ width="15"
+ height="15"
+ x="24.5"
+ y="144.125" />
+ <rect
+ style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
+ id="rect4172-5-5-9-9-8"
+ width="15"
+ height="15"
+ x="24.5"
+ y="114.625" />
+ <rect
+ style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
+ id="rect4172-0-3-5-8-9-4"
+ width="15"
+ height="15"
+ x="24.5"
+ y="129.625" />
+ <rect
+ style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
+ id="rect4172-0-5-8-6-3-9-6-2"
+ width="15"
+ height="15"
+ x="24.5"
+ y="159.125" />
+ <rect
+ style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
+ id="rect4172-0-5-8-5-8-6-0-2-2"
+ width="15"
+ height="15"
+ x="24.5"
+ y="174.125" />
+ </g>
+ <g
+ id="g4271-3-5-6-9-9-2"
+ transform="translate(89.8125,0)"
+ style="fill:#c8c8c8;fill-opacity:1">
+ <rect
+ style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
+ id="rect4172-0-5-1-0-8-6-8-8"
+ width="15"
+ height="15"
+ x="24.5"
+ y="144.125" />
+ <rect
+ style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
+ id="rect4172-5-5-9-9-8-3"
+ width="15"
+ height="15"
+ x="24.5"
+ y="114.625" />
+ <rect
+ style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
+ id="rect4172-0-3-5-8-9-4-2"
+ width="15"
+ height="15"
+ x="24.5"
+ y="129.625" />
+ <rect
+ style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
+ id="rect4172-0-5-8-6-3-9-6-2-7"
+ width="15"
+ height="15"
+ x="24.5"
+ y="159.125" />
+ <rect
+ style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
+ id="rect4172-0-5-8-5-8-6-0-2-2-6"
+ width="15"
+ height="15"
+ x="24.5"
+ y="174.125" />
+ </g>
+ <g
+ id="g4271-3-5-6-9-9-2-0"
+ transform="translate(104.875,-1.0395729e-7)"
+ style="fill:#c8c8c8;fill-opacity:1">
+ <rect
+ style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
+ id="rect4172-0-5-1-0-8-6-8-8-6"
+ width="15"
+ height="15"
+ x="24.5"
+ y="144.125" />
+ <rect
+ style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
+ id="rect4172-5-5-9-9-8-3-2"
+ width="15"
+ height="15"
+ x="24.5"
+ y="114.625" />
+ <rect
+ style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
+ id="rect4172-0-3-5-8-9-4-2-7"
+ width="15"
+ height="15"
+ x="24.5"
+ y="129.625" />
+ <rect
+ style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
+ id="rect4172-0-5-8-6-3-9-6-2-7-6"
+ width="15"
+ height="15"
+ x="24.5"
+ y="159.125" />
+ <rect
+ style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
+ id="rect4172-0-5-8-5-8-6-0-2-2-6-5"
+ width="15"
+ height="15"
+ x="24.5"
+ y="174.125" />
+ </g>
+ <g
+ id="g4271-3-5-6-9-9-2-0-8"
+ transform="translate(120,0)"
+ style="fill:#c8c8c8;fill-opacity:1">
+ <rect
+ style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
+ id="rect4172-0-5-1-0-8-6-8-8-6-5"
+ width="15"
+ height="15"
+ x="24.5"
+ y="144.125" />
+ <rect
+ style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
+ id="rect4172-5-5-9-9-8-3-2-8"
+ width="15"
+ height="15"
+ x="24.5"
+ y="114.625" />
+ <rect
+ style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
+ id="rect4172-0-3-5-8-9-4-2-7-9"
+ width="15"
+ height="15"
+ x="24.5"
+ y="129.625" />
+ <rect
+ style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
+ id="rect4172-0-5-8-6-3-9-6-2-7-6-4"
+ width="15"
+ height="15"
+ x="24.5"
+ y="159.125" />
+ <rect
+ style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
+ id="rect4172-0-5-8-5-8-6-0-2-2-6-5-5"
+ width="15"
+ height="15"
+ x="24.5"
+ y="174.125" />
+ </g>
+ <g
+ id="g4271-3-5-6-9-9-2-0-8-8"
+ transform="translate(135,0)"
+ style="fill:#c8c8c8;fill-opacity:1">
+ <rect
+ style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
+ id="rect4172-0-5-1-0-8-6-8-8-6-5-0"
+ width="15"
+ height="15"
+ x="24.5"
+ y="144.125" />
+ <rect
+ style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
+ id="rect4172-5-5-9-9-8-3-2-8-0"
+ width="15"
+ height="15"
+ x="24.5"
+ y="114.625" />
+ <rect
+ style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
+ id="rect4172-0-3-5-8-9-4-2-7-9-5"
+ width="15"
+ height="15"
+ x="24.5"
+ y="129.625" />
+ <rect
+ style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
+ id="rect4172-0-5-8-6-3-9-6-2-7-6-4-2"
+ width="15"
+ height="15"
+ x="24.5"
+ y="159.125" />
+ <rect
+ style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
+ id="rect4172-0-5-8-5-8-6-0-2-2-6-5-5-3"
+ width="15"
+ height="15"
+ x="24.5"
+ y="174.125" />
+ </g>
+ <g
+ id="g4271-3-5-6-9-9-2-0-8-8-8"
+ transform="translate(150,1.2663293e-8)"
+ style="fill:#c8c8c8;fill-opacity:1">
+ <rect
+ style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
+ id="rect4172-0-5-1-0-8-6-8-8-6-5-0-9"
+ width="15"
+ height="15"
+ x="24.5"
+ y="144.125" />
+ <rect
+ style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
+ id="rect4172-5-5-9-9-8-3-2-8-0-8"
+ width="15"
+ height="15"
+ x="24.5"
+ y="114.625" />
+ <rect
+ style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
+ id="rect4172-0-3-5-8-9-4-2-7-9-5-2"
+ width="15"
+ height="15"
+ x="24.5"
+ y="129.625" />
+ <rect
+ style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
+ id="rect4172-0-5-8-6-3-9-6-2-7-6-4-2-5"
+ width="15"
+ height="15"
+ x="24.5"
+ y="159.125" />
+ <rect
+ style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
+ id="rect4172-0-5-8-5-8-6-0-2-2-6-5-5-3-4"
+ width="15"
+ height="15"
+ x="24.5"
+ y="174.125" />
+ </g>
+ <g
+ id="g4271-3-5-6-9-9-2-0-8-8-8-7"
+ transform="translate(165,0)"
+ style="fill:#c8c8c8;fill-opacity:1">
+ <rect
+ style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
+ id="rect4172-0-5-1-0-8-6-8-8-6-5-0-9-5"
+ width="15"
+ height="15"
+ x="24.5"
+ y="144.125" />
+ <rect
+ style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
+ id="rect4172-5-5-9-9-8-3-2-8-0-8-3"
+ width="15"
+ height="15"
+ x="24.5"
+ y="114.625" />
+ <rect
+ style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
+ id="rect4172-0-3-5-8-9-4-2-7-9-5-2-2"
+ width="15"
+ height="15"
+ x="24.5"
+ y="129.625" />
+ <rect
+ style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
+ id="rect4172-0-5-8-6-3-9-6-2-7-6-4-2-5-8"
+ width="15"
+ height="15"
+ x="24.5"
+ y="159.125" />
+ <rect
+ style="fill:#c8c8c8;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.80000001;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
+ id="rect4172-0-5-8-5-8-6-0-2-2-6-5-5-3-4-6"
+ width="15"
+ height="15"
+ x="24.5"
+ y="174.125" />
+ </g>
+ </g>
+</svg>
diff --git a/man/find_data.Rd b/man/find_data.Rd
index ccaae7f..c8315c0 100644
--- a/man/find_data.Rd
+++ b/man/find_data.Rd
@@ -1,72 +1,72 @@
-% Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/find_data.R
-\name{find_data}
-\alias{find_data}
-\alias{find_data.default}
-\alias{find_data.data.frame}
-\alias{find_data.crch}
-\alias{find_data.glimML}
-\alias{find_data.glm}
-\alias{find_data.hxlr}
-\alias{find_data.lm}
-\alias{find_data.mca}
-\alias{find_data.merMod}
-\alias{find_data.svyglm}
-\alias{find_data.train}
-\alias{find_data.vgam}
-\alias{find_data.vglm}
-\title{Extract data from a model object}
-\usage{
-find_data(model, ...)
-
-\method{find_data}{default}(model, env = parent.frame(), ...)
-
-\method{find_data}{data.frame}(model, ...)
-
-\method{find_data}{crch}(model, env = parent.frame(), ...)
-
-\method{find_data}{glimML}(model, ...)
-
-\method{find_data}{glm}(model, env = parent.frame(), ...)
-
-\method{find_data}{hxlr}(model, env = parent.frame(), ...)
-
-\method{find_data}{lm}(model, env = parent.frame(), ...)
-
-\method{find_data}{mca}(model, env = parent.frame(), ...)
-
-\method{find_data}{merMod}(model, env = parent.frame(), ...)
-
-\method{find_data}{svyglm}(model, ...)
-
-\method{find_data}{train}(model, ...)
-
-\method{find_data}{vgam}(model, env = parent.frame(), ...)
-
-\method{find_data}{vglm}(model, env = parent.frame(), ...)
-}
-\arguments{
-\item{model}{The model object.}
-
-\item{\dots}{Additional arguments passed to methods.}
-
-\item{env}{An environment in which to look for the \code{data} argument to the modelling call.}
-}
-\value{
-A data frame containing the original data used in a modelling call, modified according to the original model's `subset` and `na.action` arguments, if appropriate.
-}
-\description{
-Attempt to reconstruct the data used to create a model object
-}
-\details{
-This is a convenience function and, as such, carries no guarantees. To behave well, it typically requires that a model object be specified using a formula interface and an explicit \code{data} argument. Models that can be specified using variables from the \code{.GlobalEnv} or with a non-formula interface (e.g., a matrix of data) will tend to generate errors. \code{find_data} is an S3 generic so it is possible to expand it with new methods.
-}
-\examples{
-require("datasets")
-x <- lm(mpg ~ cyl * hp + wt, data = head(mtcars))
-find_data(x)
-
-}
-\seealso{
-\code{\link{prediction}}, \code{\link{build_datalist}}, \code{\link{mean_or_mode}}, \code{\link{seq_range}}
-}
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/find_data.R
+\name{find_data}
+\alias{find_data}
+\alias{find_data.default}
+\alias{find_data.data.frame}
+\alias{find_data.crch}
+\alias{find_data.glimML}
+\alias{find_data.glm}
+\alias{find_data.hxlr}
+\alias{find_data.lm}
+\alias{find_data.mca}
+\alias{find_data.merMod}
+\alias{find_data.svyglm}
+\alias{find_data.train}
+\alias{find_data.vgam}
+\alias{find_data.vglm}
+\title{Extract data from a model object}
+\usage{
+find_data(model, ...)
+
+\method{find_data}{default}(model, env = parent.frame(), ...)
+
+\method{find_data}{data.frame}(model, ...)
+
+\method{find_data}{crch}(model, env = parent.frame(), ...)
+
+\method{find_data}{glimML}(model, ...)
+
+\method{find_data}{glm}(model, env = parent.frame(), ...)
+
+\method{find_data}{hxlr}(model, env = parent.frame(), ...)
+
+\method{find_data}{lm}(model, env = parent.frame(), ...)
+
+\method{find_data}{mca}(model, env = parent.frame(), ...)
+
+\method{find_data}{merMod}(model, env = parent.frame(), ...)
+
+\method{find_data}{svyglm}(model, env = parent.frame(), ...)
+
+\method{find_data}{train}(model, ...)
+
+\method{find_data}{vgam}(model, env = parent.frame(), ...)
+
+\method{find_data}{vglm}(model, env = parent.frame(), ...)
+}
+\arguments{
+\item{model}{The model object.}
+
+\item{\dots}{Additional arguments passed to methods.}
+
+\item{env}{An environment in which to look for the \code{data} argument to the modelling call.}
+}
+\value{
+A data frame containing the original data used in a modelling call, modified according to the original model's `subset` and `na.action` arguments, if appropriate.
+}
+\description{
+Attempt to reconstruct the data used to create a model object
+}
+\details{
+This is a convenience function and, as such, carries no guarantees. To behave well, it typically requires that a model object be specified using a formula interface and an explicit \code{data} argument. Models that can be specified using variables from the \code{.GlobalEnv} or with a non-formula interface (e.g., a matrix of data) will tend to generate errors. \code{find_data} is an S3 generic so it is possible to expand it with new methods.
+}
+\examples{
+require("datasets")
+x <- lm(mpg ~ cyl * hp + wt, data = head(mtcars))
+find_data(x)
+
+}
+\seealso{
+\code{\link{prediction}}, \code{\link{build_datalist}}, \code{\link{mean_or_mode}}, \code{\link{seq_range}}
+}
diff --git a/man/margex.Rd b/man/margex.Rd
index 46c57b6..45ed257 100644
--- a/man/margex.Rd
+++ b/man/margex.Rd
@@ -1,89 +1,89 @@
-% Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/margex.R
-\docType{data}
-\name{margex}
-\alias{margex}
-\title{Artificial data for margins, copied from Stata}
-\format{A data frame with 3000 observations on the following 11 variables.
- \describe{
- \item{\samp{y}}{A numeric vector}
- \item{\samp{outcome}}{A binary numeric vector with values (0,1)}
- \item{\samp{sex}}{A factor with two levels}
- \item{\samp{group}}{A factor with three levels}
- \item{\samp{age}}{A numeric vector}
- \item{\samp{distance}}{A numeric vector}
- \item{\samp{ycn}}{A numeric vector}
- \item{\samp{yc}}{A numeric vector}
- \item{\samp{treatment}}{A factor with two levels}
- \item{\samp{agegroup}}{A factor with three levels}
- \item{\samp{arm}}{A factor with three levels}
- }}
-\source{
-\url{http://www.stata-press.com/data/r14/margex.dta}
-}
-\usage{
-margex
-}
-\description{
-The dataset is identical to the one provided by Stata and available from \code{webuse::webuse("margex")} with categorical variables explicitly encoded as factors.
-}
-\examples{
-\donttest{
-
-# Examples from Stata's help files
-# Also available from: webuse::webuse("margex")
-data("margex")
-
-# A simple case after regress
-# . regress y i.sex i.group
-# . margins sex
-m1 <- lm(y ~ factor(sex) + factor(group), data = margex)
-prediction(m1, at = list(sex = c("male", "female")))
-
-# A simple case after logistic
-# . logistic outcome i.sex i.group
-# . margins sex
-m2 <- glm(outcome ~ sex + group, binomial(), data = margex)
-prediction(m2, at = list(sex = c("male", "female")))
-
-# Average response versus response at average
-# . margins sex
-prediction(m2, at = list(sex = c("male", "female")))
-# . margins sex, atmeans
-## TODO
-
-# Multiple margins from one margins command
-# . margins sex group
-prediction(m2, at = list(sex = c("male", "female")))
-prediction(m2, at = list(group = c("1", "2", "3")))
-
-# Margins with interaction terms
-# . logistic outcome i.sex i.group sex#group
-# . margins sex group
-m3 <- glm(outcome ~ sex * group, binomial(), data = margex)
-prediction(m3, at = list(sex = c("male", "female")))
-prediction(m3, at = list(group = c("1", "2", "3")))
-
-# Margins with continuous variables
-# . logistic outcome i.sex i.group sex#group age
-# . margins sex group
-m4 <- glm(outcome ~ sex * group + age, binomial(), data = margex)
-prediction(m4, at = list(sex = c("male", "female")))
-prediction(m4, at = list(group = c("1", "2", "3")))
-
-# Margins of continuous variables
-# . margins, at(age=40)
-prediction(m4, at = list(age = 40))
-# . margins, at(age=(30 35 40 45 50))
-prediction(m4, at = list(age = c(30, 35, 40, 45, 50)))
-
-# Margins of interactions
-# . margins sex#group
-prediction(m4, at = list(sex = c("male", "female"), group = c("1", "2", "3")))
-
-}
-}
-\seealso{
-\code{\link{prediction}}
-}
-\keyword{datasets}
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/margex.R
+\docType{data}
+\name{margex}
+\alias{margex}
+\title{Artificial data for margins, copied from Stata}
+\format{A data frame with 3000 observations on the following 11 variables.
+ \describe{
+ \item{\samp{y}}{A numeric vector}
+ \item{\samp{outcome}}{A binary numeric vector with values (0,1)}
+ \item{\samp{sex}}{A factor with two levels}
+ \item{\samp{group}}{A factor with three levels}
+ \item{\samp{age}}{A numeric vector}
+ \item{\samp{distance}}{A numeric vector}
+ \item{\samp{ycn}}{A numeric vector}
+ \item{\samp{yc}}{A numeric vector}
+ \item{\samp{treatment}}{A factor with two levels}
+ \item{\samp{agegroup}}{A factor with three levels}
+ \item{\samp{arm}}{A factor with three levels}
+ }}
+\source{
+\url{http://www.stata-press.com/data/r14/margex.dta}
+}
+\usage{
+margex
+}
+\description{
+The dataset is identical to the one provided by Stata and available from \code{webuse::webuse("margex")} with categorical variables explicitly encoded as factors.
+}
+\examples{
+\donttest{
+
+# Examples from Stata's help files
+# Also available from: webuse::webuse("margex")
+data("margex")
+
+# A simple case after regress
+# . regress y i.sex i.group
+# . margins sex
+m1 <- lm(y ~ factor(sex) + factor(group), data = margex)
+prediction(m1, at = list(sex = c("male", "female")))
+
+# A simple case after logistic
+# . logistic outcome i.sex i.group
+# . margins sex
+m2 <- glm(outcome ~ sex + group, binomial(), data = margex)
+prediction(m2, at = list(sex = c("male", "female")))
+
+# Average response versus response at average
+# . margins sex
+prediction(m2, at = list(sex = c("male", "female")))
+# . margins sex, atmeans
+## TODO
+
+# Multiple margins from one margins command
+# . margins sex group
+prediction(m2, at = list(sex = c("male", "female")))
+prediction(m2, at = list(group = c("1", "2", "3")))
+
+# Margins with interaction terms
+# . logistic outcome i.sex i.group sex#group
+# . margins sex group
+m3 <- glm(outcome ~ sex * group, binomial(), data = margex)
+prediction(m3, at = list(sex = c("male", "female")))
+prediction(m3, at = list(group = c("1", "2", "3")))
+
+# Margins with continuous variables
+# . logistic outcome i.sex i.group sex#group age
+# . margins sex group
+m4 <- glm(outcome ~ sex * group + age, binomial(), data = margex)
+prediction(m4, at = list(sex = c("male", "female")))
+prediction(m4, at = list(group = c("1", "2", "3")))
+
+# Margins of continuous variables
+# . margins, at(age=40)
+prediction(m4, at = list(age = 40))
+# . margins, at(age=(30 35 40 45 50))
+prediction(m4, at = list(age = c(30, 35, 40, 45, 50)))
+
+# Margins of interactions
+# . margins sex#group
+prediction(m4, at = list(sex = c("male", "female"), group = c("1", "2", "3")))
+
+}
+}
+\seealso{
+\code{\link{prediction}}
+}
+\keyword{datasets}
diff --git a/man/mean_or_mode.Rd b/man/mean_or_mode.Rd
index 22ea3c7..0b7732c 100644
--- a/man/mean_or_mode.Rd
+++ b/man/mean_or_mode.Rd
@@ -1,52 +1,52 @@
-% Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/mean_or_mode.R
-\name{mean_or_mode}
-\alias{mean_or_mode}
-\alias{mean_or_mode.default}
-\alias{mean_or_mode.numeric}
-\alias{mean_or_mode.data.frame}
-\alias{median_or_mode}
-\alias{median_or_mode.default}
-\alias{median_or_mode.numeric}
-\alias{median_or_mode.data.frame}
-\title{Class-dependent variable aggregation}
-\usage{
-mean_or_mode(x)
-
-\method{mean_or_mode}{default}(x)
-
-\method{mean_or_mode}{numeric}(x)
-
-\method{mean_or_mode}{data.frame}(x)
-
-median_or_mode(x)
-
-\method{median_or_mode}{default}(x)
-
-\method{median_or_mode}{numeric}(x)
-
-\method{median_or_mode}{data.frame}(x)
-}
-\arguments{
-\item{x}{A vector.}
-}
-\value{
-A numeric or factor vector of length 1.
-}
-\description{
-Summarize a vector/variable into a single number, either a mean (median) for numeric vectors or the mode for categorical (character, factor, ordered, or logical) vectors. Useful for aggregation.
-}
-\examples{
-require("datasets")
-# mean for numerics
-mean_or_mode(iris)
-mean_or_mode(iris[["Sepal.Length"]])
-mean_or_mode(iris[["Species"]])
-
-# median for numerics
-median_or_mode(iris)
-
-}
-\seealso{
-\code{\link{prediction}}, \code{\link{build_datalist}}, \code{\link{seq_range}}
-}
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/mean_or_mode.R
+\name{mean_or_mode}
+\alias{mean_or_mode}
+\alias{mean_or_mode.default}
+\alias{mean_or_mode.numeric}
+\alias{mean_or_mode.data.frame}
+\alias{median_or_mode}
+\alias{median_or_mode.default}
+\alias{median_or_mode.numeric}
+\alias{median_or_mode.data.frame}
+\title{Class-dependent variable aggregation}
+\usage{
+mean_or_mode(x)
+
+\method{mean_or_mode}{default}(x)
+
+\method{mean_or_mode}{numeric}(x)
+
+\method{mean_or_mode}{data.frame}(x)
+
+median_or_mode(x)
+
+\method{median_or_mode}{default}(x)
+
+\method{median_or_mode}{numeric}(x)
+
+\method{median_or_mode}{data.frame}(x)
+}
+\arguments{
+\item{x}{A vector.}
+}
+\value{
+A numeric or factor vector of length 1.
+}
+\description{
+Summarize a vector/variable into a single number, either a mean (median) for numeric vectors or the mode for categorical (character, factor, ordered, or logical) vectors. Useful for aggregation.
+}
+\examples{
+require("datasets")
+# mean for numerics
+mean_or_mode(iris)
+mean_or_mode(iris[["Sepal.Length"]])
+mean_or_mode(iris[["Species"]])
+
+# median for numerics
+median_or_mode(iris)
+
+}
+\seealso{
+\code{\link{prediction}}, \code{\link{build_datalist}}, \code{\link{seq_range}}
+}
diff --git a/man/prediction.Rd b/man/prediction.Rd
index 4ba9abe..801b7e7 100644
--- a/man/prediction.Rd
+++ b/man/prediction.Rd
@@ -1,412 +1,680 @@
-% Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/prediction.R, R/prediction_Arima.R,
-% R/prediction_ar.R, R/prediction_arima0.R, R/prediction_betareg.R,
-% R/prediction_biglm.R, R/prediction_bruto.R, R/prediction_clm.R,
-% R/prediction_coxph.R, R/prediction_crch.R, R/prediction_earth.R,
-% R/prediction_fda.R, R/prediction_gam.R, R/prediction_gausspr.R,
-% R/prediction_gee.R, R/prediction_glimML.R, R/prediction_glimQL.R,
-% R/prediction_glm.R, R/prediction_glmnet.R, R/prediction_glmx.R,
-% R/prediction_gls.R, R/prediction_hetglm.R, R/prediction_hurdle.R,
-% R/prediction_hxlr.R, R/prediction_ivreg.R, R/prediction_knnreg.R,
-% R/prediction_kqr.R, R/prediction_ksvm.R, R/prediction_lm.R,
-% R/prediction_lme.R, R/prediction_loess.R, R/prediction_lqs.R,
-% R/prediction_mars.R, R/prediction_mca.R, R/prediction_mclogit.R,
-% R/prediction_merMod.R, R/prediction_mnp.R, R/prediction_multinom.R,
-% R/prediction_nls.R, R/prediction_nnet.R, R/prediction_plm.R,
-% R/prediction_polr.R, R/prediction_polyreg.R, R/prediction_ppr.R,
-% R/prediction_princomp.R, R/prediction_rlm.R, R/prediction_rpart.R,
-% R/prediction_rq.R, R/prediction_selection.R, R/prediction_speedglm.R,
-% R/prediction_speedlm.R, R/prediction_survreg.R, R/prediction_svm.R,
-% R/prediction_svyglm.R, R/prediction_train.R, R/prediction_truncreg.R,
-% R/prediction_zeroinfl.R, R/summary.R
-\name{prediction-package}
-\alias{prediction-package}
-\alias{prediction}
-\alias{prediction.default}
-\alias{prediction.Arima}
-\alias{prediction.ar}
-\alias{prediction.arima0}
-\alias{prediction.betareg}
-\alias{prediction.biglm}
-\alias{prediction.bruto}
-\alias{prediction.clm}
-\alias{prediction.coxph}
-\alias{prediction.crch}
-\alias{prediction.earth}
-\alias{prediction.fda}
-\alias{prediction.Gam}
-\alias{prediction.gausspr}
-\alias{prediction.gee}
-\alias{prediction.glimML}
-\alias{prediction.glimQL}
-\alias{prediction.glm}
-\alias{prediction.glmnet}
-\alias{prediction.glmx}
-\alias{prediction.gls}
-\alias{prediction.hetglm}
-\alias{prediction.hurdle}
-\alias{prediction.hxlr}
-\alias{prediction.ivreg}
-\alias{prediction.knnreg}
-\alias{prediction.kqr}
-\alias{prediction.ksvm}
-\alias{prediction.lm}
-\alias{prediction.lme}
-\alias{prediction.loess}
-\alias{prediction.lqs}
-\alias{prediction.mars}
-\alias{prediction.mca}
-\alias{prediction.mclogit}
-\alias{prediction.merMod}
-\alias{prediction.mnp}
-\alias{prediction.multinom}
-\alias{prediction.nls}
-\alias{prediction.nnet}
-\alias{prediction.plm}
-\alias{prediction.polr}
-\alias{prediction.polyreg}
-\alias{prediction.ppr}
-\alias{prediction.princomp}
-\alias{prediction.rlm}
-\alias{prediction.rpart}
-\alias{prediction.rq}
-\alias{prediction.selection}
-\alias{prediction.speedglm}
-\alias{prediction.speedlm}
-\alias{prediction.survreg}
-\alias{prediction.svm}
-\alias{prediction.svyglm}
-\alias{prediction.train}
-\alias{prediction.truncreg}
-\alias{prediction.zeroinfl}
-\alias{prediction_summary}
-\title{Extract Predictions from a Model Object}
-\usage{
-prediction(model, ...)
-
-\method{prediction}{default}(model, data = find_data(model,
- parent.frame()), at = NULL, type = "response",
- vcov = stats::vcov(model), calculate_se = TRUE, ...)
-
-\method{prediction}{Arima}(model, calculate_se = TRUE, ...)
-
-\method{prediction}{ar}(model, data, at = NULL, calculate_se = TRUE,
- ...)
-
-\method{prediction}{arima0}(model, data, at = NULL,
- calculate_se = TRUE, ...)
-
-\method{prediction}{betareg}(model, data = find_data(model,
- parent.frame()), at = NULL, type = c("response", "link", "precision",
- "variance", "quantile"), calculate_se = FALSE, ...)
-
-\method{prediction}{biglm}(model, data = find_data(model,
- parent.frame()), at = NULL, type = "response", calculate_se = TRUE,
- ...)
-
-\method{prediction}{bruto}(model, data = NULL, at = NULL,
- type = "fitted", calculate_se = FALSE, ...)
-
-\method{prediction}{clm}(model, data = find_data(model, parent.frame()),
- at = NULL, type = NULL, calculate_se = TRUE, category, ...)
-
-\method{prediction}{coxph}(model, data = find_data(model,
- parent.frame()), at = NULL, type = c("risk", "expected", "lp"),
- calculate_se = TRUE, ...)
-
-\method{prediction}{crch}(model, data = find_data(model), at = NULL,
- type = c("response", "location", "scale", "quantile"),
- calculate_se = FALSE, ...)
-
-\method{prediction}{earth}(model, data = find_data(model,
- parent.frame()), at = NULL, type = c("response", "link"),
- calculate_se = TRUE, category, ...)
-
-\method{prediction}{fda}(model, data = find_data(model, parent.frame()),
- at = NULL, type = NULL, calculate_se = FALSE, category, ...)
-
-\method{prediction}{Gam}(model, data = find_data(model, parent.frame()),
- at = NULL, type = c("response", "link", "terms"),
- calculate_se = TRUE, ...)
-
-\method{prediction}{gausspr}(model, data, at = NULL, type = NULL,
- calculate_se = TRUE, category, ...)
-
-\method{prediction}{gee}(model, calculate_se = FALSE, ...)
-
-\method{prediction}{glimML}(model, data = find_data(model,
- parent.frame()), at = NULL, type = c("response", "link"),
- calculate_se = TRUE, ...)
-
-\method{prediction}{glimQL}(model, data = find_data(model,
- parent.frame()), at = NULL, type = c("response", "link"),
- calculate_se = TRUE, ...)
-
-\method{prediction}{glm}(model, data = find_data(model, parent.frame()),
- at = NULL, type = c("response", "link"), vcov = stats::vcov(model),
- calculate_se = TRUE, ...)
-
-\method{prediction}{glmnet}(model, data, lambda = model[["lambda"]][1L],
- at = NULL, type = c("response", "link"), calculate_se = FALSE, ...)
-
-\method{prediction}{glmx}(model, data = find_data(model, parent.frame()),
- at = NULL, type = c("response", "link"), calculate_se = FALSE, ...)
-
-\method{prediction}{gls}(model, data = find_data(model), at = NULL,
- calculate_se = FALSE, ...)
-
-\method{prediction}{hetglm}(model, data = find_data(model,
- parent.frame()), at = NULL, type = c("response", "link", "scale"),
- calculate_se = FALSE, ...)
-
-\method{prediction}{hurdle}(model, data = find_data(model,
- parent.frame()), at = NULL, type = c("response", "count", "prob",
- "zero"), calculate_se = FALSE, ...)
-
-\method{prediction}{hxlr}(model, data = find_data(model), at = NULL,
- type = c("class", "probability", "cumprob", "location", "scale"),
- calculate_se = FALSE, ...)
-
-\method{prediction}{ivreg}(model, data = find_data(model,
- parent.frame()), at = NULL, calculate_se = FALSE, ...)
-
-\method{prediction}{knnreg}(model, data, at = NULL,
- calculate_se = FALSE, ...)
-
-\method{prediction}{kqr}(model, data, at = NULL, calculate_se = FALSE,
- ...)
-
-\method{prediction}{ksvm}(model, data, at = NULL, type = NULL,
- calculate_se = TRUE, category, ...)
-
-\method{prediction}{lm}(model, data = find_data(model, parent.frame()),
- at = NULL, type = "response", vcov = stats::vcov(model),
- calculate_se = TRUE, ...)
-
-\method{prediction}{lme}(model, data = find_data(model), at = NULL,
- calculate_se = FALSE, ...)
-
-\method{prediction}{loess}(model, data = find_data(model,
- parent.frame()), at = NULL, type = "response", calculate_se = TRUE,
- ...)
-
-\method{prediction}{lqs}(model, data = find_data(model), at = NULL,
- calculate_se = FALSE, ...)
-
-\method{prediction}{mars}(model, data = NULL, at = NULL,
- type = "fitted", calculate_se = FALSE, ...)
-
-\method{prediction}{mca}(model, data = find_data(model), at = NULL,
- calculate_se = FALSE, ...)
-
-\method{prediction}{mclogit}(model, data = find_data(model,
- parent.frame()), at = NULL, type = "response",
- vcov = stats::vcov(model), calculate_se = TRUE, ...)
-
-\method{prediction}{merMod}(model, data = find_data(model), at = NULL,
- type = c("response", "link"), re.form = NULL, calculate_se = FALSE,
- ...)
-
-\method{prediction}{mnp}(model, data = find_data(model, parent.frame()),
- at = NULL, type = NULL, calculate_se = FALSE, category, ...)
-
-\method{prediction}{multinom}(model, data = find_data(model,
- parent.frame()), at = NULL, type = NULL, calculate_se = FALSE,
- category, ...)
-
-\method{prediction}{nls}(model, data = find_data(model, parent.frame()),
- at = NULL, calculate_se = FALSE, ...)
-
-\method{prediction}{nnet}(model, data = find_data(model, parent.frame()),
- at = NULL, type = NULL, calculate_se = FALSE, category, ...)
-
-\method{prediction}{plm}(model, data = find_data(model, parent.frame()),
- at = NULL, calculate_se = FALSE, ...)
-
-\method{prediction}{polr}(model, data = find_data(model, parent.frame()),
- at = NULL, type = NULL, calculate_se = FALSE, category, ...)
-
-\method{prediction}{polyreg}(model, data = NULL, at = NULL,
- type = "fitted", calculate_se = FALSE, ...)
-
-\method{prediction}{ppr}(model, data = find_data(model, parent.frame()),
- at = NULL, calculate_se = FALSE, ...)
-
-\method{prediction}{princomp}(model, data = find_data(model,
- parent.frame()), at = NULL, calculate_se = FALSE, ...)
-
-\method{prediction}{rlm}(model, data = find_data(model, parent.frame()),
- at = NULL, type = "response", vcov = stats::vcov(model),
- calculate_se = TRUE, ...)
-
-\method{prediction}{rpart}(model, data = find_data(model,
- parent.frame()), at = NULL, type = NULL, calculate_se = FALSE,
- category, ...)
-
-\method{prediction}{rq}(model, data = find_data(model, parent.frame()),
- at = NULL, calculate_se = TRUE, ...)
-
-\method{prediction}{selection}(model, data = find_data(model,
- parent.frame()), at = NULL, type = "response",
- calculate_se = FALSE, ...)
-
-\method{prediction}{speedglm}(model, data = find_data(model,
- parent.frame()), at = NULL, type = c("response", "link"),
- calculate_se = FALSE, ...)
-
-\method{prediction}{speedlm}(model, data = find_data(model,
- parent.frame()), at = NULL, calculate_se = FALSE, ...)
-
-\method{prediction}{survreg}(model, data = find_data(model,
- parent.frame()), at = NULL, type = c("response", "lp", "quantile",
- "uquantile"), calculate_se = TRUE, ...)
-
-\method{prediction}{svm}(model, data = NULL, at = NULL,
- calculate_se = TRUE, category, ...)
-
-\method{prediction}{svyglm}(model, data = find_data(model,
- parent.frame()), at = NULL, type = c("response", "link"),
- calculate_se = TRUE, ...)
-
-\method{prediction}{train}(model, data = find_data(model), at = NULL,
- type = c("raw", "prob"), ...)
-
-\method{prediction}{truncreg}(model, data, at = NULL,
- calculate_se = FALSE, ...)
-
-\method{prediction}{zeroinfl}(model, data = find_data(model,
- parent.frame()), at = NULL, type = c("response", "count", "prob",
- "zero"), calculate_se = FALSE, ...)
-
-prediction_summary(model, ..., level = 0.95)
-}
-\arguments{
-\item{model}{A model object, perhaps returned by \code{\link[stats]{lm}} or \code{\link[stats]{glm}}.}
-
-\item{\dots}{Additional arguments passed to \code{\link[stats]{predict}} methods.}
-
-\item{data}{A data.frame over which to calculate marginal effects. If missing, \code{\link{find_data}} is used to specify the data frame.}
-
-\item{at}{A list of one or more named vectors, specifically values at which to calculate the predictions. These are used to modify the value of \code{data} (see \code{\link{build_datalist}} for details on use).}
-
-\item{type}{A character string indicating the type of marginal effects to estimate. Mostly relevant for non-linear models, where the reasonable options are \dQuote{response} (the default) or \dQuote{link} (i.e., on the scale of the linear predictor in a GLM). For models of class \dQuote{polr} (from \code{\link[MASS]{polr}}), possible values are \dQuote{class} or \dQuote{probs}; both are returned.}
-
-\item{vcov}{A matrix containing the variance-covariance matrix for estimated model coefficients, or a function to perform the estimation with \code{model} as its only argument.}
-
-\item{calculate_se}{A logical indicating whether to calculate standard errors for observation-specific predictions and average predictions (if possible). The output will always contain a \dQuote{calculate_se} column regardless of this value; this only controls the calculation of standard errors. Setting it to \code{FALSE} may improve speed.}
-
-\item{category}{For multi-level or multi-category outcome models (e.g., ordered probit, multinomial logit, etc.), a value specifying which of the outcome levels should be used for the \code{"fitted"} column. If missing, some default is chosen automatically.}
-
-\item{lambda}{For models of class \dQuote{glmnet}, a value of the penalty parameter at which predictions are required.}
-
-\item{re.form}{An argument passed forward to \code{\link[lme4]{predict.merMod}}.}
-
-\item{level}{A numeric value specifying the confidence level for calculating p-values and confidence intervals.}
-}
-\value{
-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{"calculate_se"}). Additional columns may be reported depending on the object class. The data frame also carries attributes used by \code{print} and \code{summary}, which will be lost during subsetting.
-}
-\description{
-Extract predicted values via \code{\link[stats]{predict}} from a model object, conditional on data, and return a data frame.
-}
-\details{
-This function is simply a wrapper around \code{\link[stats]{predict}} that returns a data frame containing the value of \code{data} and the predicted values with respect to all variables specified in \code{data}.
-
-Methods are currently implemented for the following object classes:
-\itemize{
- \item \dQuote{lm}, see \code{\link[stats]{lm}}
- \item \dQuote{glm}, see \code{\link[stats]{glm}}, \code{\link[MASS]{glm.nb}}, \code{\link[glmx]{glmx}}, \code{\link[glmx]{hetglm}}, \code{\link[brglm]{brglm}}
- \item \dQuote{ar}, see \code{\link[stats]{ar}}
- \item \dQuote{Arima}, see \code{\link[stats]{arima}}
- \item \dQuote{arima0}, see \code{\link[stats]{arima0}}
- \item \dQuote{bigglm}, see \code{\link[biglm]{bigglm}} (including \dQuote{ffdf}-backed models provided by \code{\link[ffbase]{bigglm.ffdf}})
- \item \dQuote{betareg}, see \code{\link[betareg]{betareg}}
- \item \dQuote{bruto}, see \code{\link[mda]{bruto}}
- \item \dQuote{clm}, see \code{\link[ordinal]{clm}}
- \item \dQuote{coxph}, see \code{\link[survival]{coxph}}
- \item \dQuote{crch}, see \code{\link[crch]{crch}}
- \item \dQuote{earth}, see \code{\link[earth]{earth}}
- \item \dQuote{fda}, see \code{\link[mda]{fda}}
- \item \dQuote{Gam}, see \code{\link[gam]{gam}}
- \item \dQuote{gausspr}, see \code{\link[kernlab]{gausspr}}
- \item \dQuote{gee}, see \code{\link[gee]{gee}}
- \item \dQuote{glmnet}, see \code{\link[glmnet]{glmnet}}
- \item \dQuote{gls}, see \code{\link[nlme]{gls}}
- \item \dQuote{glimML}, see \code{\link[aod]{betabin}}, \code{\link[aod]{negbin}}
- \item \dQuote{glimQL}, see \code{\link[aod]{quasibin}}, \code{\link[aod]{quasipois}}
- \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{knnreg}, see \code{\link[caret]{knnreg}}
- \item \dQuote{kqr}, see \code{\link[kernlab]{kqr}}
- \item \dQuote{ksvm}, see \code{\link[kernlab]{ksvm}}
- \item \dQuote{lda}, see \code{\link[MASS]{lda}}
- \item \dQuote{lme}, see \code{\link[nlme]{lme}}
- \item \dQuote{loess}, see \code{\link[stats]{loess}}
- \item \dQuote{lqs}, see \code{\link[MASS]{lqs}}
- \item \dQuote{mars}, see \code{\link[mda]{mars}}
- \item \dQuote{mca}, see \code{\link[MASS]{mca}}
- \item \dQuote{mclogit}, see \code{\link[mclogit]{mclogit}}
- \item \dQuote{mda}, see \code{\link[mda]{mda}}
- \item \dQuote{merMod}, see \code{\link[lme4]{lmer}}, \code{\link[lme4]{glmer}}
- \item \dQuote{mnp}, see \code{\link[MNP]{mnp}}
- \item \dQuote{naiveBayes}, see \code{\link[e1071]{naiveBayes}}
- \item \dQuote{nlme}, see \code{\link[nlme]{nlme}}
- \item \dQuote{nls}, see \code{\link[stats]{nls}}
- \item \dQuote{nnet}, see \code{\link[nnet]{nnet}}
- \item \dQuote{plm}, see \code{\link[plm]{plm}}
- \item \dQuote{polr}, see \code{\link[MASS]{polr}}
- \item \dQuote{polyreg}, see \code{\link[mda]{polyreg}}
- \item \dQuote{ppr}, see \code{\link[stats]{ppr}}
- \item \dQuote{princomp}, see \code{\link[stats]{princomp}}
- \item \dQuote{qda}, see \code{\link[MASS]{qda}}
- \item \dQuote{rlm}, see \code{\link[MASS]{rlm}}
- \item \dQuote{rpart}, see \code{\link[rpart]{rpart}}
- \item \dQuote{rq}, see \code{\link[quantreg]{rq}}
- \item \dQuote{selection}, see \code{\link[sampleSelection]{selection}}
- \item \dQuote{speedglm}, see \code{\link[speedglm]{speedglm}}
- \item \dQuote{speedlm}, see \code{\link[speedglm]{speedlm}}
- \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{tobit}, see \code{\link[AER]{tobit}}
- \item \dQuote{train}, see \code{\link[caret]{train}}
- \item \dQuote{truncreg}, see \code{\link[truncreg]{truncreg}}
- \item \dQuote{zeroinfl}, see \code{\link[pscl]{zeroinfl}}
-}
-
-Where implemented, \code{prediction} also returns average predictions (and the variances thereof). Variances are implemented using the delta method, as described in \url{http://indiana.edu/~jslsoc/stata/ci_computations/spost_deltaci.pdf}.
-}
-\examples{
-require("datasets")
-x <- lm(Petal.Width ~ Sepal.Length * Sepal.Width * Species, data = iris)
-# prediction for every case
-prediction(x)
-
-# prediction for first case
-prediction(x, iris[1,])
-
-# basic use of 'at' argument
-summary(prediction(x, at = list(Species = c("setosa", "virginica"))))
-
-# basic use of 'at' argument
-prediction(x, at = list(Sepal.Length = seq_range(iris$Sepal.Length, 5)))
-
-# prediction at means/modes of input variables
-prediction(x, at = lapply(iris, mean_or_mode))
-
-# prediction with multi-category outcome
-\dontrun{
- library("mlogit")
- data("Fishing", package = "mlogit")
- Fish <- mlogit.data(Fishing, varying = c(2:9), shape = "wide", choice = "mode")
- mod <- mlogit(mode ~ price + catch, data = Fish)
- prediction(mod)
- prediction(mod, category = 3)
-}
-
-}
-\seealso{
-\code{\link{find_data}}, \code{\link{build_datalist}}, \code{\link{mean_or_mode}}, \code{\link{seq_range}}
-}
-\keyword{models}
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/prediction.R, R/prediction_Arima.R,
+% R/prediction_ar.R, R/prediction_arima0.R, R/prediction_betareg.R,
+% R/prediction_biglm.R, R/prediction_bruto.R, R/prediction_clm.R,
+% R/prediction_coxph.R, R/prediction_crch.R, R/prediction_earth.R,
+% R/prediction_fda.R, R/prediction_gam.R, R/prediction_gausspr.R,
+% R/prediction_gee.R, R/prediction_glimML.R, R/prediction_glimQL.R,
+% R/prediction_glm.R, R/prediction_glmnet.R, R/prediction_glmx.R,
+% R/prediction_gls.R, R/prediction_hetglm.R, R/prediction_hurdle.R,
+% R/prediction_hxlr.R, R/prediction_ivreg.R, R/prediction_knnreg.R,
+% R/prediction_kqr.R, R/prediction_ksvm.R, R/prediction_lm.R,
+% R/prediction_lme.R, R/prediction_loess.R, R/prediction_lqs.R,
+% R/prediction_mars.R, R/prediction_mca.R, R/prediction_mclogit.R,
+% R/prediction_merMod.R, R/prediction_mnp.R, R/prediction_multinom.R,
+% R/prediction_nls.R, R/prediction_nnet.R, R/prediction_plm.R,
+% R/prediction_polr.R, R/prediction_polyreg.R, R/prediction_ppr.R,
+% R/prediction_princomp.R, R/prediction_rlm.R, R/prediction_rpart.R,
+% R/prediction_rq.R, R/prediction_selection.R, R/prediction_speedglm.R,
+% R/prediction_speedlm.R, R/prediction_survreg.R, R/prediction_svm.R,
+% R/prediction_svyglm.R, R/prediction_train.R, R/prediction_truncreg.R,
+% R/prediction_zeroinfl.R, R/summary.R
+\name{prediction-package}
+\alias{prediction-package}
+\alias{prediction}
+\alias{prediction.default}
+\alias{prediction.Arima}
+\alias{prediction.ar}
+\alias{prediction.arima0}
+\alias{prediction.betareg}
+\alias{prediction.biglm}
+\alias{prediction.bruto}
+\alias{prediction.clm}
+\alias{prediction.coxph}
+\alias{prediction.crch}
+\alias{prediction.earth}
+\alias{prediction.fda}
+\alias{prediction.Gam}
+\alias{prediction.gausspr}
+\alias{prediction.gee}
+\alias{prediction.glimML}
+\alias{prediction.glimQL}
+\alias{prediction.glm}
+\alias{prediction.glmnet}
+\alias{prediction.glmx}
+\alias{prediction.gls}
+\alias{prediction.hetglm}
+\alias{prediction.hurdle}
+\alias{prediction.hxlr}
+\alias{prediction.ivreg}
+\alias{prediction.knnreg}
+\alias{prediction.kqr}
+\alias{prediction.ksvm}
+\alias{prediction.lm}
+\alias{prediction.lme}
+\alias{prediction.loess}
+\alias{prediction.lqs}
+\alias{prediction.mars}
+\alias{prediction.mca}
+\alias{prediction.mclogit}
+\alias{prediction.merMod}
+\alias{prediction.mnp}
+\alias{prediction.multinom}
+\alias{prediction.nls}
+\alias{prediction.nnet}
+\alias{prediction.plm}
+\alias{prediction.polr}
+\alias{prediction.polyreg}
+\alias{prediction.ppr}
+\alias{prediction.princomp}
+\alias{prediction.rlm}
+\alias{prediction.rpart}
+\alias{prediction.rq}
+\alias{prediction.selection}
+\alias{prediction.speedglm}
+\alias{prediction.speedlm}
+\alias{prediction.survreg}
+\alias{prediction.svm}
+\alias{prediction.svyglm}
+\alias{prediction.train}
+\alias{prediction.truncreg}
+\alias{prediction.zeroinfl}
+\alias{prediction_summary}
+\title{Extract Predictions from a Model Object}
+\usage{
+prediction(model, ...)
+
+\method{prediction}{default}(
+ model,
+ data = find_data(model, parent.frame()),
+ at = NULL,
+ type = "response",
+ vcov = stats::vcov(model),
+ calculate_se = TRUE,
+ ...
+)
+
+\method{prediction}{Arima}(model, calculate_se = TRUE, ...)
+
+\method{prediction}{ar}(model, data, at = NULL, calculate_se = TRUE, ...)
+
+\method{prediction}{arima0}(model, data, at = NULL, calculate_se = TRUE, ...)
+
+\method{prediction}{betareg}(
+ model,
+ data = find_data(model, parent.frame()),
+ at = NULL,
+ type = c("response", "link", "precision", "variance", "quantile"),
+ calculate_se = FALSE,
+ ...
+)
+
+\method{prediction}{biglm}(
+ model,
+ data = find_data(model, parent.frame()),
+ at = NULL,
+ type = "response",
+ calculate_se = TRUE,
+ ...
+)
+
+\method{prediction}{bruto}(
+ model,
+ data = NULL,
+ at = NULL,
+ type = "fitted",
+ calculate_se = FALSE,
+ ...
+)
+
+\method{prediction}{clm}(
+ model,
+ data = find_data(model, parent.frame()),
+ at = NULL,
+ type = NULL,
+ calculate_se = TRUE,
+ category,
+ ...
+)
+
+\method{prediction}{coxph}(
+ model,
+ data = find_data(model, parent.frame()),
+ at = NULL,
+ type = c("risk", "expected", "lp"),
+ calculate_se = TRUE,
+ ...
+)
+
+\method{prediction}{crch}(
+ model,
+ data = find_data(model),
+ at = NULL,
+ type = c("response", "location", "scale", "quantile"),
+ calculate_se = FALSE,
+ ...
+)
+
+\method{prediction}{earth}(
+ model,
+ data = find_data(model, parent.frame()),
+ at = NULL,
+ type = c("response", "link"),
+ calculate_se = TRUE,
+ category,
+ ...
+)
+
+\method{prediction}{fda}(
+ model,
+ data = find_data(model, parent.frame()),
+ at = NULL,
+ type = NULL,
+ calculate_se = FALSE,
+ category,
+ ...
+)
+
+\method{prediction}{Gam}(
+ model,
+ data = find_data(model, parent.frame()),
+ at = NULL,
+ type = c("response", "link", "terms"),
+ calculate_se = TRUE,
+ ...
+)
+
+\method{prediction}{gausspr}(
+ model,
+ data,
+ at = NULL,
+ type = NULL,
+ calculate_se = TRUE,
+ category,
+ ...
+)
+
+\method{prediction}{gee}(model, calculate_se = FALSE, ...)
+
+\method{prediction}{glimML}(
+ model,
+ data = find_data(model, parent.frame()),
+ at = NULL,
+ type = c("response", "link"),
+ calculate_se = TRUE,
+ ...
+)
+
+\method{prediction}{glimQL}(
+ model,
+ data = find_data(model, parent.frame()),
+ at = NULL,
+ type = c("response", "link"),
+ calculate_se = TRUE,
+ ...
+)
+
+\method{prediction}{glm}(
+ model,
+ data = find_data(model, parent.frame()),
+ at = NULL,
+ type = c("response", "link"),
+ vcov = stats::vcov(model),
+ calculate_se = TRUE,
+ ...
+)
+
+\method{prediction}{glmnet}(
+ model,
+ data,
+ lambda = model[["lambda"]][1L],
+ at = NULL,
+ type = c("response", "link"),
+ calculate_se = FALSE,
+ ...
+)
+
+\method{prediction}{glmx}(
+ model,
+ data = find_data(model, parent.frame()),
+ at = NULL,
+ type = c("response", "link"),
+ calculate_se = FALSE,
+ ...
+)
+
+\method{prediction}{gls}(
+ model,
+ data = find_data(model),
+ at = NULL,
+ calculate_se = FALSE,
+ ...
+)
+
+\method{prediction}{hetglm}(
+ model,
+ data = find_data(model, parent.frame()),
+ at = NULL,
+ type = c("response", "link", "scale"),
+ calculate_se = FALSE,
+ ...
+)
+
+\method{prediction}{hurdle}(
+ model,
+ data = find_data(model, parent.frame()),
+ at = NULL,
+ type = c("response", "count", "prob", "zero"),
+ calculate_se = FALSE,
+ ...
+)
+
+\method{prediction}{hxlr}(
+ model,
+ data = find_data(model),
+ at = NULL,
+ type = c("class", "probability", "cumprob", "location", "scale"),
+ calculate_se = FALSE,
+ ...
+)
+
+\method{prediction}{ivreg}(
+ model,
+ data = find_data(model, parent.frame()),
+ at = NULL,
+ calculate_se = FALSE,
+ ...
+)
+
+\method{prediction}{knnreg}(model, data, at = NULL, calculate_se = FALSE, ...)
+
+\method{prediction}{kqr}(model, data, at = NULL, calculate_se = FALSE, ...)
+
+\method{prediction}{ksvm}(
+ model,
+ data,
+ at = NULL,
+ type = NULL,
+ calculate_se = TRUE,
+ category,
+ ...
+)
+
+\method{prediction}{lm}(
+ model,
+ data = find_data(model, parent.frame()),
+ at = NULL,
+ type = "response",
+ vcov = stats::vcov(model),
+ calculate_se = TRUE,
+ ...
+)
+
+\method{prediction}{lme}(
+ model,
+ data = find_data(model),
+ at = NULL,
+ calculate_se = FALSE,
+ ...
+)
+
+\method{prediction}{loess}(
+ model,
+ data = find_data(model, parent.frame()),
+ at = NULL,
+ type = "response",
+ calculate_se = TRUE,
+ ...
+)
+
+\method{prediction}{lqs}(
+ model,
+ data = find_data(model),
+ at = NULL,
+ calculate_se = FALSE,
+ ...
+)
+
+\method{prediction}{mars}(
+ model,
+ data = NULL,
+ at = NULL,
+ type = "fitted",
+ calculate_se = FALSE,
+ ...
+)
+
+\method{prediction}{mca}(
+ model,
+ data = find_data(model),
+ at = NULL,
+ calculate_se = FALSE,
+ ...
+)
+
+\method{prediction}{mclogit}(
+ model,
+ data = find_data(model, parent.frame()),
+ at = NULL,
+ type = "response",
+ vcov = stats::vcov(model),
+ calculate_se = TRUE,
+ ...
+)
+
+\method{prediction}{merMod}(
+ model,
+ data = find_data(model),
+ at = NULL,
+ type = c("response", "link"),
+ re.form = NULL,
+ calculate_se = FALSE,
+ ...
+)
+
+\method{prediction}{mnp}(
+ model,
+ data = find_data(model, parent.frame()),
+ at = NULL,
+ type = NULL,
+ calculate_se = FALSE,
+ category,
+ ...
+)
+
+\method{prediction}{multinom}(
+ model,
+ data = find_data(model, parent.frame()),
+ at = NULL,
+ type = NULL,
+ calculate_se = FALSE,
+ category,
+ ...
+)
+
+\method{prediction}{nls}(
+ model,
+ data = find_data(model, parent.frame()),
+ at = NULL,
+ calculate_se = FALSE,
+ ...
+)
+
+\method{prediction}{nnet}(
+ model,
+ data = find_data(model, parent.frame()),
+ at = NULL,
+ type = NULL,
+ calculate_se = FALSE,
+ category,
+ ...
+)
+
+\method{prediction}{plm}(
+ model,
+ data = find_data(model, parent.frame()),
+ at = NULL,
+ calculate_se = FALSE,
+ ...
+)
+
+\method{prediction}{polr}(
+ model,
+ data = find_data(model, parent.frame()),
+ at = NULL,
+ type = NULL,
+ calculate_se = FALSE,
+ category,
+ ...
+)
+
+\method{prediction}{polyreg}(
+ model,
+ data = NULL,
+ at = NULL,
+ type = "fitted",
+ calculate_se = FALSE,
+ ...
+)
+
+\method{prediction}{ppr}(
+ model,
+ data = find_data(model, parent.frame()),
+ at = NULL,
+ calculate_se = FALSE,
+ ...
+)
+
+\method{prediction}{princomp}(
+ model,
+ data = find_data(model, parent.frame()),
+ at = NULL,
+ calculate_se = FALSE,
+ ...
+)
+
+\method{prediction}{rlm}(
+ model,
+ data = find_data(model, parent.frame()),
+ at = NULL,
+ type = "response",
+ vcov = stats::vcov(model),
+ calculate_se = TRUE,
+ ...
+)
+
+\method{prediction}{rpart}(
+ model,
+ data = find_data(model, parent.frame()),
+ at = NULL,
+ type = NULL,
+ calculate_se = FALSE,
+ category,
+ ...
+)
+
+\method{prediction}{rq}(
+ model,
+ data = find_data(model, parent.frame()),
+ at = NULL,
+ calculate_se = TRUE,
+ ...
+)
+
+\method{prediction}{selection}(
+ model,
+ data = find_data(model, parent.frame()),
+ at = NULL,
+ type = "response",
+ calculate_se = FALSE,
+ ...
+)
+
+\method{prediction}{speedglm}(
+ model,
+ data = find_data(model, parent.frame()),
+ at = NULL,
+ type = c("response", "link"),
+ calculate_se = FALSE,
+ ...
+)
+
+\method{prediction}{speedlm}(
+ model,
+ data = find_data(model, parent.frame()),
+ at = NULL,
+ calculate_se = FALSE,
+ ...
+)
+
+\method{prediction}{survreg}(
+ model,
+ data = find_data(model, parent.frame()),
+ at = NULL,
+ type = c("response", "lp", "quantile", "uquantile"),
+ calculate_se = TRUE,
+ ...
+)
+
+\method{prediction}{svm}(model, data = NULL, at = NULL, calculate_se = TRUE, category, ...)
+
+\method{prediction}{svyglm}(
+ model,
+ data = find_data(model, parent.frame()),
+ at = NULL,
+ type = c("response", "link"),
+ calculate_se = TRUE,
+ ...
+)
+
+\method{prediction}{train}(
+ model,
+ data = find_data(model),
+ at = NULL,
+ type = c("raw", "prob"),
+ ...
+)
+
+\method{prediction}{truncreg}(model, data, at = NULL, calculate_se = FALSE, ...)
+
+\method{prediction}{zeroinfl}(
+ model,
+ data = find_data(model, parent.frame()),
+ at = NULL,
+ type = c("response", "count", "prob", "zero"),
+ calculate_se = FALSE,
+ ...
+)
+
+prediction_summary(model, ..., level = 0.95)
+}
+\arguments{
+\item{model}{A model object, perhaps returned by \code{\link[stats]{lm}} or \code{\link[stats]{glm}}.}
+
+\item{\dots}{Additional arguments passed to \code{\link[stats]{predict}} methods.}
+
+\item{data}{A data.frame over which to calculate marginal effects. If missing, \code{\link{find_data}} is used to specify the data frame.}
+
+\item{at}{A list of one or more named vectors, specifically values at which to calculate the predictions. These are used to modify the value of \code{data} (see \code{\link{build_datalist}} for details on use).}
+
+\item{type}{A character string indicating the type of marginal effects to estimate. Mostly relevant for non-linear models, where the reasonable options are \dQuote{response} (the default) or \dQuote{link} (i.e., on the scale of the linear predictor in a GLM). For models of class \dQuote{polr} (from \code{\link[MASS]{polr}}), possible values are \dQuote{class} or \dQuote{probs}; both are returned.}
+
+\item{vcov}{A matrix containing the variance-covariance matrix for estimated model coefficients, or a function to perform the estimation with \code{model} as its only argument.}
+
+\item{calculate_se}{A logical indicating whether to calculate standard errors for observation-specific predictions and average predictions (if possible). The output will always contain a \dQuote{calculate_se} column regardless of this value; this only controls the calculation of standard errors. Setting it to \code{FALSE} may improve speed.}
+
+\item{category}{For multi-level or multi-category outcome models (e.g., ordered probit, multinomial logit, etc.), a value specifying which of the outcome levels should be used for the \code{"fitted"} column. If missing, some default is chosen automatically.}
+
+\item{lambda}{For models of class \dQuote{glmnet}, a value of the penalty parameter at which predictions are required.}
+
+\item{re.form}{An argument passed forward to \code{\link[lme4]{predict.merMod}}.}
+
+\item{level}{A numeric value specifying the confidence level for calculating p-values and confidence intervals.}
+}
+\value{
+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{"calculate_se"}). Additional columns may be reported depending on the object class. The data frame also carries attributes used by \code{print} and \code{summary}, which will be lost during subsetting.
+}
+\description{
+Extract predicted values via \code{\link[stats]{predict}} from a model object, conditional on data, and return a data frame.
+}
+\details{
+This function is simply a wrapper around \code{\link[stats]{predict}} that returns a data frame containing the value of \code{data} and the predicted values with respect to all variables specified in \code{data}.
+
+Methods are currently implemented for the following object classes:
+\itemize{
+ \item \dQuote{lm}, see \code{\link[stats]{lm}}
+ \item \dQuote{glm}, see \code{\link[stats]{glm}}, \code{\link[MASS]{glm.nb}}, \code{\link[glmx]{glmx}}, \code{\link[glmx]{hetglm}}, \code{\link[brglm]{brglm}}
+ \item \dQuote{ar}, see \code{\link[stats]{ar}}
+ \item \dQuote{Arima}, see \code{\link[stats]{arima}}
+ \item \dQuote{arima0}, see \code{\link[stats]{arima0}}
+ \item \dQuote{bigglm}, see \code{\link[biglm]{bigglm}} (including \dQuote{ffdf}-backed models provided by \code{\link[ffbase]{bigglm.ffdf}})
+ \item \dQuote{betareg}, see \code{\link[betareg]{betareg}}
+ \item \dQuote{bruto}, see \code{\link[mda]{bruto}}
+ \item \dQuote{clm}, see \code{\link[ordinal]{clm}}
+ \item \dQuote{coxph}, see \code{\link[survival]{coxph}}
+ \item \dQuote{crch}, see \code{\link[crch]{crch}}
+ \item \dQuote{earth}, see \code{\link[earth]{earth}}
+ \item \dQuote{fda}, see \code{\link[mda]{fda}}
+ \item \dQuote{Gam}, see \code{\link[gam]{gam}}
+ \item \dQuote{gausspr}, see \code{\link[kernlab]{gausspr}}
+ \item \dQuote{gee}, see \code{\link[gee]{gee}}
+ \item \dQuote{glmnet}, see \code{\link[glmnet]{glmnet}}
+ \item \dQuote{gls}, see \code{\link[nlme]{gls}}
+ \item \dQuote{glimML}, see \code{\link[aod]{betabin}}, \code{\link[aod]{negbin}}
+ \item \dQuote{glimQL}, see \code{\link[aod]{quasibin}}, \code{\link[aod]{quasipois}}
+ \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{knnreg}, see \code{\link[caret]{knnreg}}
+ \item \dQuote{kqr}, see \code{\link[kernlab]{kqr}}
+ \item \dQuote{ksvm}, see \code{\link[kernlab]{ksvm}}
+ \item \dQuote{lda}, see \code{\link[MASS]{lda}}
+ \item \dQuote{lme}, see \code{\link[nlme]{lme}}
+ \item \dQuote{loess}, see \code{\link[stats]{loess}}
+ \item \dQuote{lqs}, see \code{\link[MASS]{lqs}}
+ \item \dQuote{mars}, see \code{\link[mda]{mars}}
+ \item \dQuote{mca}, see \code{\link[MASS]{mca}}
+ \item \dQuote{mclogit}, see \code{\link[mclogit]{mclogit}}
+ \item \dQuote{mda}, see \code{\link[mda]{mda}}
+ \item \dQuote{merMod}, see \code{\link[lme4]{lmer}}, \code{\link[lme4]{glmer}}
+ \item \dQuote{mnp}, see \code{\link[MNP]{mnp}}
+ \item \dQuote{naiveBayes}, see \code{\link[e1071]{naiveBayes}}
+ \item \dQuote{nlme}, see \code{\link[nlme]{nlme}}
+ \item \dQuote{nls}, see \code{\link[stats]{nls}}
+ \item \dQuote{nnet}, see \code{\link[nnet]{nnet}}
+ \item \dQuote{plm}, see \code{\link[plm]{plm}}
+ \item \dQuote{polr}, see \code{\link[MASS]{polr}}
+ \item \dQuote{polyreg}, see \code{\link[mda]{polyreg}}
+ \item \dQuote{ppr}, see \code{\link[stats]{ppr}}
+ \item \dQuote{princomp}, see \code{\link[stats]{princomp}}
+ \item \dQuote{qda}, see \code{\link[MASS]{qda}}
+ \item \dQuote{rlm}, see \code{\link[MASS]{rlm}}
+ \item \dQuote{rpart}, see \code{\link[rpart]{rpart}}
+ \item \dQuote{rq}, see \code{\link[quantreg]{rq}}
+ \item \dQuote{selection}, see \code{\link[sampleSelection]{selection}}
+ \item \dQuote{speedglm}, see \code{\link[speedglm]{speedglm}}
+ \item \dQuote{speedlm}, see \code{\link[speedglm]{speedlm}}
+ \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{tobit}, see \code{\link[AER]{tobit}}
+ \item \dQuote{train}, see \code{\link[caret]{train}}
+ \item \dQuote{truncreg}, see \code{\link[truncreg]{truncreg}}
+ \item \dQuote{zeroinfl}, see \code{\link[pscl]{zeroinfl}}
+}
+
+Where implemented, \code{prediction} also returns average predictions (and the variances thereof). Variances are implemented using the delta method, as described in \url{http://indiana.edu/~jslsoc/stata/ci_computations/spost_deltaci.pdf}.
+}
+\examples{
+require("datasets")
+x <- lm(Petal.Width ~ Sepal.Length * Sepal.Width * Species, data = iris)
+# prediction for every case
+prediction(x)
+
+# prediction for first case
+prediction(x, iris[1,])
+
+# basic use of 'at' argument
+summary(prediction(x, at = list(Species = c("setosa", "virginica"))))
+
+# basic use of 'at' argument
+prediction(x, at = list(Sepal.Length = seq_range(iris$Sepal.Length, 5)))
+
+# prediction at means/modes of input variables
+prediction(x, at = lapply(iris, mean_or_mode))
+
+# prediction with multi-category outcome
+\dontrun{
+ library("mlogit")
+ data("Fishing", package = "mlogit")
+ Fish <- mlogit.data(Fishing, varying = c(2:9), shape = "wide", choice = "mode")
+ mod <- mlogit(mode ~ price + catch, data = Fish)
+ prediction(mod)
+ prediction(mod, category = 3)
+}
+
+}
+\seealso{
+\code{\link{find_data}}, \code{\link{build_datalist}}, \code{\link{mean_or_mode}}, \code{\link{seq_range}}
+}
+\keyword{models}
diff --git a/man/seq_range.Rd b/man/seq_range.Rd
index 7d9afbb..05a97e9 100644
--- a/man/seq_range.Rd
+++ b/man/seq_range.Rd
@@ -1,27 +1,27 @@
-% Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/seq_range.R
-\name{seq_range}
-\alias{seq_range}
-\title{Create a sequence over the range of a vector}
-\usage{
-seq_range(x, n = 2)
-}
-\arguments{
-\item{x}{A numeric vector}
-
-\item{n}{An integer specifying the length of sequence (i.e., number of points across the range of \code{x})}
-}
-\value{
-A vector of length \code{n}.
-}
-\description{
-Define a sequence of evenly spaced values from the minimum to the maximum of a vector
-}
-\examples{
-identical(range(1:5), seq_range(1:5, n = 2))
-seq_range(1:5, n = 3)
-
-}
-\seealso{
-\code{\link{mean_or_mode}}, \code{\link{build_datalist}}
-}
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/seq_range.R
+\name{seq_range}
+\alias{seq_range}
+\title{Create a sequence over the range of a vector}
+\usage{
+seq_range(x, n = 2)
+}
+\arguments{
+\item{x}{A numeric vector}
+
+\item{n}{An integer specifying the length of sequence (i.e., number of points across the range of \code{x})}
+}
+\value{
+A vector of length \code{n}.
+}
+\description{
+Define a sequence of evenly spaced values from the minimum to the maximum of a vector
+}
+\examples{
+identical(range(1:5), seq_range(1:5, n = 2))
+seq_range(1:5, n = 3)
+
+}
+\seealso{
+\code{\link{mean_or_mode}}, \code{\link{build_datalist}}
+}
diff --git a/po/R-prediction.pot b/po/R-prediction.pot
new file mode 100644
index 0000000..440e6e6
--- /dev/null
+++ b/po/R-prediction.pot
@@ -0,0 +1,125 @@
+msgid ""
+msgstr ""
+"Project-Id-Version: prediction 0.3.15\n"
+"POT-Creation-Date: 2019-12-24 14:49\n"
+"PO-Revision-Date: YEAR-MO-DA HO:MI+ZONE\n"
+"Last-Translator: FULL NAME <EMAIL@ADDRESS>\n"
+"Language-Team: LANGUAGE <LL@li.org>\n"
+"MIME-Version: 1.0\n"
+"Content-Type: text/plain; charset=CHARSET\n"
+"Content-Transfer-Encoding: 8bit\n"
+
+
+msgid "Illegal factor levels for variable '"
+msgstr ""
+
+msgid "':"
+msgstr ""
+
+msgid ","
+msgstr ""
+
+msgid "A 'at' value for '"
+msgstr ""
+
+msgid "' is"
+msgstr ""
+
+msgid "Some 'at' values for '"
+msgstr ""
+
+msgid "' are"
+msgstr ""
+
+msgid "'at' contains unnamed list elements"
+msgstr ""
+
+msgid "("
+msgstr ""
+
+msgid ")"
+msgstr ""
+
+msgid "<empty>"
+msgstr ""
+
+msgid "'find_data()' requires a formula call"
+msgstr ""
+
+msgid "'find_data()' cannot locate variable(s) used in 'subset'"
+msgstr ""
+
+msgid "'find_data.vgam()' requires the 'methods' package"
+msgstr ""
+
+msgid "prediction() for objects of class 'bigglm' only work when 'data' is specified"
+msgstr ""
+
+msgid "prediction() for objects of class 'biglm' only work when 'data' is specified"
+msgstr ""
+
+msgid "'type' is ignored for models of class '%s'"
+msgstr ""
+
+msgid "category %s not found"
+msgstr ""
+
+msgid "'data' is required for models of class '%s'"
+msgstr ""
+
+msgid "'data' is ignored for models of class '%s'"
+msgstr ""
+
+msgid "'prediction.mnp' only works when 'n.draws = 1'"
+msgstr ""
+
+msgid "Data frame with %d %s%swith modal prediction (of %d %s):"
+msgstr ""
+
+msgid "prediction"
+msgstr ""
+
+msgid "predictions"
+msgstr ""
+
+msgid "call"
+msgstr ""
+
+msgid "from\n %s"
+msgstr ""
+
+msgid "level"
+msgstr ""
+
+msgid "levels"
+msgstr ""
+
+msgid "Data frame with %d %s%swith average prediction: %s"
+msgstr ""
+
+msgid "%0."
+msgstr ""
+
+msgid "f"
+msgstr ""
+
+msgid "Data frame with %d %s%swith modal %s (of %d %s):"
+msgstr ""
+
+msgid "Data frame with %d %s%swith average %s:"
+msgstr ""
+
+msgid "Unrecognized variable name in 'at': "
+msgid_plural "Unrecognized variable names in 'at': "
+msgstr[0] ""
+msgstr[1] ""
+
+msgid "prediction"
+msgid_plural "predictions"
+msgstr[0] ""
+msgstr[1] ""
+
+msgid "level"
+msgid_plural "levels"
+msgstr[0] ""
+msgstr[1] ""
diff --git a/tests/testthat-prediction.R b/tests/testthat-prediction.R
index 85f105a..3d1c499 100644
--- a/tests/testthat-prediction.R
+++ b/tests/testthat-prediction.R
@@ -1,3 +1,3 @@
-library("testthat")
-library("prediction")
-test_check("prediction")
+library("testthat")
+library("prediction")
+test_check("prediction")
diff --git a/tests/testthat/tests-build_datalist.R b/tests/testthat/tests-build_datalist.R
index 2c50ce1..f52ee90 100644
--- a/tests/testthat/tests-build_datalist.R
+++ b/tests/testthat/tests-build_datalist.R
@@ -1,22 +1,29 @@
-context("Test `build_data_list()` behavior")
-
-test_that("Test build_datalist()", {
- expect_true(inherits(build_datalist(mtcars, at = NULL), "list"), label = "build_datalist(at = NULL) works")
- expect_true(inherits(build_datalist(mtcars, at = list(cyl = 4)), "list"), label = "build_datalist(at = ) works")
-
- expect_true(length(build_datalist(mtcars, at = list(cyl = c(4, 6), wt = 2:3))) == 4, label = "build_datalist() length")
-
- expect_error(build_datalist(mtcars, at = list(foo = 1)), label = "build_datalist(at = foo) errors")
- expect_error(build_datalist(mtcars, at = list(1)), label = "build_datalist() unnamed list errors")
- expect_warning(build_datalist(mtcars, at = list(cyl = 2)), label = "build_datalist() range warning")
-})
-
-test_that("Factors in build_datalist()", {
- mtcars$cyl <- factor(mtcars$cyl)
- expect_true(inherits(build_datalist(mtcars, at = list(cyl = 4)), "list"), label = "build_datalist(at = factor()) works")
-
- expect_error(build_datalist(mtcars, at = list(cyl = 7)), label = "build_datalist(at = ) errors on illegal factor level")
-
- mtcars$cyl <- as.character(mtcars$cyl)
- expect_true(inherits(build_datalist(mtcars, at = list(cyl = 4)), "list"), label = "build_datalist(at = ) works")
-})
+context("Test `build_data_list()` behavior")
+
+test_that("Test build_datalist()", {
+ expect_true(inherits(build_datalist(mtcars, at = NULL), "list"), label = "build_datalist(at = NULL) works")
+ expect_true(inherits(build_datalist(mtcars, at = list(cyl = 4)), "list"), label = "build_datalist(at = ) works")
+
+ expect_true(length(build_datalist(mtcars, at = list(cyl = c(4, 6), wt = 2:3))) == 4, label = "build_datalist() length")
+
+ expect_error(build_datalist(mtcars, at = list(foo = 1)), label = "build_datalist(at = foo) errors")
+ expect_error(build_datalist(mtcars, at = list(1)), label = "build_datalist() unnamed list errors")
+ expect_warning(build_datalist(mtcars, at = list(cyl = 2)), label = "build_datalist() range warning")
+})
+
+test_that("Test build_datalist() with data.table", {
+ dt <- data.table::data.table(y=1:5, x=1:5)
+ expect_true(inherits(build_datalist(dt, at = list(x = 2)), "list"), label = "build_datalist(at = NULL) works with data.table")
+})
+
+test_that("Factors in build_datalist()", {
+ mtcars$cyl <- factor(mtcars$cyl)
+ e <- build_datalist(mtcars, at = list(cyl = 4))
+ expect_true(inherits(e, "list"), label = "build_datalist(at = factor()) works")
+ expect_true(identical(levels(mtcars$cyl), levels(e[[1L]][["cyl"]])), label = "build_datalist(at = factor()) preserves factor levels")
+
+ expect_error(build_datalist(mtcars, at = list(cyl = 7)), label = "build_datalist(at = ) errors on illegal factor level")
+
+ mtcars$cyl <- as.character(mtcars$cyl)
+ expect_true(inherits(build_datalist(mtcars, at = list(cyl = 4)), "list"), label = "build_datalist(at = ) works")
+})
diff --git a/tests/testthat/tests-core.R b/tests/testthat/tests-core.R
index ca760f0..3615308 100644
--- a/tests/testthat/tests-core.R
+++ b/tests/testthat/tests-core.R
@@ -1,134 +1,134 @@
-# set comparison tolerance
-tol <- 0.0001
-
-library("datasets")
-
-context("Test `prediction()` behavior")
-test_that("Test prediction()", {
- mod1 <- lm(mpg ~ cyl, data = mtcars)
- mod2 <- glm(mpg ~ cyl, data = mtcars)
- expect_true(inherits(prediction(mod1, data = mtcars), "data.frame"), label = "prediction() works w data arg (LM)")
- expect_true(inherits(prediction(mod2, data = mtcars), "data.frame"), label = "prediction() works w data arg (GLM)")
- expect_true(inherits(prediction(mod1), "data.frame"), label = "prediction() works w/o data arg (LM)")
- expect_true(inherits(prediction(mod2), "data.frame"), label = "prediction() works w/o data arg (GLM)")
- expect_error(inherits(prediction(mod1, data = NULL), "data.frame"), label = "prediction() errors w/ NULL data arg (LM)")
- expect_error(inherits(prediction(mod2, data = NULL), "data.frame"), label = "prediction() errors w/ NULL data arg (GLM)")
- expect_true(all.equal(prediction(mod1, data = mtcars)$fitted, predict(mod1), check.attributes = FALSE),
- label = "prediction() matches predict() (LM)")
- expect_true(all.equal(prediction(mod2, data = mtcars)$fitted, predict(mod2, type = "response"), check.attributes = FALSE),
- label = "prediction() matches predict() (GLM)")
-})
-
-test_that("Test prediction(data = )", {
- m <- lm(mpg ~ cyl + wt, data = mtcars)
- p1 <- prediction(m, data = data.frame(cyl = 4, wt = 3.9))
- expect_true(inherits(p1, "data.frame"), label = "prediction(lm(~), data = data.frame()) works")
-
- m <- glm(mpg ~ cyl + wt, data = mtcars)
- p1 <- prediction(m, data = data.frame(cyl = 4, wt = 3.9))
- expect_true(inherits(p1, "data.frame"), label = "prediction(glm(~), data = data.frame()) works")
-})
-
-test_that("Test prediction(at = )", {
- m <- lm(mpg ~ cyl, data = mtcars)
- p1 <- prediction(m, at = list(cyl = 4))
- expect_true(inherits(p1, "data.frame"), label = "prediction(at = list(cyl = 4)) works")
- expect_true(nrow(p1) == nrow(mtcars), label = "prediction(at = list(cyl = 4)) works")
- expect_true(all.equal(p1$fitted, predict(m, within(mtcars, cyl <- 4)), check.attributes = FALSE),
- label = "prediction(at = list(cyl = 4)) matches predict()")
-
- p2 <- prediction(m, at = list(cyl = c(4, 6)))
- expect_true(inherits(p2, "data.frame"), label = "prediction(at = list(cyl = c(4, 6))) works")
- expect_true(nrow(p2) == 2*nrow(mtcars), label = "prediction(at = list(cyl = c(4, 6))) works")
- expect_true(all.equal(p2$fitted,
- predict(m, rbind(within(mtcars, cyl <- 4), within(mtcars, cyl <- 6))),
- check.attributes = FALSE),
- label = "prediction(at = list(cyl = c(4, 6))) matches predict()")
-
- p3 <- prediction(m, at = list(cyl = c(4, 6), wt = 2:3))
- expect_true(inherits(p3, "data.frame"), label = "prediction(at = list(cyl = c(4, 6), wt = 2:3)) works")
- expect_true(nrow(p3) == 4*nrow(mtcars), label = "prediction(at = list(cyl = c(4, 6), wt = 2:3)) works")
-
- mtcars$cyl <- factor(mtcars$cyl)
- expect_error(prediction(m, at = list(cyl = 3)), label = "prediction(at = list(cyl = 3)) errors")
-})
-
-context("Test behavior of 'prediction' class methods")
-test_that("Test print()", {
- expect_true(inherits(print(prediction(lm(mpg ~ cyl, data = mtcars), data = mtcars)), "data.frame"),
- label = "print() works with numeric outcome")
- expect_true(inherits(print(prediction(lm(mpg ~ cyl, data = mtcars), data = mtcars, at = list(cyl = c(4,6,8)))), "data.frame"),
- label = "print() works with numeric outcome and at()")
-})
-
-test_that("Test summary() w/o at()", {
- m1 <- lm(mpg ~ cyl, data = mtcars)
-
- # prediction w/o at()
- p1 <- prediction(m1)
- s1 <- summary(p1)
- expect_true(inherits(summary(p1), "data.frame"),
- label = "summary() works with numeric outcome")
- expect_true(all(c("Prediction", "SE", "z", "p", "lower", "upper") %in% names(s1)),
- label = "summary() has correct columns w/o at()")
- expect_true(nrow(s1) == 1L, label = "summary() has correct rows w/o at()")
-
- ## numerical correctness
- expect_true(all.equal(s1[["Prediction"]][1L], mean(predict(m1)), tolerance = tol),
- label = "summary() returns numerically correct mean prediction")
- test_se <- sqrt(colMeans(cbind(1, mtcars$cyl)) %*% vcov(m1) %*% colMeans(cbind(1, mtcars$cyl)))[1,1,drop=TRUE]
- expect_true(all.equal(s1[["SE"]][1L], test_se, tolerance = tol),
- label = "summary() returns numerically correct SE of mean prediction")
-})
-
-test_that("Test summary() w at()", {
- # prediction w/ at()
- m1 <- lm(mpg ~ cyl, data = mtcars)
- p2 <- prediction(m1, data = mtcars, at = list(cyl = c(4,6,8)))
- s2 <- summary(p2)
- expect_true(inherits(s2, "data.frame"),
- label = "summary() works with numeric outcome and at()")
- expect_true(all(c("at(cyl)", "Prediction", "SE", "z", "p", "lower", "upper") %in% names(s2)),
- label = "summary() has correct columns with at()")
- expect_true(nrow(s2) == 3L, label = "summary() has correct rows w/o at()")
-
- ## numerical correctness
- expect_true(all.equal(s2[["Prediction"]][1L], mean(predict(m1, newdata = within(mtcars, cyl <- 4))), tolerance = tol),
- label = "summary() returns numerically correct mean prediction with at()")
- test_se <- sqrt(colMeans(cbind(1, 4)) %*% vcov(m1) %*% colMeans(cbind(1, 4)))[1,1,drop=TRUE]
- expect_true(all.equal(s2[["SE"]][1L], test_se, tolerance = tol),
- label = "summary() returns numerically correct SE of mean prediction with at()")
-})
-
-test_that("Test prediction_summary()", {
- m1 <- lm(mpg ~ cyl, data = mtcars)
- p1 <- prediction(m1)
- s1 <- summary(p1)
- expect_true(identical(s1, prediction_summary(m1)), label = "prediction_summary() is correct")
-})
-
-test_that("Test head() and tail()", {
- p1 <- prediction(lm(mpg ~ cyl, data = mtcars), data = mtcars)
- expect_true(inherits(head(p1), "data.frame"), label = "head() works")
- expect_true(nrow(head(p1, 5L)) == 5L, label = "head() has correct rows")
- expect_true(inherits(tail(p1), "data.frame"), label = "tail() works")
- expect_true(nrow(tail(p1, 5L)) == 5L, label = "tail() has correct rows")
-})
-
-context("Test utilities")
-test_that("Test seq_range()", {
- expect_true(identical(range(mtcars$wt), seq_range(mtcars$wt, 2)), label = "seq_range() is correct")
- expect_true(length(seq_range(mtcars$wt, 5)) == 5, label = "seq_range() length is correct")
-})
-
-test_that("Test mean_or_mode()/median_or_mode()", {
- expect_true(mean_or_mode(mtcars$wt) == mean(mtcars$wt), label = "mean_or_mode.numeric() is correct")
- expect_true(median_or_mode(mtcars$wt) == median(mtcars$wt), label = "median_or_mode.numeric() is correct")
-
- mtcars$cyl <- factor(mtcars$cyl)
- expect_true(mean_or_mode(mtcars$cyl) == 8, label = "mean_or_mode.default() is correct")
- expect_true(median_or_mode(mtcars$cyl) == 8, label = "mean_or_mode.default() is correct")
-
- expect_true(identical(mean_or_mode(mtcars), lapply(mtcars, mean_or_mode)), label = "mean_or_mode.data.frame() is correct")
- expect_true(identical(median_or_mode(mtcars), lapply(mtcars, median_or_mode)), label = "median_or_mode.data.frame() is correct")
-})
+# set comparison tolerance
+tol <- 0.0001
+
+library("datasets")
+
+context("Test `prediction()` behavior")
+test_that("Test prediction()", {
+ mod1 <- lm(mpg ~ cyl, data = mtcars)
+ mod2 <- glm(mpg ~ cyl, data = mtcars)
+ expect_true(inherits(prediction(mod1, data = mtcars), "data.frame"), label = "prediction() works w data arg (LM)")
+ expect_true(inherits(prediction(mod2, data = mtcars), "data.frame"), label = "prediction() works w data arg (GLM)")
+ expect_true(inherits(prediction(mod1), "data.frame"), label = "prediction() works w/o data arg (LM)")
+ expect_true(inherits(prediction(mod2), "data.frame"), label = "prediction() works w/o data arg (GLM)")
+ expect_error(inherits(prediction(mod1, data = NULL), "data.frame"), label = "prediction() errors w/ NULL data arg (LM)")
+ expect_error(inherits(prediction(mod2, data = NULL), "data.frame"), label = "prediction() errors w/ NULL data arg (GLM)")
+ expect_true(all.equal(prediction(mod1, data = mtcars)$fitted, predict(mod1), check.attributes = FALSE),
+ label = "prediction() matches predict() (LM)")
+ expect_true(all.equal(prediction(mod2, data = mtcars)$fitted, predict(mod2, type = "response"), check.attributes = FALSE),
+ label = "prediction() matches predict() (GLM)")
+})
+
+test_that("Test prediction(data = )", {
+ m <- lm(mpg ~ cyl + wt, data = mtcars)
+ p1 <- prediction(m, data = data.frame(cyl = 4, wt = 3.9))
+ expect_true(inherits(p1, "data.frame"), label = "prediction(lm(~), data = data.frame()) works")
+
+ m <- glm(mpg ~ cyl + wt, data = mtcars)
+ p1 <- prediction(m, data = data.frame(cyl = 4, wt = 3.9))
+ expect_true(inherits(p1, "data.frame"), label = "prediction(glm(~), data = data.frame()) works")
+})
+
+test_that("Test prediction(at = )", {
+ m <- lm(mpg ~ cyl, data = mtcars)
+ p1 <- prediction(m, at = list(cyl = 4))
+ expect_true(inherits(p1, "data.frame"), label = "prediction(at = list(cyl = 4)) works")
+ expect_true(nrow(p1) == nrow(mtcars), label = "prediction(at = list(cyl = 4)) works")
+ expect_true(all.equal(p1$fitted, predict(m, within(mtcars, cyl <- 4)), check.attributes = FALSE),
+ label = "prediction(at = list(cyl = 4)) matches predict()")
+
+ p2 <- prediction(m, at = list(cyl = c(4, 6)))
+ expect_true(inherits(p2, "data.frame"), label = "prediction(at = list(cyl = c(4, 6))) works")
+ expect_true(nrow(p2) == 2*nrow(mtcars), label = "prediction(at = list(cyl = c(4, 6))) works")
+ expect_true(all.equal(p2$fitted,
+ predict(m, rbind(within(mtcars, cyl <- 4), within(mtcars, cyl <- 6))),
+ check.attributes = FALSE),
+ label = "prediction(at = list(cyl = c(4, 6))) matches predict()")
+
+ p3 <- prediction(m, at = list(cyl = c(4, 6), wt = 2:3))
+ expect_true(inherits(p3, "data.frame"), label = "prediction(at = list(cyl = c(4, 6), wt = 2:3)) works")
+ expect_true(nrow(p3) == 4*nrow(mtcars), label = "prediction(at = list(cyl = c(4, 6), wt = 2:3)) works")
+
+ mtcars$cyl <- factor(mtcars$cyl)
+ expect_error(prediction(m, at = list(cyl = 3)), label = "prediction(at = list(cyl = 3)) errors")
+})
+
+context("Test behavior of 'prediction' class methods")
+test_that("Test print()", {
+ expect_true(inherits(print(prediction(lm(mpg ~ cyl, data = mtcars), data = mtcars)), "data.frame"),
+ label = "print() works with numeric outcome")
+ expect_true(inherits(print(prediction(lm(mpg ~ cyl, data = mtcars), data = mtcars, at = list(cyl = c(4,6,8)))), "data.frame"),
+ label = "print() works with numeric outcome and at()")
+})
+
+test_that("Test summary() w/o at()", {
+ m1 <- lm(mpg ~ cyl, data = mtcars)
+
+ # prediction w/o at()
+ p1 <- prediction(m1)
+ s1 <- summary(p1)
+ expect_true(inherits(summary(p1), "data.frame"),
+ label = "summary() works with numeric outcome")
+ expect_true(all(c("Prediction", "SE", "z", "p", "lower", "upper") %in% names(s1)),
+ label = "summary() has correct columns w/o at()")
+ expect_true(nrow(s1) == 1L, label = "summary() has correct rows w/o at()")
+
+ ## numerical correctness
+ expect_true(all.equal(s1[["Prediction"]][1L], mean(predict(m1)), tolerance = tol),
+ label = "summary() returns numerically correct mean prediction")
+ test_se <- sqrt(colMeans(cbind(1, mtcars$cyl)) %*% vcov(m1) %*% colMeans(cbind(1, mtcars$cyl)))[1,1,drop=TRUE]
+ expect_true(all.equal(s1[["SE"]][1L], test_se, tolerance = tol),
+ label = "summary() returns numerically correct SE of mean prediction")
+})
+
+test_that("Test summary() w at()", {
+ # prediction w/ at()
+ m1 <- lm(mpg ~ cyl, data = mtcars)
+ p2 <- prediction(m1, data = mtcars, at = list(cyl = c(4,6,8)))
+ s2 <- summary(p2)
+ expect_true(inherits(s2, "data.frame"),
+ label = "summary() works with numeric outcome and at()")
+ expect_true(all(c("at(cyl)", "Prediction", "SE", "z", "p", "lower", "upper") %in% names(s2)),
+ label = "summary() has correct columns with at()")
+ expect_true(nrow(s2) == 3L, label = "summary() has correct rows w/o at()")
+
+ ## numerical correctness
+ expect_true(all.equal(s2[["Prediction"]][1L], mean(predict(m1, newdata = within(mtcars, cyl <- 4))), tolerance = tol),
+ label = "summary() returns numerically correct mean prediction with at()")
+ test_se <- sqrt(colMeans(cbind(1, 4)) %*% vcov(m1) %*% colMeans(cbind(1, 4)))[1,1,drop=TRUE]
+ expect_true(all.equal(s2[["SE"]][1L], test_se, tolerance = tol),
+ label = "summary() returns numerically correct SE of mean prediction with at()")
+})
+
+test_that("Test prediction_summary()", {
+ m1 <- lm(mpg ~ cyl, data = mtcars)
+ p1 <- prediction(m1)
+ s1 <- summary(p1)
+ expect_true(identical(s1, prediction_summary(m1)), label = "prediction_summary() is correct")
+})
+
+test_that("Test head() and tail()", {
+ p1 <- prediction(lm(mpg ~ cyl, data = mtcars), data = mtcars)
+ expect_true(inherits(head(p1), "data.frame"), label = "head() works")
+ expect_true(nrow(head(p1, 5L)) == 5L, label = "head() has correct rows")
+ expect_true(inherits(tail(p1), "data.frame"), label = "tail() works")
+ expect_true(nrow(tail(p1, 5L)) == 5L, label = "tail() has correct rows")
+})
+
+context("Test utilities")
+test_that("Test seq_range()", {
+ expect_true(identical(range(mtcars$wt), seq_range(mtcars$wt, 2)), label = "seq_range() is correct")
+ expect_true(length(seq_range(mtcars$wt, 5)) == 5, label = "seq_range() length is correct")
+})
+
+test_that("Test mean_or_mode()/median_or_mode()", {
+ expect_true(mean_or_mode(mtcars$wt) == mean(mtcars$wt), label = "mean_or_mode.numeric() is correct")
+ expect_true(median_or_mode(mtcars$wt) == median(mtcars$wt), label = "median_or_mode.numeric() is correct")
+
+ mtcars$cyl <- factor(mtcars$cyl)
+ expect_true(mean_or_mode(mtcars$cyl) == 8, label = "mean_or_mode.default() is correct")
+ expect_true(median_or_mode(mtcars$cyl) == 8, label = "mean_or_mode.default() is correct")
+
+ expect_true(identical(mean_or_mode(mtcars), lapply(mtcars, mean_or_mode)), label = "mean_or_mode.data.frame() is correct")
+ expect_true(identical(median_or_mode(mtcars), lapply(mtcars, median_or_mode)), label = "median_or_mode.data.frame() is correct")
+})
diff --git a/tests/testthat/tests-find_data.R b/tests/testthat/tests-find_data.R
index 4fdf09b..ddb717b 100644
--- a/tests/testthat/tests-find_data.R
+++ b/tests/testthat/tests-find_data.R
@@ -1,94 +1,106 @@
-library("datasets")
-
-context("Test `find_data()` behavior")
-
-test_that("Test find_data.default()", {
- expect_true(inherits(find_data(lm(mpg ~ cyl, data = mtcars)), "data.frame"), label = "find_data.default() works")
-
- m1 <- lm(mpg ~ cyl, data = mtcars, subset = am == 1)
- expect_true(nrow(find_data(m1)) == nrow(mtcars[mtcars$am == 1, ]), label = "find_data.default(data, subset) works")
-
- mtcars2 <- mtcars
- mtcars2[1:3,] <- NA_real_
-
- m2 <- lm(mpg ~ cyl, data = mtcars2)
- expect_true(nrow(find_data(m2)) == nrow(mtcars2[-c(1:3), ]), label = "find_data.default(data, na.action) works")
-
- m3 <- lm(mpg ~ cyl, data = mtcars2, subset = am == 1)
- expect_true(nrow(find_data(m3)) == nrow(na.omit(mtcars2[mtcars2$am == 1, ])), label = "find_data.default(data, subset, na.action) works")
-
- expect_error(find_data(StructTS(log10(UKgas), type = "BSM")), label = "find_data.default([no formula]) errors")
-})
-
-test_that("Test find_data.lm()", {
- expect_true(inherits(find_data(lm(mpg ~ cyl, data = mtcars)), "data.frame"), label = "find_data.lm() works")
-})
-
-test_that("Test find_data.glm()", {
- expect_true(inherits(find_data(glm(mpg ~ cyl, data = mtcars)), "data.frame"), label = "find_data.glm() works")
-})
-
-test_that("Test find_data.data.frame()", {
- expect_true(inherits(find_data(mtcars), "data.frame"), label = "find_data.data.frame() works")
-})
-
-test_that("Test find_data.lm() and prediction.lm() with missing data", {
- mtcars2 <- mtcars
- mtcars2$mpg[1:4] <- NA_real_
-
- # na.omit
- m1 <- lm(mpg ~ cyl, data = mtcars2, na.action = na.omit)
- expect_true(identical(dim(find_data(m1)), dim(na.omit(mtcars2))),
- label = "find_data.lm() drops missing data when 'na.action = na.omit'")
- expect_true(nrow(prediction(m1)) == nrow(na.omit(mtcars2)),
- label = "prediction.lm() returns correct rows when 'na.action = na.omit'")
-
- # na.exclude
- m2 <- lm(mpg ~ cyl, data = mtcars2, na.action = na.exclude)
- expect_true(identical(dim(find_data(m2)), dim(na.omit(mtcars2))),
- label = "find_data.lm() drops missing data when 'na.action = na.exclude'")
- expect_true(nrow(prediction(m2)) == nrow(na.omit(mtcars2)),
- label = "prediction.lm() returns correct rows when 'na.action = na.exclude'")
-
- # prediction with missing data passed explicitly
- m3 <- lm(mpg ~ cyl, data = mtcars) # missing outcome
- p3 <- prediction(m3, mtcars2, na.action = na.pass)
- expect_true(nrow(p3) == nrow(mtcars),
- label = "prediction.lm() returns correct rows when prediction(na.action = na.pass) for missing outcome")
- expect_true(all(!is.na(p3$fitted)[1:4]),
- label = "prediction.lm() returns numeric predictions when prediction(na.action = na.pass) for missing outcome")
- expect_true(nrow(prediction(m3, mtcars2, na.action = na.omit)) == nrow(mtcars2),
- label = "prediction.lm() returns correct rows when prediction(na.action = na.omit) for missing outcome")
- expect_true(nrow(prediction(m3, mtcars2, na.action = na.exclude)) == nrow(mtcars2),
- label = "prediction.lm() returns correct rows when prediction(na.action = na.exclude) for missing outcome")
-
- m4 <- lm(cyl ~ mpg, data = mtcars) # missing covariate
- p4 <- prediction(m4, mtcars2, na.action = na.pass)
- expect_true(nrow(p4) == nrow(mtcars),
- label = "prediction.lm() returns correct rows when prediction(na.action = na.pass) for missing covariate")
- expect_true(all(is.na(p4$fitted)[1:4]),
- label = "prediction.lm() returns NA predictions when prediction(na.action = na.pass) for missing covariate")
- expect_error(prediction(m4, mtcars2, na.action = na.omit),
- label = "prediction.lm() fails when prediction(na.action = na.omit) for missing covariate")
- expect_error(prediction(m4, mtcars2, na.action = na.exclude),
- label = "prediction.lm() fails when prediction(na.action = na.exclude) for missing covariate")
-
- rm(mtcars2)
-})
-
-test_that("Test find_data.lm() with subsetted data", {
- mtcars2 <- mtcars
- mtcars2$mpg[1:4] <- NA_real_
- m1 <- lm(mpg ~ cyl, data = mtcars2, subset = !is.na(mpg))
- expect_true(identical(dim(find_data(m1)), dim(na.omit(mtcars2))),
- label = "find_data.lm() has correct dimensions when subsetting")
- expect_true(nrow(prediction(m1)) == nrow(na.omit(mtcars2)),
- label = "prediction.lm() returns correct rows when subsetting")
- x <- c(rep(TRUE, 30), FALSE, FALSE)
- m2 <- lm(mpg ~ cyl, data = mtcars2, subset = x)
- expect_true(identical(nrow(find_data(m2)), nrow(na.omit(mtcars2))-2L),
- label = "find_data.lm() subsets correctly when subsetting variable is global")
- expect_true(identical(rownames(find_data(m2)), head(rownames(na.omit(mtcars2)), 26)),
- label = "find_data.lm() returns correct rows when subsetting and missing data are present")
- rm(mtcars2)
-})
+library("datasets")
+
+context("Test `find_data()` behavior")
+
+test_that("Test find_data.default()", {
+ expect_true(inherits(find_data(lm(mpg ~ cyl, data = mtcars)), "data.frame"), label = "find_data.default() works")
+
+ m1 <- lm(mpg ~ cyl, data = mtcars, subset = am == 1)
+ expect_true(nrow(find_data(m1)) == nrow(mtcars[mtcars$am == 1, ]), label = "find_data.default(data, subset) works")
+
+ mtcars2 <- mtcars
+ mtcars2[1:3,] <- NA_real_
+
+ m2 <- lm(mpg ~ cyl, data = mtcars2)
+ expect_true(nrow(find_data(m2)) == nrow(mtcars2[-c(1:3), ]), label = "find_data.default(data, na.action) works")
+
+ m3 <- lm(mpg ~ cyl, data = mtcars2, subset = am == 1)
+ expect_true(nrow(find_data(m3)) == nrow(na.omit(mtcars2[mtcars2$am == 1, ])), label = "find_data.default(data, subset, na.action) works")
+
+ expect_error(find_data(StructTS(log10(UKgas), type = "BSM")), label = "find_data.default([no formula]) errors")
+})
+
+test_that("Test find_data.lm()", {
+ expect_true(inherits(find_data(lm(mpg ~ cyl, data = mtcars)), "data.frame"), label = "find_data.lm() works")
+})
+
+test_that("Test find_data.glm()", {
+ expect_true(inherits(find_data(glm(mpg ~ cyl, data = mtcars)), "data.frame"), label = "find_data.glm() works")
+})
+
+test_that("Test find_data.data.frame()", {
+ expect_true(inherits(find_data(mtcars), "data.frame"), label = "find_data.data.frame() works")
+})
+
+test_that("Test find_data.lm() and prediction.lm() with missing data", {
+ mtcars2 <- mtcars
+ mtcars2$mpg[1:4] <- NA_real_
+
+ # na.omit
+ m1 <- lm(mpg ~ cyl, data = mtcars2, na.action = na.omit)
+ expect_true(identical(dim(find_data(m1)), dim(na.omit(mtcars2))),
+ label = "find_data.lm() drops missing data when 'na.action = na.omit'")
+ expect_true(nrow(prediction(m1)) == nrow(na.omit(mtcars2)),
+ label = "prediction.lm() returns correct rows when 'na.action = na.omit'")
+
+ # na.exclude
+ m2 <- lm(mpg ~ cyl, data = mtcars2, na.action = na.exclude)
+ expect_true(identical(dim(find_data(m2)), dim(na.omit(mtcars2))),
+ label = "find_data.lm() drops missing data when 'na.action = na.exclude'")
+ expect_true(nrow(prediction(m2)) == nrow(na.omit(mtcars2)),
+ label = "prediction.lm() returns correct rows when 'na.action = na.exclude'")
+
+ # prediction with missing data passed explicitly
+ m3 <- lm(mpg ~ cyl, data = mtcars) # missing outcome
+ p3 <- prediction(m3, mtcars2, na.action = na.pass)
+ expect_true(nrow(p3) == nrow(mtcars),
+ label = "prediction.lm() returns correct rows when prediction(na.action = na.pass) for missing outcome")
+ expect_true(all(!is.na(p3$fitted)[1:4]),
+ label = "prediction.lm() returns numeric predictions when prediction(na.action = na.pass) for missing outcome")
+ expect_true(nrow(prediction(m3, mtcars2, na.action = na.omit)) == nrow(mtcars2),
+ label = "prediction.lm() returns correct rows when prediction(na.action = na.omit) for missing outcome")
+ expect_true(nrow(prediction(m3, mtcars2, na.action = na.exclude)) == nrow(mtcars2),
+ label = "prediction.lm() returns correct rows when prediction(na.action = na.exclude) for missing outcome")
+
+ m4 <- lm(cyl ~ mpg, data = mtcars) # missing covariate
+ p4 <- prediction(m4, mtcars2, na.action = na.pass)
+ expect_true(nrow(p4) == nrow(mtcars),
+ label = "prediction.lm() returns correct rows when prediction(na.action = na.pass) for missing covariate")
+ expect_true(all(is.na(p4$fitted)[1:4]),
+ label = "prediction.lm() returns NA predictions when prediction(na.action = na.pass) for missing covariate")
+ expect_error(prediction(m4, mtcars2, na.action = na.omit),
+ label = "prediction.lm() fails when prediction(na.action = na.omit) for missing covariate")
+ expect_error(prediction(m4, mtcars2, na.action = na.exclude),
+ label = "prediction.lm() fails when prediction(na.action = na.exclude) for missing covariate")
+
+ rm(mtcars2)
+})
+
+test_that("Test find_data.lm() with subsetted data", {
+ mtcars2 <- mtcars
+ mtcars2$mpg[1:4] <- NA_real_
+ m1 <- lm(mpg ~ cyl, data = mtcars2, subset = !is.na(mpg))
+ expect_true(identical(dim(find_data(m1)), dim(na.omit(mtcars2))),
+ label = "find_data.lm() has correct dimensions when subsetting")
+ expect_true(nrow(prediction(m1)) == nrow(na.omit(mtcars2)),
+ label = "prediction.lm() returns correct rows when subsetting")
+ x <- c(rep(TRUE, 30), FALSE, FALSE)
+ m2 <- lm(mpg ~ cyl, data = mtcars2, subset = x)
+ expect_true(identical(nrow(find_data(m2)), nrow(na.omit(mtcars2))-2L),
+ label = "find_data.lm() subsets correctly when subsetting variable is global")
+ expect_true(identical(rownames(find_data(m2)), head(rownames(na.omit(mtcars2)), 26)),
+ label = "find_data.lm() returns correct rows when subsetting and missing data are present")
+ rm(mtcars2)
+})
+
+test_that("Test find_data.lm() with subsetted data", {
+ skip_if_not_installed("survey")
+ library("survey")
+ data(api)
+ dstrat <- svydesign(id=~1, strata=~stype, weights=~pw, data=apistrat, fpc=~fpc)
+ m <- svyglm(growth ~ target, dstrat)
+ f <- find_data(m, design = dstrat)
+
+ expect_true(identical(nrow(f), length(predict(m))), label = "Survey design model has correct rows")
+ expect_true(identical(nrow(prediction(m)), length(predict(m))), label = "Survey design model has correct rows")
+})
diff --git a/tests/testthat/tests-methods.R b/tests/testthat/tests-methods.R
index 8eb1a1a..49b7542 100644
--- a/tests/testthat/tests-methods.R
+++ b/tests/testthat/tests-methods.R
@@ -1,605 +1,605 @@
-# test all prediction() methods, conditional on availability of package
-# this file is organized alphabetically by package name
-
-library("datasets")
-
-context("Test `prediction()` methods, conditional on package availability")
-
-if (require("AER", quietly = TRUE)) {
- test_that("Test prediction() for 'ivreg'", {
- data("CigarettesSW", package = "AER")
- CigarettesSW$rprice <- with(CigarettesSW, price/cpi)
- CigarettesSW$rincome <- with(CigarettesSW, income/population/cpi)
- CigarettesSW$tdiff <- with(CigarettesSW, (taxs - tax)/cpi)
- m <- AER::ivreg(log(packs) ~ log(rprice) + log(rincome) | log(rincome) + tdiff + I(tax/cpi),
- data = CigarettesSW, subset = year == "1995")
- p <- prediction(m)
- expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
- expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
- })
- test_that("Test prediction() for 'tobit'", {
- data("Affairs", package = "AER")
- m <- tobit(affairs ~ age + yearsmarried + religiousness + occupation + rating, data = Affairs)
- p <- prediction(m)
- expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
- expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
- })
-}
-
-if (require("aod", quietly = TRUE)) {
- test_that("Test prediction() for 'glimML'", {
- data("orob2", package = "aod")
- m <- aod::betabin(cbind(y, n - y) ~ seed, ~ 1, data = orob2)
- p <- prediction(m)
- expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
- expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
- })
- test_that("Test prediction() for 'glimQL'", {
- data("orob2", package = "aod")
- m <- aod::quasibin(cbind(y, n - y) ~ seed * root, data = orob2, phi = 0)
- p <- prediction(m)
- expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
- expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
- })
-}
-
-if (require("betareg", quietly = TRUE)) {
- test_that("Test prediction() for 'betareg'", {
- data("GasolineYield", package = "betareg")
- m <- betareg::betareg(yield ~ batch + temp, data = GasolineYield)
- p <- prediction(m)
- expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
- expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
- })
-}
-
-if (require("biglm", quietly = TRUE)) {
- test_that("Test prediction() for 'biglm'", {
- data("trees", package = "datasets")
- m <- biglm::biglm(log(Volume) ~ log(Girth) + log(Height), data=trees)
- p <- prediction(m, calculate_se = FALSE) # temporary, while bug fixed upstream
- expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
- expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
- })
- #test_that("Test prediction() for 'bigglm'", {
- # data("trees", package = "datasets")
- # m <- biglm::bigglm(log(Volume) ~ log(Girth) + log(Height), data=trees, chunksize=10)
- # p <- prediction(m, calculate_se = FALSE) # temporary, while bug fixed upstream
- # expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
- # expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
- #})
-}
-
-if (require("brglm", quietly = TRUE)) {
- test_that("Test prediction() for 'brglm'", {
- data("lizards", package = "brglm")
- m <- brglm::brglm(cbind(grahami, opalinus) ~ height + diameter +
- light + time, family = binomial(logit), data=lizards,
- method = "brglm.fit")
- p <- prediction(m)
- expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
- expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
- })
-}
-
-if (require("caret", quietly = TRUE)) {
- test_that("Test prediction() for 'knnreg'", {
- data("BloodBrain", package = "caret")
- inTrain <- createDataPartition(logBBB, p = .8)[[1]]
- trainX <- bbbDescr[inTrain,]
- trainY <- logBBB[inTrain]
- testX <- bbbDescr[-inTrain,]
- m <- knnreg(trainX, trainY, k = 3)
- p <- prediction(m, data = testX)
- expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
- expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
- })
- test_that("Test prediction() for 'train'", {
- data("iris", package = "datasets")
- m <- train(Sepal.Length ~ ., data = iris, method = "lm")
- p <- prediction(m, data = iris)
- expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
- expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
- })
-}
-
-if (require("crch", quietly = TRUE)) {
- test_that("Test prediction() for 'crch'", {
- e <- new.env()
- data("RainIbk", package = "crch", envir = e)
- RainIbk <- e$RainIbk
- RainIbk$sqrtensmean <- apply(sqrt(RainIbk[,grep('^rainfc',names(RainIbk))]), 1, mean)
- m <- crch::crch(sqrt(rain) ~ sqrtensmean, data = RainIbk, dist = "gaussian", left = 0)
- p <- prediction(m, data = RainIbk)
- expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
- expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
- })
- test_that("Test prediction() for 'hxlr'", {
- data("RainIbk", package = "crch")
- RainIbk$sqrtensmean <- apply(sqrt(RainIbk[,grep('^rainfc',names(RainIbk))]), 1, mean)
- q <- unique(quantile(RainIbk$rain, seq(0.1, 0.9, 0.1)))
- m <- crch::hxlr(sqrt(rain) ~ sqrtensmean, data = RainIbk, thresholds = sqrt(q))
- expect_true(inherits(prediction(m, data = RainIbk), "prediction"))
- })
-}
-
-if (require("e1071", quietly = TRUE)) {
- test_that("Test prediction() for 'naiveBayes'", {
- data("Titanic")
- m <- e1071::naiveBayes(Survived ~ ., data = Titanic)
- p <- prediction(m)
- expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
- expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
- })
- test_that("Test prediction() for 'svm'", {
- m <- e1071::svm(Species ~ ., data = iris)
- p <- prediction(m)
- expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
- expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
- })
-}
-
-if (require("earth", quietly = TRUE)) {
- test_that("Test prediction() for 'earth'", {
- data("trees", package = "datasets")
- m <- earth::earth(Volume ~ ., data = trees)
- p <- prediction(m)
- expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
- expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
- })
-}
-
-if (require("ffbase", quietly = TRUE)) {
- test_that("Test prediction() for 'biglm' w/ 'ffbase' backend", {
- stopifnot(require("ff"))
- stopifnot(require("biglm"))
- data("trees", package = "datasets")
- x <- ff::as.ffdf(trees)
- m <- biglm::biglm(log(Volume)~log(Girth)+log(Height), data=x)
- p <- prediction(m, calculate_se = FALSE) # temporary, while bug fixed upstream
- expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
- expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
- })
-}
-
-if (require("gam", quietly = TRUE)) {
- test_that("Test prediction() for 'Gam'", {
- data("gam.data", package = "gam")
- m <- gam::gam(y ~ gam::s(x,6) + z,data=gam.data)
- p <- prediction(m)
- expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
- expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
- })
-}
-
-if (require("gee", quietly = TRUE)) {
- test_that("Test prediction() for 'gee'", {
- data("warpbreaks")
- m <- gee::gee(breaks ~ tension, id=wool, data=warpbreaks, corstr="exchangeable")
- p <- prediction(m)
- expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
- expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
- })
-}
-
-if (require("glmnet", quietly = TRUE)) {
- test_that("Test prediction() for 'glmnet'", {
- x <- matrix(rnorm(100*20),100,20)
- y <- rnorm(100)
- m <- glmnet::glmnet(x,y)
- p <- prediction(m, data = x)
- expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
- expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
- })
-}
-
-if (require("glmx", quietly = TRUE) ) {
- test_that("Test prediction() for 'glmx()'", {
- d <- data.frame(x = runif(200, -1, 1))
- d$y <- rnbinom(200, mu = exp(0 + 3 * d$x), size = 1)
- m <- glmx::glmx(y ~ x, data = d, family = MASS::negative.binomial, xlink = "log", xstart = 0)
- p <- prediction(m)
- expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
- expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
- })
- test_that("Test prediction() for 'hetglm()'", {
- n <- 200
- x <- rnorm(n)
- ystar <- 1 + x + rnorm(n, sd = exp(x))
- y <- factor(ystar > 0)
- m <- glmx::hetglm(y ~ x | 1)
- p <- prediction(m)
- expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
- expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
- })
-}
-
-if (require("kernlab", quietly = TRUE)) {
- require("methods", quietly = TRUE)
- test_that("Test prediction() for 'gausspr'", {
- data("promotergene", package = "kernlab")
- ind <- sample(1:dim(promotergene)[1],20)
- genetrain <- promotergene[-ind, ]
- genetest <- promotergene[ind, ]
- m <- kernlab::gausspr(Class~., data = genetrain, kernel = "rbfdot",
- kpar = list(sigma = 0.015))
- p <- prediction(m, data = genetrain)
- expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
- expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
- })
- test_that("Test prediction() for 'kqr'", {
- x <- sort(runif(300))
- y <- sin(pi*x) + rnorm(300,0,sd=exp(sin(2*pi*x)))
- m <- kernlab::kqr(x, y, tau = 0.5, C=0.15)
- p <- prediction(m)
- expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
- expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
- })
- test_that("Test prediction() for 'ksvm'", {
- data("promotergene", package = "kernlab")
- ind <- sample(1:dim(promotergene)[1],20)
- genetrain <- promotergene[-ind, ]
- genetest <- promotergene[ind, ]
- m <- kernlab::ksvm(Class~., data = genetrain, kernel = "rbfdot",
- kpar = list(sigma = 0.015), C = 70, cross = 4, prob.model = TRUE)
- p <- prediction(m, data = genetrain)
- expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
- expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
- })
-}
-
-if (require("lme4", quietly = TRUE)) {
- test_that("Test prediction() for 'merMod'", {
- data("cbpp", package = "lme4")
- m <- lme4::glmer(cbind(incidence, size - incidence) ~ period + (1 |herd), cbpp, binomial)
- p <- prediction(m)
- expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
- expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
- })
-}
-
-if (require("MASS", quietly = TRUE)) {
- test_that("Test prediction() for 'glm.nb'", {
- data("quine", package = "MASS")
- m <- MASS::glm.nb(Days ~ Sex/(Age + Eth*Lrn), data = quine)
- p <- prediction(m)
- expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
- expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
- })
- test_that("Test prediction() for 'lda'", {
- data("iris3", package = "datasets")
- tr <- sample(1:50, 25)
- train <- rbind(iris3[tr,,1], iris3[tr,,2], iris3[tr,,3])
- cl <- factor(c(rep("s",25), rep("c",25), rep("v",25)))
- m <- MASS::lda(train, cl)
- p <- prediction(m, data = train)
- expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
- expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
- })
- test_that("Test prediction() for 'lqs'", {
- data("stackloss", package = "datasets")
- m <- MASS::lqs(stack.loss ~ ., data = stackloss, method = "S", nsamp = "exact")
- p <- prediction(m)
- expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
- expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
- })
- test_that("Test prediction() for 'mca'", {
- data("farms", package = "MASS")
- m <- MASS::mca(farms, abbrev=TRUE)
- p <- prediction(m)
- expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
- expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
- })
- test_that("Test prediction() for 'polr'", {
- data("housing", package = "MASS")
- m <- MASS::polr(Sat ~ Infl + Type + Cont, weights = Freq, data = housing)
- p <- prediction(m)
- expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
- expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
- })
- test_that("Test prediction() for 'qda'", {
- data("iris3", package = "datasets")
- tr <- sample(1:50, 25)
- train <- rbind(iris3[tr,,1], iris3[tr,,2], iris3[tr,,3])
- cl <- factor(c(rep("s",25), rep("c",25), rep("v",25)))
- m <- MASS::qda(train, cl)
- p <- prediction(m, data = train)
- expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
- expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
- })
- test_that("Test prediction() for 'rlm'", {
- data("stackloss", package = "datasets")
- m <- MASS::rlm(stack.loss ~ ., stackloss)
- p <- prediction(m)
- expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
- expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
- })
-}
-
-if (require("mclogit", quietly = TRUE)) {
- test_that("Test prediction() for 'mclogit'", {
- data("Transport", package = "mclogit")
- m <- mclogit::mclogit(cbind(resp,suburb)~distance+cost, data = Transport, trace = FALSE)
- p <- prediction(m)
- expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
- expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
- })
-}
-
-if (require("mda", quietly = TRUE)) {
- test_that("Test prediction() for 'bruto'", {
- data("trees", package = "datasets")
- m <- bruto(trees[,-3], trees[3])
- p <- prediction(m, data = NULL)
- expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
- expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
- })
- test_that("Test prediction() for 'fda'", {
- data("iris", package = "datasets")
- m <- fda(Species ~ ., data = iris)
- p <- prediction(m)
- expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
- expect_true(all(c("fitted", "se.fitted", "fitted.class") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
- })
- test_that("Test prediction() for 'mars'", {
- data("trees", package = "datasets")
- m <- mars(trees[,-3], trees[3])
- p <- prediction(m, data = NULL)
- expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
- expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
- })
- test_that("Test prediction() for 'mda'", {
- data("glass", package = "mda")
- m <- mda(Type ~ ., data = glass)
- p <- prediction(m)
- expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
- expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
- })
- test_that("Test prediction() for 'polyreg'", {
- data("iris", package = "datasets")
- m <- polyreg(iris[,2:3], iris$Sepal.Length)
- p <- prediction(m, data = NULL)
- expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
- expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
- })
-}
-
-#if (require("mnlogit", quietly = TRUE)) {
-# test_that("Test prediction() for 'mnlogit'", {
-# data("Fish", package = "mnlogit")
-# m <- mnlogit::mnlogit(mode ~ price | income | catch, Fish, ncores = 1)
-# p <- prediction(m)
-# expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
-# expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
-# })
-#}
-
-if (require("MNP", quietly = TRUE)) {
- test_that("Test prediction() for 'mnp'", {
- data("japan", package = "MNP")
- m <- MNP::mnp(cbind(LDP, NFP, SKG, JCP) ~ gender + education + age, data = head(japan, 100), verbose = FALSE)
- p <- prediction(m)
- expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
- expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
- })
-}
-
-if (require("nlme", quietly = TRUE)) {
- test_that("Test prediction() for 'gls'", {
- data("Ovary", package = "nlme")
- m <- nlme::gls(follicles ~ sin(2*pi*Time) + cos(2*pi*Time), Ovary,
- correlation = nlme::corAR1(form = ~ 1 | Mare), verbose = FALSE)
- p <- prediction(m)
- expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
- expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
- })
- test_that("Test prediction() for 'lme'", {
- data("Orthodont", package = "nlme")
- m <- nlme::lme(distance ~ age, Orthodont, random = ~ age | Subject)
- p <- prediction(m)
- expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
- expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
- })
-}
-
-if (require("nnet", quietly = TRUE)) {
- #test_that("Test prediction() for 'multinom'", { })
- test_that("Test prediction() for 'nnet'", {
- data("iris3", package = "datasets")
- ird <- data.frame(rbind(iris3[,,1], iris3[,,2], iris3[,,3]),
- species = factor(c(rep("s",50), rep("c", 50), rep("v", 50))))
- samp <- c(sample(1:50,25), sample(51:100,25), sample(101:150,25))
- m <- nnet::nnet(species ~ ., data = ird, subset = samp, size = 2, rang = 0.1,
- decay = 5e-4, maxit = 200, trace = FALSE)
- p <- prediction(m)
- expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
- expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
- })
-}
-
-if (require("ordinal", quietly = TRUE)) {
- test_that("Test prediction() for 'clm'", {
- data("wine", package = "ordinal")
- m <- ordinal::clm(rating ~ temp * contact, data = wine)
- p <- prediction(m)
- expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
- expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
- })
-}
-
-if (require("plm", quietly = TRUE)) {
- test_that("Test prediction() for 'plm'", {
- data("Grunfeld", package = "plm")
- m <- plm::plm(inv ~ value + capital, data = Grunfeld, model = "pooling")
- p <- prediction(m)
- expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
- expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
- })
-}
-
-if (require("pscl", quietly = TRUE)) {
- test_that("Test prediction() for 'hurdle'", {
- data("bioChemists", package = "pscl")
- m <- pscl::hurdle(art ~ ., data = bioChemists)
- p <- prediction(m)
- expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
- expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
- })
- test_that("Test prediction() for 'zeroinfl'", {
- data("bioChemists", package = "pscl")
- m <- pscl::zeroinfl(art ~ ., data = bioChemists)
- p <- prediction(m)
- expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
- expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
- })
- #test_that("Test prediction() for 'ideal'", {
- # expect_true(inherits(prediction(m), "prediction"))
- #})
-}
-
-if (require("quantreg", quietly = TRUE)) {
- test_that("Test prediction() for 'rq'", {
- data("stackloss", package = "datasets")
- m <- quantreg::rq(stack.loss ~ stack.x, tau = .5, data = stackloss)
- p <- prediction(m)
- expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
- expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
- })
-}
-
-if (require("rpart", quietly = TRUE)) {
- test_that("Test prediction() for 'rpart'", {
- data("kyphosis", package = "rpart")
- m <- rpart::rpart(Kyphosis ~ Age + Number + Start, data = kyphosis)
- p <- prediction(m)
- expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
- expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
- })
-}
-
-if (require("sampleSelection", quietly = TRUE)) {
- test_that("Test prediction() for 'selection'", {
- data("Mroz87", package = "sampleSelection")
- Mroz87$kids <- (Mroz87$kids5 + Mroz87$kids618 > 0)
- m <- sampleSelection::heckit(lfp ~ age + I( age^2 ) + faminc + kids + educ,
- wage ~ exper + I( exper^2 ) + educ + city, Mroz87)
- p <- prediction(m)
- expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
- expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
- })
-}
-
-if (require("speedglm", quietly = TRUE) ) {
- test_that("Test prediction() for 'speedglm()'", {
- n <- 1000
- k <- 3
- y <- rnorm(n)
- x <- round(matrix(rnorm(n * k), n, k), digits = 3)
- colnames(x) <- c("s1", "s2", "s3")
- da <- data.frame(y, x)
- m <- speedglm(y ~ s1 + s2 + s3, data = da)
- p <- prediction(m)
- expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
- expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
- })
- test_that("Test prediction() for 'speedlm()'", {
- n <- 1000
- k <- 3
- y <- rnorm(n)
- x <- round(matrix(rnorm(n * k), n, k), digits = 3)
- colnames(x) <- c("s1", "s2", "s3")
- da <- data.frame(y, x)
- m <- speedlm(y ~ s1 + s2 + s3, data = da)
- p <- prediction(m)
- expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
- expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
- })
-}
-
-if (require("stats", quietly = TRUE)) {
- test_that("Test prediction() for 'ar'", {
- data("sunspot.year", package = "datasets")
- m <- stats::ar(sunspot.year)
- p <- prediction(m, data = sunspot.year)
- expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
- expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
- })
- test_that("Test prediction() for 'Arima'", {
- expect_true(inherits(prediction(stats::arima(lh, order = c(3,0,0)), n.ahead = 12), "prediction"))
- })
- test_that("Test prediction() for 'arima0'", {
- m <- stats::arima0(lh, order = c(1,0,1))
- expect_true(inherits(prediction(m, data = lh, n.ahead = 12), "prediction"))
- })
- test_that("Test prediction() for 'loess'", {
- m <- stats::loess(dist ~ speed, cars)
- p <- prediction(m)
- expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
- expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
- })
- test_that("Test prediction() for 'nls'", {
- m <- stats::nls(demand ~ SSasympOrig(Time, A, lrc), data = BOD)
- p <- prediction(m)
- expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
- expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
- })
- test_that("Test prediction() for 'ppr'", {
- data("rock", package = "datasets")
- rock$area1 <- rock$area/10000
- rock$peri1 <- rock$peri/10000
- m <- stats::ppr(log(perm) ~ area1 + peri1 + shape,
- data = rock, nterms = 2, max.terms = 5)
- p <- prediction(m)
- expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
- expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
- })
- test_that("Test prediction() for 'princomp'", {
- data("USArrests", package = "datasets")
- m <- stats::princomp(~ ., data = USArrests, cor = TRUE)
- p <- prediction(m)
- expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
- expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
- })
-}
-
-if (require("survey", quietly = TRUE)) {
- test_that("Test prediction() for 'svyglm'", {
- data("api", package = "survey")
- dstrat <- survey::svydesign(id=~1,strata=~stype, weights=~pw, data=apistrat, fpc=~fpc)
- m <- survey::svyglm(api.stu~enroll, design=dstrat)
- p <- prediction(m)
- expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
- expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
- })
-}
-
-if (require("survival", quietly = TRUE)) {
- test_that("Test prediction() for 'coxph'", {
- test1 <- list(time=c(4,3,1,1,2,2,3),
- status=c(1,1,1,0,1,1,0),
- x=c(0,2,1,1,1,0,0),
- sex=c(0,0,0,0,1,1,1))
- m <- survival::coxph(survival::Surv(time, status) ~ x + survival::strata(sex), test1)
- p <- prediction(m)
- expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
- expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
- })
- test_that("Test prediction() for 'survreg'", {
- data("ovarian", package = "survival")
- m <- survival::survreg(survival::Surv(futime, fustat) ~ ecog.ps + rx, ovarian, dist='weibull', scale=1)
- p <- prediction(m)
- expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
- expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
- })
-}
-
-if (require("truncreg", quietly = TRUE)) {
- test_that("Test prediction() for 'truncreg'", {
- data("tobin", package = "survival")
- m <- truncreg::truncreg(durable ~ age + quant, data = tobin, subset = durable > 0)
- p <- prediction(m)
- expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
- expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
- })
-}
-
+# test all prediction() methods, conditional on availability of package
+# this file is organized alphabetically by package name
+
+library("datasets")
+
+context("Test `prediction()` methods, conditional on package availability")
+
+if (require("AER", quietly = TRUE)) {
+ test_that("Test prediction() for 'ivreg'", {
+ data("CigarettesSW", package = "AER")
+ CigarettesSW$rprice <- with(CigarettesSW, price/cpi)
+ CigarettesSW$rincome <- with(CigarettesSW, income/population/cpi)
+ CigarettesSW$tdiff <- with(CigarettesSW, (taxs - tax)/cpi)
+ m <- AER::ivreg(log(packs) ~ log(rprice) + log(rincome) | log(rincome) + tdiff + I(tax/cpi),
+ data = CigarettesSW, subset = year == "1995")
+ p <- prediction(m)
+ expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
+ expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
+ })
+ test_that("Test prediction() for 'tobit'", {
+ data("Affairs", package = "AER")
+ m <- tobit(affairs ~ age + yearsmarried + religiousness + occupation + rating, data = Affairs)
+ p <- prediction(m)
+ expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
+ expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
+ })
+}
+
+if (require("aod", quietly = TRUE)) {
+ test_that("Test prediction() for 'glimML'", {
+ data("orob2", package = "aod")
+ m <- aod::betabin(cbind(y, n - y) ~ seed, ~ 1, data = orob2)
+ p <- prediction(m)
+ expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
+ expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
+ })
+ test_that("Test prediction() for 'glimQL'", {
+ data("orob2", package = "aod")
+ m <- aod::quasibin(cbind(y, n - y) ~ seed * root, data = orob2, phi = 0)
+ p <- prediction(m)
+ expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
+ expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
+ })
+}
+
+if (require("betareg", quietly = TRUE)) {
+ test_that("Test prediction() for 'betareg'", {
+ data("GasolineYield", package = "betareg")
+ m <- betareg::betareg(yield ~ batch + temp, data = GasolineYield)
+ p <- prediction(m)
+ expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
+ expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
+ })
+}
+
+if (require("biglm", quietly = TRUE)) {
+ test_that("Test prediction() for 'biglm'", {
+ data("trees", package = "datasets")
+ m <- biglm::biglm(log(Volume) ~ log(Girth) + log(Height), data=trees)
+ p <- prediction(m, calculate_se = FALSE) # temporary, while bug fixed upstream
+ expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
+ expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
+ })
+ #test_that("Test prediction() for 'bigglm'", {
+ # data("trees", package = "datasets")
+ # m <- biglm::bigglm(log(Volume) ~ log(Girth) + log(Height), data=trees, chunksize=10)
+ # p <- prediction(m, calculate_se = FALSE) # temporary, while bug fixed upstream
+ # expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
+ # expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
+ #})
+}
+
+if (require("brglm", quietly = TRUE)) {
+ test_that("Test prediction() for 'brglm'", {
+ data("lizards", package = "brglm")
+ m <- brglm::brglm(cbind(grahami, opalinus) ~ height + diameter +
+ light + time, family = binomial(logit), data=lizards,
+ method = "brglm.fit")
+ p <- prediction(m)
+ expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
+ expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
+ })
+}
+
+if (require("caret", quietly = TRUE)) {
+ test_that("Test prediction() for 'knnreg'", {
+ data("BloodBrain", package = "caret")
+ inTrain <- createDataPartition(logBBB, p = .8)[[1]]
+ trainX <- bbbDescr[inTrain,]
+ trainY <- logBBB[inTrain]
+ testX <- bbbDescr[-inTrain,]
+ m <- knnreg(trainX, trainY, k = 3)
+ p <- prediction(m, data = testX)
+ expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
+ expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
+ })
+ test_that("Test prediction() for 'train'", {
+ data("iris", package = "datasets")
+ m <- train(Sepal.Length ~ ., data = iris, method = "lm")
+ p <- prediction(m, data = iris)
+ expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
+ expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
+ })
+}
+
+if (require("crch", quietly = TRUE)) {
+ test_that("Test prediction() for 'crch'", {
+ e <- new.env()
+ data("RainIbk", package = "crch", envir = e)
+ RainIbk <- e$RainIbk
+ RainIbk$sqrtensmean <- apply(sqrt(RainIbk[,grep('^rainfc',names(RainIbk))]), 1, mean)
+ m <- crch::crch(sqrt(rain) ~ sqrtensmean, data = RainIbk, dist = "gaussian", left = 0)
+ p <- prediction(m, data = RainIbk)
+ expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
+ expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
+ })
+ test_that("Test prediction() for 'hxlr'", {
+ data("RainIbk", package = "crch")
+ RainIbk$sqrtensmean <- apply(sqrt(RainIbk[,grep('^rainfc',names(RainIbk))]), 1, mean)
+ q <- unique(quantile(RainIbk$rain, seq(0.1, 0.9, 0.1)))
+ m <- crch::hxlr(sqrt(rain) ~ sqrtensmean, data = RainIbk, thresholds = sqrt(q))
+ expect_true(inherits(prediction(m, data = RainIbk), "prediction"))
+ })
+}
+
+if (require("e1071", quietly = TRUE)) {
+ test_that("Test prediction() for 'naiveBayes'", {
+ data("Titanic")
+ m <- e1071::naiveBayes(Survived ~ ., data = Titanic)
+ p <- prediction(m)
+ expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
+ expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
+ })
+ test_that("Test prediction() for 'svm'", {
+ m <- e1071::svm(Species ~ ., data = iris)
+ p <- prediction(m)
+ expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
+ expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
+ })
+}
+
+if (require("earth", quietly = TRUE)) {
+ test_that("Test prediction() for 'earth'", {
+ data("trees", package = "datasets")
+ m <- earth::earth(Volume ~ ., data = trees)
+ p <- prediction(m)
+ expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
+ expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
+ })
+}
+
+if (require("ffbase", quietly = TRUE)) {
+ test_that("Test prediction() for 'biglm' w/ 'ffbase' backend", {
+ stopifnot(require("ff"))
+ stopifnot(require("biglm"))
+ data("trees", package = "datasets")
+ x <- ff::as.ffdf(trees)
+ m <- biglm::biglm(log(Volume)~log(Girth)+log(Height), data=x)
+ p <- prediction(m, calculate_se = FALSE) # temporary, while bug fixed upstream
+ expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
+ expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
+ })
+}
+
+if (require("gam", quietly = TRUE)) {
+ test_that("Test prediction() for 'Gam'", {
+ data("gam.data", package = "gam")
+ m <- gam::gam(y ~ gam::s(x,6) + z,data=gam.data)
+ p <- prediction(m)
+ expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
+ expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
+ })
+}
+
+if (require("gee", quietly = TRUE)) {
+ test_that("Test prediction() for 'gee'", {
+ data("warpbreaks")
+ m <- gee::gee(breaks ~ tension, id=wool, data=warpbreaks, corstr="exchangeable")
+ p <- prediction(m)
+ expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
+ expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
+ })
+}
+
+if (require("glmnet", quietly = TRUE)) {
+ test_that("Test prediction() for 'glmnet'", {
+ x <- matrix(rnorm(100*20),100,20)
+ y <- rnorm(100)
+ m <- glmnet::glmnet(x,y)
+ p <- prediction(m, data = x)
+ expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
+ expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
+ })
+}
+
+if (require("glmx", quietly = TRUE) ) {
+ test_that("Test prediction() for 'glmx()'", {
+ d <- data.frame(x = runif(200, -1, 1))
+ d$y <- rnbinom(200, mu = exp(0 + 3 * d$x), size = 1)
+ m <- glmx::glmx(y ~ x, data = d, family = MASS::negative.binomial, xlink = "log", xstart = 0)
+ p <- prediction(m)
+ expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
+ expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
+ })
+ test_that("Test prediction() for 'hetglm()'", {
+ n <- 200
+ x <- rnorm(n)
+ ystar <- 1 + x + rnorm(n, sd = exp(x))
+ y <- factor(ystar > 0)
+ m <- glmx::hetglm(y ~ x | 1)
+ p <- prediction(m)
+ expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
+ expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
+ })
+}
+
+if (require("kernlab", quietly = TRUE)) {
+ require("methods", quietly = TRUE)
+ test_that("Test prediction() for 'gausspr'", {
+ data("promotergene", package = "kernlab")
+ ind <- sample(1:dim(promotergene)[1],20)
+ genetrain <- promotergene[-ind, ]
+ genetest <- promotergene[ind, ]
+ m <- kernlab::gausspr(Class~., data = genetrain, kernel = "rbfdot",
+ kpar = list(sigma = 0.015))
+ p <- prediction(m, data = genetrain)
+ expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
+ expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
+ })
+ test_that("Test prediction() for 'kqr'", {
+ x <- sort(runif(300))
+ y <- sin(pi*x) + rnorm(300,0,sd=exp(sin(2*pi*x)))
+ m <- kernlab::kqr(x, y, tau = 0.5, C=0.15, kpar = list(sigma = 10))
+ p <- prediction(m)
+ expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
+ expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
+ })
+ test_that("Test prediction() for 'ksvm'", {
+ data("promotergene", package = "kernlab")
+ ind <- sample(1:dim(promotergene)[1],20)
+ genetrain <- promotergene[-ind, ]
+ genetest <- promotergene[ind, ]
+ m <- kernlab::ksvm(Class~., data = genetrain, kernel = "rbfdot",
+ kpar = list(sigma = 0.015), C = 70, cross = 4, prob.model = TRUE)
+ p <- prediction(m, data = genetrain)
+ expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
+ expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
+ })
+}
+
+if (require("lme4", quietly = TRUE)) {
+ test_that("Test prediction() for 'merMod'", {
+ data("cbpp", package = "lme4")
+ m <- lme4::glmer(cbind(incidence, size - incidence) ~ period + (1 |herd), cbpp, binomial)
+ p <- prediction(m)
+ expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
+ expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
+ })
+}
+
+if (require("MASS", quietly = TRUE)) {
+ test_that("Test prediction() for 'glm.nb'", {
+ data("quine", package = "MASS")
+ m <- MASS::glm.nb(Days ~ Sex/(Age + Eth*Lrn), data = quine)
+ p <- prediction(m)
+ expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
+ expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
+ })
+ test_that("Test prediction() for 'lda'", {
+ data("iris3", package = "datasets")
+ tr <- sample(1:50, 25)
+ train <- rbind(iris3[tr,,1], iris3[tr,,2], iris3[tr,,3])
+ cl <- factor(c(rep("s",25), rep("c",25), rep("v",25)))
+ m <- MASS::lda(train, cl)
+ p <- prediction(m, data = train)
+ expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
+ expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
+ })
+ test_that("Test prediction() for 'lqs'", {
+ data("stackloss", package = "datasets")
+ m <- MASS::lqs(stack.loss ~ ., data = stackloss, method = "S", nsamp = "exact")
+ p <- prediction(m)
+ expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
+ expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
+ })
+ test_that("Test prediction() for 'mca'", {
+ data("farms", package = "MASS")
+ m <- MASS::mca(farms, abbrev=TRUE)
+ p <- prediction(m)
+ expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
+ expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
+ })
+ test_that("Test prediction() for 'polr'", {
+ data("housing", package = "MASS")
+ m <- MASS::polr(Sat ~ Infl + Type + Cont, weights = Freq, data = housing)
+ p <- prediction(m)
+ expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
+ expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
+ })
+ test_that("Test prediction() for 'qda'", {
+ data("iris3", package = "datasets")
+ tr <- sample(1:50, 25)
+ train <- rbind(iris3[tr,,1], iris3[tr,,2], iris3[tr,,3])
+ cl <- factor(c(rep("s",25), rep("c",25), rep("v",25)))
+ m <- MASS::qda(train, cl)
+ p <- prediction(m, data = train)
+ expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
+ expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
+ })
+ test_that("Test prediction() for 'rlm'", {
+ data("stackloss", package = "datasets")
+ m <- MASS::rlm(stack.loss ~ ., stackloss)
+ p <- prediction(m)
+ expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
+ expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
+ })
+}
+
+if (require("mclogit", quietly = TRUE)) {
+ test_that("Test prediction() for 'mclogit'", {
+ data("Transport", package = "mclogit")
+ m <- mclogit::mclogit(cbind(resp,suburb)~distance+cost, data = Transport, trace = FALSE)
+ p <- prediction(m)
+ expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
+ expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
+ })
+}
+
+if (require("mda", quietly = TRUE)) {
+ test_that("Test prediction() for 'bruto'", {
+ data("trees", package = "datasets")
+ m <- bruto(trees[,-3], trees[3])
+ p <- prediction(m, data = NULL)
+ expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
+ expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
+ })
+ test_that("Test prediction() for 'fda'", {
+ data("iris", package = "datasets")
+ m <- fda(Species ~ ., data = iris)
+ p <- prediction(m)
+ expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
+ expect_true(all(c("fitted", "se.fitted", "fitted.class") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
+ })
+ test_that("Test prediction() for 'mars'", {
+ data("trees", package = "datasets")
+ m <- mars(trees[,-3], trees[3])
+ p <- prediction(m, data = NULL)
+ expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
+ expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
+ })
+ test_that("Test prediction() for 'mda'", {
+ data("glass", package = "mda")
+ m <- mda(Type ~ ., data = glass)
+ p <- prediction(m)
+ expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
+ expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
+ })
+ test_that("Test prediction() for 'polyreg'", {
+ data("iris", package = "datasets")
+ m <- polyreg(iris[,2:3], iris$Sepal.Length)
+ p <- prediction(m, data = NULL)
+ expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
+ expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
+ })
+}
+
+#if (require("mnlogit", quietly = TRUE)) {
+# test_that("Test prediction() for 'mnlogit'", {
+# data("Fish", package = "mnlogit")
+# m <- mnlogit::mnlogit(mode ~ price | income | catch, Fish, ncores = 1)
+# p <- prediction(m)
+# expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
+# expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
+# })
+#}
+
+if (require("MNP", quietly = TRUE)) {
+ test_that("Test prediction() for 'mnp'", {
+ data("japan", package = "MNP")
+ m <- MNP::mnp(cbind(LDP, NFP, SKG, JCP) ~ gender + education + age, data = head(japan, 100), verbose = FALSE)
+ p <- prediction(m)
+ expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
+ expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
+ })
+}
+
+if (require("nlme", quietly = TRUE)) {
+ test_that("Test prediction() for 'gls'", {
+ data("Ovary", package = "nlme")
+ m <- nlme::gls(follicles ~ sin(2*pi*Time) + cos(2*pi*Time), Ovary,
+ correlation = nlme::corAR1(form = ~ 1 | Mare), verbose = FALSE)
+ p <- prediction(m)
+ expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
+ expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
+ })
+ test_that("Test prediction() for 'lme'", {
+ data("Orthodont", package = "nlme")
+ m <- nlme::lme(distance ~ age, Orthodont, random = ~ age | Subject)
+ p <- prediction(m)
+ expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
+ expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
+ })
+}
+
+if (require("nnet", quietly = TRUE)) {
+ #test_that("Test prediction() for 'multinom'", { })
+ test_that("Test prediction() for 'nnet'", {
+ data("iris3", package = "datasets")
+ ird <- data.frame(rbind(iris3[,,1], iris3[,,2], iris3[,,3]),
+ species = factor(c(rep("s",50), rep("c", 50), rep("v", 50))))
+ samp <- c(sample(1:50,25), sample(51:100,25), sample(101:150,25))
+ m <- nnet::nnet(species ~ ., data = ird, subset = samp, size = 2, rang = 0.1,
+ decay = 5e-4, maxit = 200, trace = FALSE)
+ p <- prediction(m)
+ expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
+ expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
+ })
+}
+
+if (require("ordinal", quietly = TRUE)) {
+ test_that("Test prediction() for 'clm'", {
+ data("wine", package = "ordinal")
+ m <- ordinal::clm(rating ~ temp * contact, data = wine)
+ p <- prediction(m)
+ expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
+ expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
+ })
+}
+
+if (require("plm", quietly = TRUE)) {
+ test_that("Test prediction() for 'plm'", {
+ data("Grunfeld", package = "plm")
+ m <- plm::plm(inv ~ value + capital, data = Grunfeld, model = "pooling")
+ p <- prediction(m)
+ expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
+ expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
+ })
+}
+
+if (require("pscl", quietly = TRUE)) {
+ test_that("Test prediction() for 'hurdle'", {
+ data("bioChemists", package = "pscl")
+ m <- pscl::hurdle(art ~ ., data = bioChemists)
+ p <- prediction(m)
+ expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
+ expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
+ })
+ test_that("Test prediction() for 'zeroinfl'", {
+ data("bioChemists", package = "pscl")
+ m <- pscl::zeroinfl(art ~ ., data = bioChemists)
+ p <- prediction(m)
+ expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
+ expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
+ })
+ #test_that("Test prediction() for 'ideal'", {
+ # expect_true(inherits(prediction(m), "prediction"))
+ #})
+}
+
+if (require("quantreg", quietly = TRUE)) {
+ test_that("Test prediction() for 'rq'", {
+ data("stackloss", package = "datasets")
+ m <- quantreg::rq(stack.loss ~ stack.x, tau = .5, data = stackloss)
+ p <- prediction(m)
+ expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
+ expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
+ })
+}
+
+if (require("rpart", quietly = TRUE)) {
+ test_that("Test prediction() for 'rpart'", {
+ data("kyphosis", package = "rpart")
+ m <- rpart::rpart(Kyphosis ~ Age + Number + Start, data = kyphosis)
+ p <- prediction(m)
+ expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
+ expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
+ })
+}
+
+if (require("sampleSelection", quietly = TRUE)) {
+ test_that("Test prediction() for 'selection'", {
+ data("Mroz87", package = "sampleSelection")
+ Mroz87$kids <- (Mroz87$kids5 + Mroz87$kids618 > 0)
+ m <- sampleSelection::heckit(lfp ~ age + I( age^2 ) + faminc + kids + educ,
+ wage ~ exper + I( exper^2 ) + educ + city, Mroz87)
+ p <- prediction(m)
+ expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
+ expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
+ })
+}
+
+if (require("speedglm", quietly = TRUE) ) {
+ test_that("Test prediction() for 'speedglm()'", {
+ n <- 1000
+ k <- 3
+ y <- rnorm(n)
+ x <- round(matrix(rnorm(n * k), n, k), digits = 3)
+ colnames(x) <- c("s1", "s2", "s3")
+ da <- data.frame(y, x)
+ m <- speedglm(y ~ s1 + s2 + s3, data = da)
+ p <- prediction(m)
+ expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
+ expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
+ })
+ test_that("Test prediction() for 'speedlm()'", {
+ n <- 1000
+ k <- 3
+ y <- rnorm(n)
+ x <- round(matrix(rnorm(n * k), n, k), digits = 3)
+ colnames(x) <- c("s1", "s2", "s3")
+ da <- data.frame(y, x)
+ m <- speedlm(y ~ s1 + s2 + s3, data = da)
+ p <- prediction(m)
+ expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
+ expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
+ })
+}
+
+if (require("stats", quietly = TRUE)) {
+ test_that("Test prediction() for 'ar'", {
+ data("sunspot.year", package = "datasets")
+ m <- stats::ar(sunspot.year)
+ p <- prediction(m, data = sunspot.year)
+ expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
+ expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
+ })
+ test_that("Test prediction() for 'Arima'", {
+ expect_true(inherits(prediction(stats::arima(lh, order = c(3,0,0)), n.ahead = 12), "prediction"))
+ })
+ test_that("Test prediction() for 'arima0'", {
+ m <- stats::arima0(lh, order = c(1,0,1))
+ expect_true(inherits(prediction(m, data = lh, n.ahead = 12), "prediction"))
+ })
+ test_that("Test prediction() for 'loess'", {
+ m <- stats::loess(dist ~ speed, cars)
+ p <- prediction(m)
+ expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
+ expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
+ })
+ test_that("Test prediction() for 'nls'", {
+ m <- stats::nls(demand ~ SSasympOrig(Time, A, lrc), data = BOD)
+ p <- prediction(m)
+ expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
+ expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
+ })
+ test_that("Test prediction() for 'ppr'", {
+ data("rock", package = "datasets")
+ rock$area1 <- rock$area/10000
+ rock$peri1 <- rock$peri/10000
+ m <- stats::ppr(log(perm) ~ area1 + peri1 + shape,
+ data = rock, nterms = 2, max.terms = 5)
+ p <- prediction(m)
+ expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
+ expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
+ })
+ test_that("Test prediction() for 'princomp'", {
+ data("USArrests", package = "datasets")
+ m <- stats::princomp(~ ., data = USArrests, cor = TRUE)
+ p <- prediction(m)
+ expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
+ expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
+ })
+}
+
+if (require("survey", quietly = TRUE)) {
+ test_that("Test prediction() for 'svyglm'", {
+ data("api", package = "survey")
+ dstrat <- survey::svydesign(id=~1,strata=~stype, weights=~pw, data=apistrat, fpc=~fpc)
+ m <- survey::svyglm(api.stu~enroll, design=dstrat)
+ p <- prediction(m)
+ expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
+ expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
+ })
+}
+
+if (require("survival", quietly = TRUE)) {
+ test_that("Test prediction() for 'coxph'", {
+ test1 <- list(time=c(4,3,1,1,2,2,3),
+ status=c(1,1,1,0,1,1,0),
+ x=c(0,2,1,1,1,0,0),
+ sex=c(0,0,0,0,1,1,1))
+ m <- survival::coxph(survival::Surv(time, status) ~ x + survival::strata(sex), test1)
+ p <- prediction(m)
+ expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
+ expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
+ })
+ test_that("Test prediction() for 'survreg'", {
+ data("ovarian", package = "survival")
+ m <- survival::survreg(survival::Surv(futime, fustat) ~ ecog.ps + rx, ovarian, dist='weibull', scale=1)
+ p <- prediction(m)
+ expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
+ expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
+ })
+}
+
+if (require("truncreg", quietly = TRUE)) {
+ test_that("Test prediction() for 'truncreg'", {
+ data("tobin", package = "survival")
+ m <- truncreg::truncreg(durable ~ age + quant, data = tobin, subset = durable > 0)
+ p <- prediction(m)
+ expect_true(inherits(p, "prediction"), label = "'prediction' class is correct")
+ expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned")
+ })
+}
+
Debdiff
File lists identical (after any substitutions)
Control files: lines which differ (wdiff format)
Depends: r-base-core (>= 4.2.2.20221110-2), 4.2.2.20221110-1), r-api-4.0, r-cran-data.table