├── .Rbuildignore ├── .github ├── CONTRIBUTING.md ├── ISSUE_TEMPLATE.md └── PULL_REQUEST_TEMPLATE.md ├── .gitignore ├── .travis.yml ├── DESCRIPTION ├── LICENSE ├── LICENSE.md ├── Makefile ├── NAMESPACE ├── NEWS.md ├── R ├── build_datalist.R ├── find_data.R ├── make_data_frame.R ├── margex.R ├── mean_or_mode.R ├── prediction.R ├── prediction_Arima.R ├── prediction_ar.R ├── prediction_arima0.R ├── prediction_betareg.R ├── prediction_bigFastLm.R ├── prediction_bigglm.R ├── prediction_biglm.R ├── prediction_bruto.R ├── prediction_clm.R ├── prediction_coxph.R ├── prediction_crch.R ├── prediction_earth.R ├── prediction_fda.R ├── prediction_gam.R ├── prediction_gausspr.R ├── prediction_gee.R ├── prediction_glimML.R ├── prediction_glimQL.R ├── prediction_glm.R ├── prediction_glmnet.R ├── prediction_glmx.R ├── prediction_gls.R ├── prediction_hetglm.R ├── prediction_hurdle.R ├── prediction_hxlr.R ├── prediction_ivreg.R ├── prediction_knnreg.R ├── prediction_kqr.R ├── prediction_ksvm.R ├── prediction_lda.R ├── prediction_lm.R ├── prediction_lme.R ├── prediction_loess.R ├── prediction_lqs.R ├── prediction_mars.R ├── prediction_mca.R ├── prediction_mclogit.R ├── prediction_merMod.R ├── prediction_mlogit.R ├── prediction_mnlogit.R ├── prediction_mnp.R ├── prediction_multinom.R ├── prediction_naiveBayes.R ├── prediction_nls.R ├── prediction_nnet.R ├── prediction_plm.R ├── prediction_polr.R ├── prediction_polyreg.R ├── prediction_ppr.R ├── prediction_princomp.R ├── prediction_qda.R ├── prediction_rlm.R ├── prediction_rpart.R ├── prediction_rq.R ├── prediction_selection.R ├── prediction_speedglm.R ├── prediction_speedlm.R ├── prediction_survreg.R ├── prediction_svm.R ├── prediction_svyglm.R ├── prediction_train.R ├── prediction_tree.R ├── prediction_truncreg.R ├── prediction_vgam.R ├── prediction_vglm.R ├── prediction_zeroinfl.R ├── print.R ├── seq_range.R ├── summary.R └── utils.R ├── README.Rmd ├── README.md ├── appveyor.yml ├── data-raw └── margex.R ├── data └── margex.rda ├── docs ├── CONTRIBUTING.html ├── ISSUE_TEMPLATE.html ├── LICENSE-text.html ├── LICENSE.html ├── PULL_REQUEST_TEMPLATE.html ├── authors.html ├── docsearch.css ├── docsearch.js ├── favicon.ico ├── index.html ├── jquery.sticky-kit.min.js ├── link.svg ├── logo.png ├── logo.svg ├── news │ └── index.html ├── pkgdown.css ├── pkgdown.js ├── pkgdown.yml └── reference │ ├── build_datalist.html │ ├── figures │ ├── logo.png │ └── logo.svg │ ├── find_data.html │ ├── index.html │ ├── margex.html │ ├── mean_or_mode.html │ ├── prediction.html │ └── seq_range.html ├── inst └── CITATION ├── man ├── build_datalist.Rd ├── figures │ ├── logo.png │ └── logo.svg ├── find_data.Rd ├── margex.Rd ├── mean_or_mode.Rd ├── prediction.Rd └── seq_range.Rd ├── po └── R-prediction.pot └── tests ├── testthat-prediction.R └── testthat ├── tests-build_datalist.R ├── tests-core.R ├── tests-find_data.R └── tests-methods.R /.Rbuildignore: -------------------------------------------------------------------------------- 1 | ^\.github.? 2 | ^\.travis\.yml$ 3 | ^appveyor\.yml$ 4 | ^travis-tool\.sh$ 5 | ^Makefile$ 6 | ^README\.Rmd$ 7 | ^README\.html$ 8 | ^README_files$ 9 | ^README_files/.+$ 10 | ^CONTRIBUTING\.md$ 11 | ^LICENSE\.md$ 12 | ^inst/standarderrors\.pdf$ 13 | ^figure$ 14 | ^figure/.+$ 15 | ^cache/.+$ 16 | ^docs$ 17 | ^docs/.+$ 18 | ^data-raw$ 19 | ^data-raw/.+$ 20 | ^revdep.? 21 | ^ignore$ 22 | ^inst/doc/.+\.log$ 23 | ^inst/doc/.+\.Rmd$ 24 | ^vignettes/figure$ 25 | ^vignettes/figure/.+$ 26 | ^vignettes/.+\.aux$ 27 | ^vignettes/.+\.bbl$ 28 | ^vignettes/.+\.blg$ 29 | ^vignettes/.+\.dvi$ 30 | ^vignettes/.+\.log$ 31 | ^vignettes/.+\.out$ 32 | ^vignettes/.+\.pdf$ 33 | ^vignettes/.+\.sty$ 34 | ^vignettes/.+\.tex$ 35 | -------------------------------------------------------------------------------- /.github/CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | Contributions to **prediction** are welcome from anyone and are best sent as pull requests on [the GitHub repository](https://github.com/leeper/prediction/). This page provides some instructions to potential contributors about how to add to the package. 2 | 3 | 1. Contributions can be submitted as [a pull request](https://help.github.com/articles/creating-a-pull-request/) on GitHub by forking or cloning the [repo](https://github.com/leeper/prediction/), making changes and submitting the pull request. 4 | 5 | 2. This package follows [the cloudyr project style guide](http://cloudyr.github.io/styleguide/index.html). Please refer to this when editing package code. 6 | 7 | 3. Pull requests should involve only one commit per substantive change. This means if you change multiple files (e.g., code and documentation), these changes should be committed together. If you don't know how to do this (e.g., you are making changes in the GitHub web interface) just submit anyway and the maintainer will clean things up. 8 | 9 | 4. All contributions must be submitted consistent with the package license ([MIT](https://opensource.org/licenses/MIT)). 10 | 11 | 5. Non-trivial contributions need to be noted in the `Authors@R` field in the [DESCRIPTION](https://github.com/leeper/prediction/blob/master/DESCRIPTION). Just follow the format of the existing entries to add your name (and, optionally, email address). Substantial contributions should also be noted in [`inst/CITATION`](https://github.com/leeper/prediction/blob/master/inst/CITATION). 12 | 13 | 6. The package uses royxgen code and documentation markup, so changes should be made to roxygen comments in the source code `.R` files. If changes are made, roxygen needs to be run. The easiest way to do this is a command line call to: `Rscript -e devtools::document()`. Please resolve any roxygen errors before submitting a pull request. The [README.md](https://github.com/leeper/prediction/blob/master/README.md) file is built from [README.Rmd](https://github.com/leeper/prediction/blob/master/README.Rmd); changes should be made in both places or to [README.Rmd](https://github.com/leeper/prediction/blob/master/README.Rmd) and then knitted using using `knitr::knit("README.Rmd")`. 14 | 15 | 7. Please run `R CMD BUILD prediction` and `R CMD CHECK prediction_VERSION.tar.gz` before submitting the pull request to check for any errors. 16 | 17 | Some specific types of changes that you might make are: 18 | 19 | 1. Bug fixes. Great! 20 | 21 | 2. Documentation-only changes (e.g., to Rd files, README, vignettes). This is great! All contributions are welcome. 22 | 23 | 3. New functionality. This is fine, but should be discussed on [the GitHub issues page](https://github.com/leeper/prediction/issues) before submitting a pull request. Note, in particular, that contributions of new `prediction()` methods, should comply with following: 24 | 25 | - Methods should be added to their own file in the [`R/`](https://github.com/leeper/prediction/tree/master/R/) directory, with a file name corresponding to the function name (e.g., the `prediction.lm()` is saved in `R/prediction_lm.R`). 26 | - Lists of supported class are included in two places: `README.Rmd` (do not edit `README.md` directly) and on the main documentation package page (generated from roxygen comments in `R/prediction.R`). New methods should be listed in both places; methods are listed alphabetically by model class. 27 | - New methods should be supported by a simple test that is run conditional on the availability of the package that implements the model class. The tests should be added to the `tests/tests-methods.R` test file, under a conditional statement testing availability of package using `requireNamespace()`. Tests in this file are organized alphabetically, first by package and, within packages, by model class name. 28 | - Any packages that these methods require should be added to the `Enhances` field of the [`DESCRIPTION`](https://github.com/leeper/prediction/blob/master/DESCRIPTION) file. If methods require imports from a package they are supporting, they should still be listed in `Enhances` and call code should be made conditional on a `requireNamespace()` statement in the method. 29 | - The required packages should also be added to [`.travis.yml`](https://github.com/leeper/prediction/blob/master/.travis.yml) under the `r_packages:` heading so that they can be used during testing on Travis-CI. 30 | 31 | 3. Changes requiring a new package dependency should also be discussed on [the GitHub issues page](https://github.com/leeper/prediction/issues) before submitting a pull request. 32 | 33 | 4. Message translations. These are very appreciated! The format is a pain, but if you're doing this I'm assuming you're already familiar with it. 34 | 35 | Any questions you have can be opened as GitHub issues or directed to thosjleeper (at) gmail.com. 36 | -------------------------------------------------------------------------------- /.github/ISSUE_TEMPLATE.md: -------------------------------------------------------------------------------- 1 | Please specify whether your issue is about: 2 | 3 | - [ ] a possible bug 4 | - [ ] a question about package functionality 5 | - [ ] a suggested code or documentation change, improvement to the code, or feature request 6 | 7 | If you are reporting (1) a bug or (2) a question about code, please supply: 8 | 9 | - [a fully reproducible example](http://stackoverflow.com/questions/5963269/how-to-make-a-great-r-reproducible-example) using a publicly available dataset (or provide your data) 10 | - if an error is occurring, include the output of `traceback()` run immediately after the error occurs 11 | - the output of `sessionInfo()` 12 | 13 | Put your code here: 14 | 15 | ```R 16 | ## load package 17 | library("prediction") 18 | 19 | ## code goes here 20 | 21 | 22 | ## session info for your system 23 | sessionInfo() 24 | ``` 25 | 26 | -------------------------------------------------------------------------------- /.github/PULL_REQUEST_TEMPLATE.md: -------------------------------------------------------------------------------- 1 | Please ensure the following before submitting a PR: 2 | 3 | - [ ] if suggesting code changes or improvements, [open an issue](https://github.com/leeper/prediction/issues/new) first 4 | - [ ] for all but trivial changes (e.g., typo fixes), add your name to [DESCRIPTION](https://github.com/leeper/prediction/blob/master/DESCRIPTION) 5 | - [ ] for all but trivial changes (e.g., typo fixes), documentation your change in [NEWS.md](https://github.com/leeper/prediction/blob/master/NEWS.md) with a parenthetical reference to the issue number being addressed 6 | - [ ] if changing documentation, edit files in `/R` not `/man` and run `devtools::document()` to update documentation 7 | - [ ] add code or new test files to [`/tests`](https://github.com/leeper/prediction/tree/master/tests/testthat) for any new functionality or bug fix 8 | - [ ] make sure `R CMD check` runs without error before submitting the PR 9 | 10 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .Renviron 2 | .Rproj.user 3 | .Rhistory 4 | .RData 5 | *.Rproj 6 | README.html 7 | /inst/doc/*.log 8 | /vignettes/*.log 9 | /vignettes/*.aux 10 | /vignettes/*.pdf 11 | /vignettes/*.sty 12 | /vignettes/*.tex 13 | /vignettes/*.out 14 | /vignettes/*.blg 15 | /vignettes/figure/ 16 | /vignettes/*.bib.bak 17 | /revdep/ 18 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: r 2 | sudo: false 3 | cache: packages 4 | matrix: 5 | include: 6 | - os: linux 7 | r: oldrel 8 | - os: linux 9 | r: release 10 | - os: linux 11 | r: devel 12 | - os: linux 13 | dist: trusty 14 | env: R_CODECOV=true 15 | - os: osx 16 | osx_image: xcode8 17 | - os: osx 18 | osx_image: xcode8.3 19 | r_packages: 20 | - covr 21 | - AER 22 | - aod 23 | - betareg 24 | - biglm 25 | - brglm 26 | - caret 27 | - crch 28 | - e1071 29 | - earth 30 | - ff 31 | - ffbase 32 | - gam 33 | - gee 34 | - glmnet 35 | - glmx 36 | - kernlab 37 | - lme4 38 | - MASS 39 | - mclogit 40 | - mda 41 | - mlogit 42 | - MNP 43 | - nlme 44 | - nnet 45 | - ordinal 46 | - plm 47 | - pscl 48 | - quantreg 49 | - rpart 50 | - sampleSelection 51 | - speedglm 52 | - survey 53 | - survival 54 | - truncreg 55 | - VGAM 56 | after_success: 57 | - R -q -e 'library("covr");codecov()' 58 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: prediction 2 | Type: Package 3 | Title: Tidy, Type-Safe 'prediction()' Methods 4 | 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' . 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. 5 | License: MIT + file LICENSE 6 | Version: 0.3.15 7 | Date: 2019-12-24 8 | Authors@R: c(person("Thomas J.", "Leeper", 9 | role = c("aut", "cre"), 10 | email = "thosjleeper@gmail.com", 11 | comment = c(ORCID = "0000-0003-4097-6326")), 12 | person("Carl", "Ganz", role = "ctb", 13 | email = "carlganz@ucla.edu"), 14 | person("Vincent", "Arel-Bundock", role = "ctb", 15 | email = "vincent.arel-bundock@umontreal.ca", 16 | comment = c(ORCID = "0000-0003-2042-7063")) 17 | ) 18 | URL: https://github.com/leeper/prediction 19 | BugReports: https://github.com/leeper/prediction/issues 20 | Depends: R (>= 3.5.0) 21 | Imports: 22 | utils, 23 | stats, 24 | data.table 25 | Suggests: 26 | datasets, 27 | methods, 28 | testthat 29 | Enhances: 30 | AER, 31 | aod, 32 | betareg, 33 | biglm, 34 | brglm, 35 | caret, 36 | crch, 37 | e1071, 38 | earth, 39 | ff, 40 | ffbase, 41 | gam (>= 1.15), 42 | gee, 43 | glmnet, 44 | glmx, 45 | kernlab, 46 | lme4, 47 | MASS, 48 | mclogit, 49 | mda, 50 | mlogit, 51 | MNP, 52 | nlme, 53 | nnet, 54 | ordinal, 55 | plm, 56 | pscl, 57 | quantreg, 58 | rpart, 59 | sampleSelection, 60 | speedglm, 61 | survey (>= 3.31-5), 62 | survival, 63 | truncreg, 64 | VGAM 65 | ByteCompile: true 66 | Encoding: UTF-8 67 | RoxygenNote: 7.0.2 68 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | YEAR: 2016-2018 2 | COPYRIGHT HOLDER: Thomas J. Leeper 3 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | ===================== 3 | 4 | Copyright © 2016-2018 Thomas J. Leeper 5 | 6 | Permission is hereby granted, free of charge, to any person 7 | obtaining a copy of this software and associated documentation 8 | files (the “Software”), to deal in the Software without 9 | restriction, including without limitation the rights to use, 10 | copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | copies of the Software, and to permit persons to whom the 12 | Software is furnished to do so, subject to the following 13 | conditions: 14 | 15 | The above copyright notice and this permission notice shall be 16 | included in all copies or substantial portions of the Software. 17 | 18 | THE SOFTWARE IS PROVIDED “AS IS”, WITHOUT WARRANTY OF ANY KIND, 19 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES 20 | OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 21 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 22 | HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 23 | WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 24 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 25 | OTHER DEALINGS IN THE SOFTWARE. 26 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | pkg = $(shell basename $(CURDIR)) 2 | 3 | all: build 4 | 5 | NAMESPACE: R/* 6 | Rscript -e "devtools::document()" 7 | 8 | README.md: README.Rmd 9 | Rscript -e "knitr::knit('README.Rmd')" 10 | 11 | README.html: README.md 12 | pandoc -o README.html README.md 13 | 14 | ../$(pkg)*.tar.gz: DESCRIPTION NAMESPACE README.md R/* man/* tests/testthat/* po/R-rio.pot 15 | cd ../ && R CMD build $(pkg) 16 | 17 | build: ../$(pkg)*.tar.gz 18 | 19 | check: ../$(pkg)*.tar.gz 20 | cd ../ && R CMD check $(pkg)*.tar.gz 21 | rm ../$(pkg)*.tar.gz 22 | 23 | install: ../$(pkg)*.tar.gz 24 | cd ../ && R CMD INSTALL $(pkg)*.tar.gz 25 | rm ../$(pkg)*.tar.gz 26 | 27 | website: R/* README.md DESCRIPTION 28 | Rscript -e "pkgdown::build_site()" 29 | 30 | po/R-rio.pot: R/* DESCRIPTION 31 | Rscript -e "tools::update_pkg_po('.')" 32 | 33 | translations: po/R-rio.pot 34 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2: do not edit by hand 2 | 3 | S3method(find_data,crch) 4 | S3method(find_data,data.frame) 5 | S3method(find_data,default) 6 | S3method(find_data,glimML) 7 | S3method(find_data,glm) 8 | S3method(find_data,hxlr) 9 | S3method(find_data,lm) 10 | S3method(find_data,mca) 11 | S3method(find_data,merMod) 12 | S3method(find_data,svyglm) 13 | S3method(find_data,train) 14 | S3method(find_data,vgam) 15 | S3method(find_data,vglm) 16 | S3method(head,prediction) 17 | S3method(mean_or_mode,data.frame) 18 | S3method(mean_or_mode,default) 19 | S3method(mean_or_mode,numeric) 20 | S3method(median_or_mode,data.frame) 21 | S3method(median_or_mode,default) 22 | S3method(median_or_mode,numeric) 23 | S3method(prediction,Arima) 24 | S3method(prediction,Gam) 25 | S3method(prediction,ar) 26 | S3method(prediction,arima0) 27 | S3method(prediction,betareg) 28 | S3method(prediction,biglm) 29 | S3method(prediction,bruto) 30 | S3method(prediction,clm) 31 | S3method(prediction,coxph) 32 | S3method(prediction,crch) 33 | S3method(prediction,default) 34 | S3method(prediction,earth) 35 | S3method(prediction,fda) 36 | S3method(prediction,gausspr) 37 | S3method(prediction,gee) 38 | S3method(prediction,glimML) 39 | S3method(prediction,glimQL) 40 | S3method(prediction,glm) 41 | S3method(prediction,glmnet) 42 | S3method(prediction,glmx) 43 | S3method(prediction,gls) 44 | S3method(prediction,hetglm) 45 | S3method(prediction,hurdle) 46 | S3method(prediction,hxlr) 47 | S3method(prediction,ivreg) 48 | S3method(prediction,knnreg) 49 | S3method(prediction,kqr) 50 | S3method(prediction,ksvm) 51 | S3method(prediction,lm) 52 | S3method(prediction,lme) 53 | S3method(prediction,loess) 54 | S3method(prediction,lqs) 55 | S3method(prediction,mars) 56 | S3method(prediction,mca) 57 | S3method(prediction,mclogit) 58 | S3method(prediction,merMod) 59 | S3method(prediction,mnp) 60 | S3method(prediction,multinom) 61 | S3method(prediction,nls) 62 | S3method(prediction,nnet) 63 | S3method(prediction,plm) 64 | S3method(prediction,polr) 65 | S3method(prediction,polyreg) 66 | S3method(prediction,ppr) 67 | S3method(prediction,princomp) 68 | S3method(prediction,rlm) 69 | S3method(prediction,rpart) 70 | S3method(prediction,rq) 71 | S3method(prediction,selection) 72 | S3method(prediction,speedglm) 73 | S3method(prediction,speedlm) 74 | S3method(prediction,survreg) 75 | S3method(prediction,svm) 76 | S3method(prediction,svyglm) 77 | S3method(prediction,train) 78 | S3method(prediction,truncreg) 79 | S3method(prediction,zeroinfl) 80 | S3method(print,prediction) 81 | S3method(print,summary.prediction) 82 | S3method(summary,prediction) 83 | S3method(tail,prediction) 84 | export(build_datalist) 85 | export(find_data) 86 | export(mean_or_mode) 87 | export(median_or_mode) 88 | export(prediction) 89 | export(prediction_summary) 90 | export(seq_range) 91 | import(stats) 92 | importFrom(data.table,rbindlist) 93 | importFrom(stats,model.frame) 94 | importFrom(stats,terms) 95 | importFrom(utils,head) 96 | importFrom(utils,tail) 97 | -------------------------------------------------------------------------------- /R/find_data.R: -------------------------------------------------------------------------------- 1 | #' @rdname find_data 2 | #' @title Extract data from a model object 3 | #' @description Attempt to reconstruct the data used to create a model object 4 | #' @param model The model object. 5 | #' @param \dots Additional arguments passed to methods. 6 | #' @param env An environment in which to look for the \code{data} argument to the modelling call. 7 | #' @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. 8 | #' @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. 9 | #' @examples 10 | #' require("datasets") 11 | #' x <- lm(mpg ~ cyl * hp + wt, data = head(mtcars)) 12 | #' find_data(x) 13 | #' 14 | #' @seealso \code{\link{prediction}}, \code{\link{build_datalist}}, \code{\link{mean_or_mode}}, \code{\link{seq_range}} 15 | #' @export 16 | find_data <- function(model, ...) { 17 | UseMethod("find_data") 18 | } 19 | 20 | #' @rdname find_data 21 | #' @importFrom stats terms 22 | #' @export 23 | find_data.default <- function(model, env = parent.frame(), ...) { 24 | form <- try(terms(model), silent = TRUE) 25 | if (inherits(form, "try-error") && is.null(model[["call"]])) { 26 | stop("'find_data()' requires a formula call") 27 | } else { 28 | if (!is.null(model[["call"]][["data"]])) { 29 | dat <- eval(model[["call"]][["data"]], env) 30 | if (inherits(dat, "try-error")) { 31 | dat <- get_all_vars(model, data = model[["call"]][["data"]]) 32 | } 33 | } else { 34 | dat <- get_all_vars(model, data = env) 35 | } 36 | # handle subset 37 | if (!is.null(model[["call"]][["subset"]])) { 38 | subs <- try(eval(model[["call"]][["subset"]], dat), silent = TRUE) 39 | if (inherits(subs, "try-error")) { 40 | subs <- try(eval(model[["call"]][["subset"]], env), silent = TRUE) 41 | if (inherits(subs, "try-error")) { 42 | subs <- TRUE 43 | warning("'find_data()' cannot locate variable(s) used in 'subset'") 44 | } 45 | } 46 | dat <- dat[subs, , drop = FALSE] 47 | } 48 | # handle na.action 49 | if (!is.null(model[["na.action"]])) { 50 | dat <- dat[-model[["na.action"]], , drop = FALSE] 51 | } 52 | } 53 | if (is.null(dat)) { 54 | stop("'find_data()' requires a formula call") 55 | } 56 | dat 57 | } 58 | 59 | #' @rdname find_data 60 | #' @export 61 | find_data.data.frame <- function(model, ...) { 62 | model 63 | } 64 | 65 | #' @rdname find_data 66 | #' @export 67 | find_data.crch <- find_data.default 68 | 69 | #' @rdname find_data 70 | #' @export 71 | find_data.glimML <- function(model, ...) { 72 | requireNamespace("methods", quietly = TRUE) 73 | methods::slot(model, "data") 74 | } 75 | 76 | find_data.glimQL <- function(model, env = parent.frame(), ...) { 77 | requireNamespace("methods", quietly = TRUE) 78 | methods::slot(model, "fm")$data 79 | } 80 | 81 | #' @rdname find_data 82 | #' @export 83 | find_data.glm <- find_data.default 84 | 85 | #' @rdname find_data 86 | #' @export 87 | find_data.hxlr <- find_data.default 88 | 89 | #' @rdname find_data 90 | #' @export 91 | find_data.lm <- find_data.default 92 | 93 | #' @rdname find_data 94 | #' @export 95 | find_data.mca <- function(model, env = parent.frame(), ...) { 96 | eval(model[["call"]][["df"]], envir = env) 97 | } 98 | 99 | #' @rdname find_data 100 | #' @importFrom stats model.frame 101 | #' @export 102 | find_data.merMod <- function(model, env = parent.frame(), ...) { 103 | model.frame(model) 104 | } 105 | 106 | #' @rdname find_data 107 | #' @export 108 | find_data.svyglm <- function(model, env = parent.frame(), ...) { 109 | dat <- model[["data"]] 110 | # handle subset 111 | if (!is.null(model[["call"]][["subset"]])) { 112 | subs <- try(eval(model[["call"]][["subset"]], dat), silent = TRUE) 113 | if (inherits(subs, "try-error")) { 114 | subs <- try(eval(model[["call"]][["subset"]], env), silent = TRUE) 115 | if (inherits(subs, "try-error")) { 116 | subs <- TRUE 117 | warning("'find_data()' cannot locate variable(s) used in 'subset'") 118 | } 119 | } 120 | dat <- dat[subs, , drop = FALSE] 121 | } 122 | # handle na.action 123 | if (!is.null(model[["na.action"]])) { 124 | dat <- dat[-model[["na.action"]], , drop = FALSE] 125 | } 126 | 127 | return(dat) 128 | } 129 | 130 | #' @rdname find_data 131 | #' @export 132 | find_data.train <- function(model, ...) { 133 | model[["trainingData"]] 134 | } 135 | 136 | #' @rdname find_data 137 | #' @export 138 | find_data.vgam <- function(model, env = parent.frame(), ...) { 139 | if (!requireNamespace("methods")) { 140 | stop("'find_data.vgam()' requires the 'methods' package") 141 | } 142 | dat <- methods::slot(model, "misc")[["dataname"]] 143 | get(dat, envir = env) 144 | } 145 | 146 | #' @rdname find_data 147 | #' @export 148 | find_data.vglm <- find_data.vgam 149 | -------------------------------------------------------------------------------- /R/make_data_frame.R: -------------------------------------------------------------------------------- 1 | # internal function that overrides the defaults of `data.frame()` 2 | make_data_frame <- function(...) { 3 | data.frame(..., check.rows = FALSE, check.names = FALSE, fix.empty.names = FALSE, stringsAsFactors = FALSE) 4 | } 5 | -------------------------------------------------------------------------------- /R/margex.R: -------------------------------------------------------------------------------- 1 | #' @rdname margex 2 | #' @docType data 3 | #' @title Artificial data for margins, copied from Stata 4 | #' @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. 5 | #' @format A data frame with 3000 observations on the following 11 variables. 6 | #' \describe{ 7 | #' \item{\samp{y}}{A numeric vector} 8 | #' \item{\samp{outcome}}{A binary numeric vector with values (0,1)} 9 | #' \item{\samp{sex}}{A factor with two levels} 10 | #' \item{\samp{group}}{A factor with three levels} 11 | #' \item{\samp{age}}{A numeric vector} 12 | #' \item{\samp{distance}}{A numeric vector} 13 | #' \item{\samp{ycn}}{A numeric vector} 14 | #' \item{\samp{yc}}{A numeric vector} 15 | #' \item{\samp{treatment}}{A factor with two levels} 16 | #' \item{\samp{agegroup}}{A factor with three levels} 17 | #' \item{\samp{arm}}{A factor with three levels} 18 | #' } 19 | #' @source \url{http://www.stata-press.com/data/r14/margex.dta} 20 | #' @examples 21 | #' \donttest{ 22 | #' 23 | #' # Examples from Stata's help files 24 | #' # Also available from: webuse::webuse("margex") 25 | #' data("margex") 26 | #' 27 | #' # A simple case after regress 28 | #' # . regress y i.sex i.group 29 | #' # . margins sex 30 | #' m1 <- lm(y ~ factor(sex) + factor(group), data = margex) 31 | #' prediction(m1, at = list(sex = c("male", "female"))) 32 | #' 33 | #' # A simple case after logistic 34 | #' # . logistic outcome i.sex i.group 35 | #' # . margins sex 36 | #' m2 <- glm(outcome ~ sex + group, binomial(), data = margex) 37 | #' prediction(m2, at = list(sex = c("male", "female"))) 38 | #' 39 | #' # Average response versus response at average 40 | #' # . margins sex 41 | #' prediction(m2, at = list(sex = c("male", "female"))) 42 | #' # . margins sex, atmeans 43 | #' ## TODO 44 | #' 45 | #' # Multiple margins from one margins command 46 | #' # . margins sex group 47 | #' prediction(m2, at = list(sex = c("male", "female"))) 48 | #' prediction(m2, at = list(group = c("1", "2", "3"))) 49 | #' 50 | #' # Margins with interaction terms 51 | #' # . logistic outcome i.sex i.group sex#group 52 | #' # . margins sex group 53 | #' m3 <- glm(outcome ~ sex * group, binomial(), data = margex) 54 | #' prediction(m3, at = list(sex = c("male", "female"))) 55 | #' prediction(m3, at = list(group = c("1", "2", "3"))) 56 | #' 57 | #' # Margins with continuous variables 58 | #' # . logistic outcome i.sex i.group sex#group age 59 | #' # . margins sex group 60 | #' m4 <- glm(outcome ~ sex * group + age, binomial(), data = margex) 61 | #' prediction(m4, at = list(sex = c("male", "female"))) 62 | #' prediction(m4, at = list(group = c("1", "2", "3"))) 63 | #' 64 | #' # Margins of continuous variables 65 | #' # . margins, at(age=40) 66 | #' prediction(m4, at = list(age = 40)) 67 | #' # . margins, at(age=(30 35 40 45 50)) 68 | #' prediction(m4, at = list(age = c(30, 35, 40, 45, 50))) 69 | #' 70 | #' # Margins of interactions 71 | #' # . margins sex#group 72 | #' prediction(m4, at = list(sex = c("male", "female"), group = c("1", "2", "3"))) 73 | #' 74 | #' } 75 | #' @seealso \code{\link{prediction}} 76 | "margex" 77 | -------------------------------------------------------------------------------- /R/mean_or_mode.R: -------------------------------------------------------------------------------- 1 | #' @rdname mean_or_mode 2 | #' @title Class-dependent variable aggregation 3 | #' @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. 4 | #' @param x A vector. 5 | #' @return A numeric or factor vector of length 1. 6 | #' @examples 7 | #' require("datasets") 8 | #' # mean for numerics 9 | #' mean_or_mode(iris) 10 | #' mean_or_mode(iris[["Sepal.Length"]]) 11 | #' mean_or_mode(iris[["Species"]]) 12 | #' 13 | #' # median for numerics 14 | #' median_or_mode(iris) 15 | #' 16 | #' @seealso \code{\link{prediction}}, \code{\link{build_datalist}}, \code{\link{seq_range}} 17 | #' @import stats 18 | #' @export 19 | mean_or_mode <- function(x) { 20 | UseMethod("mean_or_mode") 21 | } 22 | 23 | #' @rdname mean_or_mode 24 | #' @export 25 | mean_or_mode.default <- function(x) { 26 | if (!is.factor(x)) { 27 | x <- as.factor(x) 28 | } 29 | factor(names(sort(table(x), decreasing = TRUE))[1L], levels = levels(x)) 30 | } 31 | 32 | #' @rdname mean_or_mode 33 | #' @export 34 | mean_or_mode.numeric <- function(x) { 35 | mean(x, na.rm = TRUE) 36 | } 37 | 38 | #' @rdname mean_or_mode 39 | #' @export 40 | mean_or_mode.data.frame <- function(x) { 41 | setNames(lapply(x, mean_or_mode), names(x)) 42 | } 43 | 44 | #' @rdname mean_or_mode 45 | #' @export 46 | median_or_mode <- function(x) { 47 | UseMethod("median_or_mode") 48 | } 49 | 50 | #' @rdname mean_or_mode 51 | #' @export 52 | median_or_mode.default <- function(x) { 53 | if (!is.factor(x)) { 54 | x <- as.factor(x) 55 | } 56 | factor(names(sort(table(x), decreasing = TRUE))[1L], levels = levels(x)) 57 | } 58 | 59 | #' @rdname mean_or_mode 60 | #' @export 61 | median_or_mode.numeric <- function(x) { 62 | median(x, na.rm = TRUE) 63 | } 64 | 65 | #' @rdname mean_or_mode 66 | #' @export 67 | median_or_mode.data.frame <- function(x) { 68 | setNames(lapply(x, median_or_mode), names(x)) 69 | } 70 | -------------------------------------------------------------------------------- /R/prediction_Arima.R: -------------------------------------------------------------------------------- 1 | #' @rdname prediction 2 | #' @export 3 | prediction.Arima <- function(model, calculate_se = TRUE,...) { 4 | 5 | # extract predicted values 6 | if (isTRUE(calculate_se)) { 7 | tmp <- predict(object = model, se.fit = TRUE, ...) 8 | pred <- make_data_frame(fitted = tmp[[1L]], se.fitted = tmp[[2L]]) 9 | } else { 10 | tmp <- predict(object = model, se.fit = FALSE, ...) 11 | pred <- make_data_frame(fitted = tmp, se.fitted = rep(NA_real_, length(tmp))) 12 | } 13 | 14 | # variance(s) of average predictions 15 | vc <- NA_real_ 16 | 17 | # output 18 | structure(pred, 19 | class = c("prediction", "data.frame"), 20 | at = NULL, 21 | type = NA_character_, 22 | call = if ("call" %in% names(model)) model[["call"]] else NULL, 23 | model_class = class(model), 24 | row.names = seq_len(nrow(pred)), 25 | vcov = vc, 26 | jacobian = NULL, 27 | weighted = FALSE) 28 | } 29 | -------------------------------------------------------------------------------- /R/prediction_ar.R: -------------------------------------------------------------------------------- 1 | #' @rdname prediction 2 | #' @export 3 | prediction.ar <- function(model, data, at = NULL, calculate_se = TRUE,...) { 4 | 5 | # extract predicted values 6 | if (missing(data) || is.null(data)) { 7 | if (isTRUE(calculate_se)) { 8 | tmp <- predict(object = model, se.fit = TRUE, ...) 9 | pred <- make_data_frame(fitted = tmp[[1L]], se.fitted = tmp[[2L]]) 10 | } else { 11 | tmp <- predict(object = model, se.fit = FALSE, ...) 12 | pred <- make_data_frame(fitted = tmp, se.fitted = rep(NA_real_, length(tmp))) 13 | } 14 | } else { 15 | # setup data 16 | if (is.null(at)) { 17 | data <- data 18 | } else { 19 | data <- build_datalist(data, at = at, as.data.frame = TRUE) 20 | at_specification <- attr(data, "at_specification") 21 | } 22 | if (isTRUE(calculate_se)) { 23 | tmp <- predict(model, newdata = data, se.fit = TRUE, ...) 24 | pred <- make_data_frame(fitted = tmp[[1L]], se.fitted = tmp[[2L]]) 25 | } else { 26 | tmp <- predict(model, newdata = data, se.fit = FALSE, ...) 27 | pred <- make_data_frame(fitted = tmp, se.fitted = rep(NA_real_, length(tmp))) 28 | } 29 | } 30 | 31 | # variance(s) of average predictions 32 | vc <- NA_real_ 33 | 34 | # output 35 | structure(pred, 36 | class = c("prediction", "data.frame"), 37 | at = if (is.null(at)) at else at_specification, 38 | type = NA_character_, 39 | call = if ("call" %in% names(model)) model[["call"]] else NULL, 40 | model_class = class(model), 41 | row.names = seq_len(nrow(pred)), 42 | vcov = vc, 43 | jacobian = NULL, 44 | weighted = FALSE) 45 | } 46 | -------------------------------------------------------------------------------- /R/prediction_arima0.R: -------------------------------------------------------------------------------- 1 | #' @rdname prediction 2 | #' @export 3 | prediction.arima0 <- prediction.ar 4 | -------------------------------------------------------------------------------- /R/prediction_betareg.R: -------------------------------------------------------------------------------- 1 | #' @rdname prediction 2 | #' @export 3 | prediction.betareg <- 4 | function(model, 5 | data = find_data(model, parent.frame()), 6 | at = NULL, 7 | type = c("response", "link", "precision", "variance", "quantile"), 8 | calculate_se = FALSE, 9 | ...) { 10 | 11 | type <- match.arg(type) 12 | 13 | # extract predicted value 14 | data <- data 15 | if (missing(data) || is.null(data)) { 16 | pred <- make_data_frame(fitted = predict(model, type = type, ...), 17 | se.fitted = NA_real_) 18 | } else { 19 | # reduce memory profile 20 | model[["model"]] <- NULL 21 | 22 | # setup data 23 | if (is.null(at)) { 24 | out <- data 25 | } else { 26 | out <- build_datalist(data, at = at, as.data.frame = TRUE) 27 | at_specification <- attr(out, "at_specification") 28 | } 29 | # calculate predictions 30 | pred <- predict(model, newdata = out, type = type, ...) 31 | # cbind back together 32 | pred <- make_data_frame(out, fitted = pred, se.fitted = rep(NA_real_, length(pred))) 33 | } 34 | 35 | # variance(s) of average predictions 36 | vc <- NA_real_ 37 | 38 | # output 39 | structure(pred, 40 | class = c("prediction", "data.frame"), 41 | at = if (is.null(at)) at else at_specification, 42 | type = type, 43 | call = if ("call" %in% names(model)) model[["call"]] else NULL, 44 | model_class = class(model), 45 | row.names = seq_len(nrow(pred)), 46 | vcov = vc, 47 | jacobian = NULL, 48 | weighted = FALSE) 49 | } 50 | -------------------------------------------------------------------------------- /R/prediction_bigFastLm.R: -------------------------------------------------------------------------------- 1 | # @rdname prediction 2 | # @export 3 | prediction.bigLm <- 4 | function(model, 5 | data = NULL, 6 | calculate_se = FALSE, 7 | ...) { 8 | 9 | # extract predicted values 10 | data <- data 11 | if (missing(data) || is.null(data)) { 12 | pred <- predict(model, ...) 13 | pred <- make_data_frame(fitted = pred, se.fitted = rep(NA_real_, length(pred))) 14 | } else { 15 | # setup data 16 | #data <- build_datalist(data, at = at, as.data.frame = TRUE) 17 | #at_specification <- attr(data, "at_specification") 18 | # calculate predictions 19 | tmp <- predict(model, newdata = data, ...) 20 | # cbind back together 21 | pred <- make_data_frame(data, fitted = tmp, se.fitted = rep(NA_real_, nrow(data))) 22 | } 23 | 24 | # variance(s) of average predictions 25 | vc <- NA_real_ 26 | 27 | # output 28 | structure(pred, 29 | class = c("prediction", "data.frame"), 30 | at = NULL, 31 | type = "response", 32 | call = if ("call" %in% names(model)) model[["call"]] else NULL, 33 | model_class = class(model), 34 | row.names = seq_len(nrow(pred)), 35 | vcov = vc, 36 | jacobian = NULL, 37 | weighted = FALSE) 38 | } -------------------------------------------------------------------------------- /R/prediction_bigglm.R: -------------------------------------------------------------------------------- 1 | # @rdname prediction 2 | # @export 3 | prediction.bigglm <- 4 | function(model, 5 | data = find_data(model, parent.frame()), 6 | at = NULL, 7 | type = "response", 8 | calculate_se = TRUE, 9 | ...) { 10 | 11 | type <- match.arg(type) 12 | 13 | # extract predicted values 14 | data <- data 15 | if (missing(data) || is.null(data)) { 16 | stop("prediction() for objects of class 'bigglm' only work when 'data' is specified") 17 | } else { 18 | # reduce memory profile 19 | model[["model"]] <- NULL 20 | 21 | # setup data 22 | data <- build_datalist(data, at = at, as.data.frame = TRUE) 23 | at_specification <- attr(data, "at_specification") 24 | # calculate predictions 25 | if (isTRUE(calculate_se)) { 26 | tmp <- predict(model, newdata = data, type = type, se.fit = TRUE, ...) 27 | # cbind back together 28 | pred <- make_data_frame(data, fitted = tmp[["fit"]], se.fitted = tmp[["se.fit"]]) 29 | } else { 30 | tmp <- predict(model, newdata = data, type = type, se.fit = FALSE, ...) 31 | # cbind back together 32 | pred <- make_data_frame(data, fitted = tmp, se.fitted = rep(NA_real_, nrow(data))) 33 | } 34 | } 35 | 36 | # variance(s) of average predictions 37 | vc <- NA_real_ 38 | 39 | # output 40 | structure(pred, 41 | class = c("prediction", "data.frame"), 42 | at = if (is.null(at)) at else at_specification, 43 | type = type, 44 | call = if ("call" %in% names(model)) model[["call"]] else NULL, 45 | model_class = class(model), 46 | row.names = seq_len(nrow(pred)), 47 | vcov = vc, 48 | jaccobian = NULL, 49 | weighted = FALSE) 50 | } 51 | -------------------------------------------------------------------------------- /R/prediction_biglm.R: -------------------------------------------------------------------------------- 1 | #' @rdname prediction 2 | #' @export 3 | prediction.biglm <- 4 | function(model, 5 | data = find_data(model, parent.frame()), 6 | at = NULL, 7 | type = "response", 8 | calculate_se = TRUE, 9 | ...) { 10 | 11 | type <- match.arg(type) 12 | 13 | # extract predicted values 14 | data <- data 15 | if (missing(data) || is.null(data)) { 16 | stop("prediction() for objects of class 'biglm' only work when 'data' is specified") 17 | } else { 18 | # reduce memory profile 19 | model[["model"]] <- NULL 20 | 21 | # setup data 22 | data <- build_datalist(data, at = at, as.data.frame = TRUE) 23 | at_specification <- attr(data, "at_specification") 24 | # calculate predictions 25 | if (isTRUE(calculate_se)) { 26 | tmp <- predict(model, newdata = data, se.fit = TRUE, ...) 27 | # cbind back together 28 | pred <- make_data_frame(data, fitted = tmp[["fit"]], se.fitted = tmp[["se.fit"]]) 29 | } else { 30 | tmp <- predict(model, newdata = data, se.fit = FALSE, ...) 31 | # cbind back together 32 | pred <- make_data_frame(data, fitted = tmp, se.fitted = rep(NA_real_, nrow(data))) 33 | } 34 | } 35 | 36 | # variance(s) of average predictions 37 | vc <- NA_real_ 38 | 39 | # output 40 | structure(pred, 41 | class = c("prediction", "data.frame"), 42 | at = if (is.null(at)) at else at_specification, 43 | type = type, 44 | call = if ("call" %in% names(model)) model[["call"]] else NULL, 45 | model_class = class(model), 46 | row.names = seq_len(nrow(pred)), 47 | vcov = vc, 48 | jacobian = NULL, 49 | weighted = FALSE) 50 | } 51 | -------------------------------------------------------------------------------- /R/prediction_bruto.R: -------------------------------------------------------------------------------- 1 | #' @rdname prediction 2 | #' @export 3 | prediction.bruto <- 4 | function(model, 5 | data = NULL, 6 | at = NULL, 7 | type = "fitted", 8 | calculate_se = FALSE, 9 | ...) { 10 | 11 | type <- match.arg(type) 12 | 13 | # extract predicted values 14 | data <- data 15 | if (missing(data) || is.null(data)) { 16 | pred <- predict(model, type = type, ...) 17 | pred <- make_data_frame(fitted = pred[,1L], se.fitted = rep(NA_real_, length(pred))) 18 | } else { 19 | # setup data 20 | data <- build_datalist(data, at = at, as.data.frame = TRUE) 21 | at_specification <- attr(data, "at_specification") 22 | # calculate predictions 23 | if (!is.matrix(data)) { 24 | data <- as.matrix(data) 25 | } 26 | tmp <- predict(model, newdata = data, type = type, ...) 27 | # cbind back together 28 | pred <- make_data_frame(data, fitted = tmp[,1L], se.fitted = rep(NA_real_, nrow(data))) 29 | } 30 | 31 | # variance(s) of average predictions 32 | vc <- NA_real_ 33 | 34 | # output 35 | structure(pred, 36 | class = c("prediction", "data.frame"), 37 | at = if (is.null(at)) at else at_specification, 38 | type = type, 39 | call = if ("call" %in% names(model)) model[["call"]] else NULL, 40 | model_class = class(model), 41 | row.names = seq_len(nrow(pred)), 42 | vcov = vc, 43 | jacobian = NULL, 44 | weighted = FALSE) 45 | } 46 | -------------------------------------------------------------------------------- /R/prediction_clm.R: -------------------------------------------------------------------------------- 1 | #' @rdname prediction 2 | #' @export 3 | prediction.clm <- 4 | function(model, 5 | data = find_data(model, parent.frame()), 6 | at = NULL, 7 | type = NULL, 8 | calculate_se = TRUE, 9 | category, 10 | ...) { 11 | 12 | if (!is.null(type)) { 13 | warning(sprintf("'type' is ignored for models of class '%s'", class(model))) 14 | } 15 | 16 | # extract predicted values 17 | data <- data 18 | if (missing(data) || is.null(data)) { 19 | pred <- make_data_frame(fitted.class = predict(model, type = "class", se.fit = FALSE, ...)[["fit"]]) 20 | if (isTRUE(calculate_se)) { 21 | problist <- predict(model, newdata = data, type = "prob", se.fit = TRUE, ...) 22 | probs <- make_data_frame(problist[["fit"]]) 23 | probs.se <- make_data_frame(problist[["se.fit"]]) 24 | names(probs) <- paste0("Pr(", seq_len(ncol(probs)), ")") 25 | names(probs.se) <- paste0("se.Pr(", seq_len(ncol(probs)), ")") 26 | pred <- make_data_frame(pred, probs, probs.se) 27 | } else { 28 | problist <- predict(model, newdata = data, type = "prob", se.fit = FALSE, ...) 29 | probs <- make_data_frame(problist[["fit"]]) 30 | names(probs) <- paste0("Pr(", seq_len(ncol(probs)), ")") 31 | pred <- make_data_frame(pred, probs) 32 | } 33 | } else { 34 | # setup data 35 | if (is.null(at)) { 36 | out <- data 37 | } else { 38 | out <- build_datalist(data, at = at, as.data.frame = TRUE) 39 | at_specification <- attr(out, "at_specification") 40 | } 41 | # calculate predictions 42 | pred <- predict(model, newdata = out, type = "class", se.fit = FALSE, ...)[["fit"]] 43 | if (isTRUE(calculate_se)) { 44 | problist <- predict(model, newdata = out, type = "prob", se.fit = TRUE, ...) 45 | probs <- make_data_frame(problist[["fit"]]) 46 | probs.se <- make_data_frame(problist[["se.fit"]]) 47 | names(probs) <- paste0("Pr(", seq_len(ncol(probs)), ")") 48 | names(probs.se) <- paste0("se.Pr(", seq_len(ncol(probs)), ")") 49 | pred <- make_data_frame(out, fitted.class = pred, probs, probs.se) 50 | } else { 51 | problist <- predict(model, newdata = out, type = "prob", se.fit = FALSE, ...) 52 | probs <- make_data_frame(problist[["fit"]]) 53 | names(probs) <- paste0("Pr(", seq_len(ncol(probs)), ")") 54 | pred <- make_data_frame(out, fitted.class = pred, probs) 55 | } 56 | } 57 | 58 | # handle category argument 59 | if (missing(category)) { 60 | w <- grep("^Pr\\(", names(pred))[1L] 61 | category <- names(pred)[w] 62 | pred[["fitted"]] <- pred[[w]] 63 | } else { 64 | w <- which(names(pred) == paste0("Pr(", category, ")")) 65 | if (!length(w)) { 66 | stop(sprintf("category %s not found", category)) 67 | } 68 | pred[["fitted"]] <- pred[[ w[1L] ]] 69 | } 70 | pred[["se.fitted"]] <- NA_real_ 71 | 72 | # variance(s) of average predictions 73 | vc <- NA_real_ 74 | 75 | # output 76 | structure(pred, 77 | class = c("prediction", "data.frame"), 78 | at = if (is.null(at)) at else at_specification, 79 | type = NA_character_, 80 | call = if ("call" %in% names(model)) model[["call"]] else NULL, 81 | model_class = class(model), 82 | row.names = seq_len(nrow(pred)), 83 | vcov = vc, 84 | jacobian = NULL, 85 | category = category, 86 | weighted = FALSE) 87 | } 88 | -------------------------------------------------------------------------------- /R/prediction_coxph.R: -------------------------------------------------------------------------------- 1 | #' @rdname prediction 2 | #' @export 3 | prediction.coxph <- 4 | function(model, 5 | data = find_data(model, parent.frame()), 6 | at = NULL, 7 | type = c("risk", "expected", "lp"), 8 | calculate_se = TRUE, 9 | ...) { 10 | 11 | type <- match.arg(type) 12 | 13 | # extract predicted values 14 | data <- data 15 | if (missing(data) || is.null(data)) { 16 | if (isTRUE(calculate_se)) { 17 | pred <- predict(model, type = type, se.fit = TRUE, ...) 18 | pred <- make_data_frame(fitted = pred[["fit"]], se.fitted = pred[["se.fit"]]) 19 | } else { 20 | pred <- predict(model, type = type, se.fit = FALSE, ...) 21 | pred <- make_data_frame(fitted = pred, se.fitted = rep(NA_real_, length(pred))) 22 | } 23 | } else { 24 | # setup data 25 | if (is.null(at)) { 26 | out <- data 27 | } else { 28 | out <- build_datalist(data, at = at, as.data.frame = TRUE) 29 | at_specification <- attr(out, "at_specification") 30 | } 31 | # calculate predictions 32 | if (isTRUE(calculate_se)) { 33 | pred <- predict(model, newdata = out, type = type, se.fit = TRUE, ...) 34 | pred <- make_data_frame(out, fitted = pred[["fit"]], se.fitted = pred[["se.fit"]]) 35 | } else { 36 | pred <- predict(model, newdata = out, type = type, se.fit = FALSE, ...) 37 | pred <- make_data_frame(out, fitted = pred, se.fitted = rep(NA_real_, length(pred))) 38 | } 39 | } 40 | 41 | # variance(s) of average predictions 42 | vc <- NA_real_ 43 | 44 | # output 45 | structure(pred, 46 | class = c("prediction", "data.frame"), 47 | at = if (is.null(at)) at else at_specification, 48 | type = type, 49 | call = if ("call" %in% names(model)) model[["call"]] else NULL, 50 | model_class = class(model), 51 | row.names = seq_len(nrow(pred)), 52 | vcov = vc, 53 | jacobian = NULL, 54 | weighted = FALSE) 55 | } 56 | -------------------------------------------------------------------------------- /R/prediction_crch.R: -------------------------------------------------------------------------------- 1 | #' @rdname prediction 2 | #' @export 3 | prediction.crch <- 4 | function(model, 5 | data = find_data(model), 6 | at = NULL, 7 | type = c("response", "location", "scale", "quantile"), 8 | calculate_se = FALSE, 9 | ...) { 10 | 11 | type <- match.arg(type) 12 | 13 | # extract predicted values 14 | data <- data 15 | if (missing(data) || is.null(data)) { 16 | pred <- make_data_frame(fitted = predict(model, type = type, ...), 17 | se.fitted = NA_real_) 18 | } else { 19 | # setup data 20 | if (is.null(at)) { 21 | out <- data 22 | } else { 23 | out <- build_datalist(data, at = at, as.data.frame = TRUE) 24 | at_specification <- attr(out, "at_specification") 25 | } 26 | # calculate predictions 27 | tmp <- predict(model, newdata = out, type = type, ...) 28 | # cbind back together 29 | pred <- make_data_frame(out, fitted = tmp, se.fitted = rep(NA_real_, length(tmp))) 30 | } 31 | 32 | # variance(s) of average predictions 33 | vc <- NA_real_ 34 | 35 | # output 36 | structure(pred, 37 | class = c("prediction", "data.frame"), 38 | at = if (is.null(at)) at else at_specification, 39 | type = type, 40 | call = if ("call" %in% names(model)) model[["call"]] else NULL, 41 | model_class = class(model), 42 | row.names = seq_len(nrow(pred)), 43 | vcov = vc, 44 | jacobian = NULL, 45 | weighted = FALSE) 46 | } 47 | -------------------------------------------------------------------------------- /R/prediction_earth.R: -------------------------------------------------------------------------------- 1 | #' @rdname prediction 2 | #' @export 3 | prediction.earth <- 4 | function(model, 5 | data = find_data(model, parent.frame()), 6 | at = NULL, 7 | type = c("response", "link"), 8 | calculate_se = TRUE, 9 | category, 10 | ...) { 11 | 12 | type <- match.arg(type) 13 | 14 | # extract predicted values 15 | data <- data 16 | if (missing(data) || is.null(data)) { 17 | pred <- make_data_frame(fitted.class = predict(model, type = "class", ...)[,1L]) 18 | probs <- make_data_frame(predict(model, type = type, ...)) 19 | names(probs) <- paste0("Pr(", names(probs), ")") 20 | pred <- make_data_frame(pred, probs) 21 | } else { 22 | # setup data 23 | if (is.null(at)) { 24 | out <- data 25 | } else { 26 | out <- build_datalist(data, at = at, as.data.frame = TRUE) 27 | at_specification <- attr(out, "at_specification") 28 | } 29 | # calculate predictions 30 | tmp <- predict(model, 31 | newdata = out, 32 | type = "class", 33 | ...) 34 | colnames(tmp) <- "fitted.class" 35 | tmp_probs <- make_data_frame(predict(model, newdata = out, type = type, ...)) 36 | names(tmp_probs) <- paste0("Pr(", names(tmp_probs), ")") 37 | # cbind back together 38 | pred <- make_data_frame(out, tmp, tmp_probs) 39 | pred[["se.fitted"]] <- NA_real_ 40 | } 41 | 42 | # handle category argument 43 | if (missing(category)) { 44 | w <- grep("^Pr\\(", names(pred))[1L] 45 | category <- names(pred)[w] 46 | pred[["fitted"]] <- pred[[w]] 47 | } else { 48 | w <- which(names(pred) == paste0("Pr(", category, ")")) 49 | if (!length(w)) { 50 | stop(sprintf("category %s not found", category)) 51 | } 52 | pred[["fitted"]] <- pred[[ w[1L] ]] 53 | } 54 | 55 | # variance(s) of average predictions 56 | vc <- NA_real_ 57 | 58 | # output 59 | structure(pred, 60 | class = c("prediction", "data.frame"), 61 | at = if (is.null(at)) at else at_specification, 62 | type = NA_character_, 63 | call = if ("call" %in% names(model)) model[["call"]] else NULL, 64 | model_class = class(model), 65 | row.names = seq_len(nrow(pred)), 66 | vcov = vc, 67 | jacobian = NULL, 68 | category = category, 69 | weighted = FALSE) 70 | } 71 | -------------------------------------------------------------------------------- /R/prediction_fda.R: -------------------------------------------------------------------------------- 1 | #' @rdname prediction 2 | #' @export 3 | prediction.fda <- 4 | function(model, 5 | data = find_data(model, parent.frame()), 6 | at = NULL, 7 | type = NULL, 8 | calculate_se = FALSE, 9 | category, 10 | ...) { 11 | 12 | if (!is.null(type)) { 13 | warning(sprintf("'type' is ignored for models of class '%s'", class(model))) 14 | } 15 | 16 | # extract predicted values 17 | data <- data 18 | if (missing(data) || is.null(data)) { 19 | pred <- make_data_frame(fitted.class = predict(model, type = "class", ...)) 20 | probs <- make_data_frame(predict(model, type = "posterior", ...)) 21 | names(probs) <- paste0("Pr(", names(probs), ")") 22 | pred <- make_data_frame(pred, probs) 23 | } else { 24 | # setup data 25 | if (is.null(at)) { 26 | out <- data 27 | } else { 28 | out <- build_datalist(data, at = at, as.data.frame = TRUE) 29 | at_specification <- attr(out, "at_specification") 30 | } 31 | # calculate predictions 32 | tmp <- predict(model, newdata = out, type = "class", ...) 33 | tmp_probs <- make_data_frame(predict(model, newdata = out, type = "posterior", ...)) 34 | names(tmp_probs) <- paste0("Pr(", names(tmp_probs), ")") 35 | # cbind back together 36 | pred <- make_data_frame(out, fitted.class = tmp, se.fitted = rep(NA_real_, nrow(out)), tmp_probs) 37 | rm(tmp, tmp_probs) 38 | } 39 | 40 | # handle category argument 41 | if (missing(category)) { 42 | w <- grep("^Pr\\(", names(pred))[1L] 43 | category <- names(pred)[w] 44 | pred[["fitted"]] <- pred[[w]] 45 | } else { 46 | w <- which(names(pred) == paste0("Pr(", category, ")")) 47 | if (!length(w)) { 48 | stop(sprintf("category %s not found", category)) 49 | } 50 | pred[["fitted"]] <- pred[[ w[1L] ]] 51 | } 52 | 53 | # variance(s) of average predictions 54 | vc <- NA_real_ 55 | 56 | # output 57 | structure(pred, 58 | class = c("prediction", "data.frame"), 59 | at = if (is.null(at)) at else at_specification, 60 | type = NA_character_, 61 | call = if ("call" %in% names(model)) model[["call"]] else NULL, 62 | model_class = class(model), 63 | row.names = seq_len(nrow(pred)), 64 | vcov = vc, 65 | jacobian = NULL, 66 | category = category, 67 | weighted = FALSE) 68 | } 69 | -------------------------------------------------------------------------------- /R/prediction_gam.R: -------------------------------------------------------------------------------- 1 | #' @rdname prediction 2 | #' @export 3 | prediction.Gam <- 4 | function(model, 5 | data = find_data(model, parent.frame()), 6 | at = NULL, 7 | type = c("response", "link", "terms"), 8 | calculate_se = TRUE, 9 | ...) { 10 | 11 | type <- match.arg(type) 12 | 13 | # extract predicted value 14 | data <- data 15 | if (missing(data) || is.null(data)) { 16 | if (isTRUE(calculate_se)) { 17 | pred <- predict(model, type = type, se.fit = TRUE, ...) 18 | pred <- make_data_frame(fitted = pred[["fit"]], se.fitted = pred[["se.fit"]][,1L]) 19 | } else { 20 | pred <- predict(model, type = type, se.fit = FALSE, ...) 21 | pred <- make_data_frame(fitted = pred, se.fitted = rep(NA_real_, length(pred))) 22 | } 23 | } else { 24 | # setup data 25 | if (is.null(at)) { 26 | out <- data 27 | } else { 28 | out <- build_datalist(data, at = at, as.data.frame = TRUE) 29 | at_specification <- attr(out, "at_specification") 30 | } 31 | # calculate predictions 32 | if (isTRUE(calculate_se)) { 33 | pred <- predict(model, newdata = out, type = type, se.fit = FALSE, ...) 34 | pred <- make_data_frame(out, fitted = pred, se.fitted = rep(NA_real_, length(pred))) 35 | } else { 36 | pred <- predict(model, newdata = out, type = type, se.fit = FALSE, ...) 37 | pred <- make_data_frame(out, fitted = pred, se.fitted = rep(NA_real_, length(pred))) 38 | } 39 | } 40 | 41 | # variance(s) of average predictions 42 | vc <- NA_real_ 43 | 44 | # output 45 | structure(pred, 46 | class = c("prediction", "data.frame"), 47 | at = if (is.null(at)) at else at_specification, 48 | type = type, 49 | call = if ("call" %in% names(model)) model[["call"]] else NULL, 50 | model_class = class(model), 51 | row.names = seq_len(nrow(pred)), 52 | vcov = vc, 53 | jacobian = NULL, 54 | weighted = FALSE) 55 | } 56 | -------------------------------------------------------------------------------- /R/prediction_gausspr.R: -------------------------------------------------------------------------------- 1 | #' @rdname prediction 2 | #' @export 3 | prediction.gausspr <- 4 | function(model, 5 | data, 6 | at = NULL, 7 | type = NULL, 8 | calculate_se = TRUE, 9 | category, 10 | ...) { 11 | 12 | requireNamespace("kernlab") 13 | 14 | if (!is.null(type)) { 15 | warning(sprintf("'type' is ignored for models of class '%s'", class(model))) 16 | } 17 | 18 | # extract predicted values 19 | data <- data 20 | if (missing(data) || is.null(data)) { 21 | pred <- make_data_frame(fitted.class = kernlab::predict(model, type = "response", ...)) 22 | probs <- make_data_frame(kernlab::predict(model, type = "probabilities", ...)) 23 | names(probs) <- paste0("Pr(", names(probs), ")") 24 | pred <- cbind(pred, probs) 25 | } else { 26 | # setup data 27 | if (is.null(at)) { 28 | out <- data 29 | } else { 30 | out <- build_datalist(data, at = at, as.data.frame = TRUE) 31 | at_specification <- attr(out, "at_specification") 32 | } 33 | # calculate predictions 34 | tmp <- kernlab::predict(model, newdata = out, type = "response", ...) 35 | tmp_probs <- make_data_frame(kernlab::predict(model, newdata = out, type = "probabilities", ...)) 36 | names(tmp_probs) <- paste0("Pr(", names(tmp_probs), ")") 37 | # cbind back together 38 | pred <- make_data_frame(out, fitted.class = tmp, tmp_probs) 39 | rm(tmp, tmp_probs) 40 | } 41 | 42 | # handle category argument 43 | if (missing(category)) { 44 | w <- grep("^Pr\\(", names(pred))[1L] 45 | category <- names(pred)[w] 46 | pred[["fitted"]] <- pred[[w]] 47 | } else { 48 | w <- which(names(pred) == paste0("Pr(", category, ")")) 49 | if (!length(w)) { 50 | stop(sprintf("category %s not found", category)) 51 | } 52 | pred[["fitted"]] <- pred[[ w[1L] ]] 53 | } 54 | pred[["se.fitted"]] <- NA_real_ 55 | 56 | # variance(s) of average predictions 57 | vc <- NA_real_ 58 | 59 | # output 60 | structure(pred, 61 | class = c("prediction", "data.frame"), 62 | at = if (is.null(at)) at else at_specification, 63 | type = NA_character_, 64 | call = if ("call" %in% names(model)) model[["call"]] else NULL, 65 | model_class = class(model), 66 | row.names = seq_len(nrow(pred)), 67 | vcov = vc, 68 | jacobian = NULL, 69 | category = category, 70 | weighted = FALSE) 71 | } 72 | -------------------------------------------------------------------------------- /R/prediction_gee.R: -------------------------------------------------------------------------------- 1 | #' @rdname prediction 2 | #' @export 3 | prediction.gee <- function(model, calculate_se = FALSE, ...) { 4 | 5 | pred <- make_data_frame(fitted = predict(model, ...)) 6 | pred[["se.fitted"]] <- NA_real_ 7 | 8 | # variance(s) of average predictions 9 | vc <- NA_real_ 10 | 11 | # output 12 | structure(pred, 13 | class = c("prediction", "data.frame"), 14 | at = NULL, 15 | type = NA_character_, 16 | call = if ("call" %in% names(model)) model[["call"]] else NULL, 17 | model_class = class(model), 18 | row.names = seq_len(nrow(pred)), 19 | vcov = vc, 20 | jacobian = NULL, 21 | weighted = FALSE) 22 | } 23 | -------------------------------------------------------------------------------- /R/prediction_glimML.R: -------------------------------------------------------------------------------- 1 | #' @rdname prediction 2 | #' @export 3 | prediction.glimML <- 4 | function(model, 5 | data = find_data(model, parent.frame()), 6 | at = NULL, 7 | type = c("response", "link"), 8 | calculate_se = TRUE, 9 | ...) { 10 | 11 | requireNamespace("aod") 12 | 13 | type <- match.arg(type) 14 | 15 | # extract predicted values 16 | data <- data 17 | if (missing(data) || is.null(data)) { 18 | if (isTRUE(calculate_se)) { 19 | pred <- aod::predict(model, type = type, se.fit = TRUE, ...) 20 | pred <- make_data_frame(fitted = pred[["fit"]], se.fitted = pred[["se.fit"]]) 21 | } else { 22 | pred <- aod::predict(model, type = type, se.fit = FALSE, ...) 23 | pred <- make_data_frame(fitted = pred, se.fitted = rep(NA_real_, length(pred))) 24 | } 25 | } else { 26 | # setup data 27 | data <- build_datalist(data, at = at, as.data.frame = TRUE) 28 | at_specification <- attr(data, "at_specification") 29 | # calculate predictions 30 | if (isTRUE(calculate_se)) { 31 | tmp <- aod::predict(model, newdata = data, type = type, se.fit = TRUE, ...) 32 | # cbind back together 33 | pred <- make_data_frame(data, fitted = tmp[["fit"]], se.fitted = tmp[["se.fit"]]) 34 | } else { 35 | tmp <- aod::predict(model, newdata = data, type = type, se.fit = FALSE, ...) 36 | # cbind back together 37 | pred <- make_data_frame(data, fitted = tmp, se.fitted = rep(NA_real_, nrow(data))) 38 | } 39 | } 40 | 41 | # variance(s) of average predictions 42 | vc <- NA_real_ 43 | 44 | # output 45 | structure(pred, 46 | class = c("prediction", "data.frame"), 47 | at = if (is.null(at)) at else at_specification, 48 | type = type, 49 | call = if ("call" %in% names(model)) model[["call"]] else NULL, 50 | model_class = class(model), 51 | row.names = seq_len(nrow(pred)), 52 | vcov = vc, 53 | jacobian = NULL, 54 | weighted = FALSE) 55 | } 56 | -------------------------------------------------------------------------------- /R/prediction_glimQL.R: -------------------------------------------------------------------------------- 1 | #' @rdname prediction 2 | #' @export 3 | prediction.glimQL <- 4 | function(model, 5 | data = find_data(model, parent.frame()), 6 | at = NULL, 7 | type = c("response", "link"), 8 | calculate_se = TRUE, 9 | ...) { 10 | 11 | requireNamespace("aod") 12 | 13 | type <- match.arg(type) 14 | 15 | # extract predicted values 16 | data <- data 17 | if (missing(data) || is.null(data)) { 18 | if (isTRUE(calculate_se)) { 19 | pred <- aod::predict(model, type = type, se.fit = TRUE, ...) 20 | pred <- make_data_frame(fitted = pred[["fit"]], se.fitted = pred[["se.fit"]]) 21 | } else { 22 | pred <- aod::predict(model, type = type, se.fit = FALSE, ...) 23 | pred <- make_data_frame(fitted = pred, se.fitted = rep(NA_real_, length(pred))) 24 | } 25 | } else { 26 | # setup data 27 | data <- build_datalist(data, at = at, as.data.frame = TRUE) 28 | at_specification <- attr(data, "at_specification") 29 | # calculate predictions 30 | if (isTRUE(calculate_se)) { 31 | tmp <- aod::predict(model, newdata = data, type = type, se.fit = TRUE, ...) 32 | # cbind back together 33 | pred <- make_data_frame(data, fitted = tmp[["fit"]], se.fitted = tmp[["se.fit"]]) 34 | } else { 35 | tmp <- aod::predict(model, newdata = data, type = type, se.fit = FALSE, ...) 36 | # cbind back together 37 | pred <- make_data_frame(data, fitted = tmp, se.fitted = rep(NA_real_, nrow(data))) 38 | } 39 | } 40 | 41 | # variance(s) of average predictions 42 | vc <- NA_real_ 43 | 44 | # output 45 | structure(pred, 46 | class = c("prediction", "data.frame"), 47 | at = if (is.null(at)) at else at_specification, 48 | type = type, 49 | call = if ("call" %in% names(model)) model[["call"]] else NULL, 50 | model_class = class(model), 51 | row.names = seq_len(nrow(pred)), 52 | vcov = vc, 53 | jacobian = NULL, 54 | weighted = FALSE) 55 | } 56 | -------------------------------------------------------------------------------- /R/prediction_glm.R: -------------------------------------------------------------------------------- 1 | #' @rdname prediction 2 | #' @export 3 | prediction.glm <- 4 | function(model, 5 | data = find_data(model, parent.frame()), 6 | at = NULL, 7 | type = c("response", "link"), 8 | vcov = stats::vcov(model), 9 | calculate_se = TRUE, 10 | ...) { 11 | 12 | type <- match.arg(type) 13 | 14 | # extract predicted values 15 | data <- data 16 | if (missing(data) || is.null(data)) { 17 | if (isTRUE(calculate_se)) { 18 | pred <- predict(model, type = type, se.fit = TRUE, ...) 19 | pred <- make_data_frame(fitted = pred[["fit"]], se.fitted = pred[["se.fit"]]) 20 | } else { 21 | pred <- predict(model, type = type, se.fit = FALSE, ...) 22 | pred <- make_data_frame(fitted = pred, se.fitted = rep(NA_real_, length(pred))) 23 | } 24 | } else { 25 | # reduce memory profile 26 | model[["model"]] <- NULL 27 | 28 | # setup data 29 | out <- build_datalist(data, at = at, as.data.frame = TRUE) 30 | at_specification <- attr(out, "at_specification") 31 | # calculate predictions 32 | if (isTRUE(calculate_se)) { 33 | tmp <- predict(model, newdata = out, type = type, se.fit = TRUE, ...) 34 | # cbind back together 35 | pred <- make_data_frame(out, fitted = tmp[["fit"]], se.fitted = tmp[["se.fit"]]) 36 | } else { 37 | tmp <- predict(model, newdata = out, type = type, se.fit = FALSE, ...) 38 | # cbind back together 39 | pred <- make_data_frame(out, fitted = tmp, se.fitted = rep(NA_real_, nrow(out))) 40 | } 41 | } 42 | 43 | # variance(s) of average predictions 44 | if (isTRUE(calculate_se)) { 45 | # handle case where SEs are calculated 46 | model_terms <- delete.response(terms(model)) 47 | if (is.null(at)) { 48 | # no 'at_specification', so calculate variance of overall average prediction 49 | model_frame <- model.frame(model_terms, data, na.action = na.pass, xlev = model$xlevels) 50 | model_mat <- model.matrix(model_terms, model_frame, contrasts.arg = model$contrasts) 51 | if (type == "link") { 52 | means_for_prediction <- colMeans(model_mat) 53 | } else if (type == "response") { 54 | predictions_link <- predict(model, newdata = data, type = "link", se.fit = FALSE, ...) 55 | means_for_prediction <- colMeans(model$family$mu.eta(predictions_link) * model_mat) 56 | } 57 | J <- matrix(means_for_prediction, nrow = 1L) 58 | } else { 59 | # with 'at_specification', calculate variance of all counterfactual predictions 60 | datalist <- build_datalist(data, at = at, as.data.frame = FALSE) 61 | jacobian_list <- lapply(datalist, function(one) { 62 | model_frame <- model.frame(model_terms, one, na.action = na.pass, xlev = model$xlevels) 63 | model_mat <- model.matrix(model_terms, model_frame, contrasts.arg = model$contrasts) 64 | if (type == "link") { 65 | means_for_prediction <- colMeans(model_mat) 66 | } else if (type == "response") { 67 | predictions_link <- predict(model, newdata = one, type = "link", se.fit = FALSE, ...) 68 | means_for_prediction <- colMeans(model$family$mu.eta(predictions_link) * model_mat) 69 | } 70 | means_for_prediction 71 | }) 72 | J <- do.call("rbind", jacobian_list) 73 | } 74 | vc <- diag(J %*% vcov %*% t(J)) 75 | } else { 76 | # handle case where SEs are *not* calculated 77 | J <- NULL 78 | if (length(at)) { 79 | vc <- rep(NA_real_, nrow(at_specification)) 80 | } else { 81 | vc <- NA_real_ 82 | } 83 | } 84 | 85 | # output 86 | structure(pred, 87 | class = c("prediction", "data.frame"), 88 | at = if (is.null(at)) at else at_specification, 89 | type = type, 90 | call = if ("call" %in% names(model)) model[["call"]] else NULL, 91 | model_class = class(model), 92 | row.names = seq_len(nrow(pred)), 93 | vcov = vc, 94 | jacobian = J, 95 | weighted = FALSE) 96 | } 97 | -------------------------------------------------------------------------------- /R/prediction_glmnet.R: -------------------------------------------------------------------------------- 1 | #' @rdname prediction 2 | #' @param lambda For models of class \dQuote{glmnet}, a value of the penalty parameter at which predictions are required. 3 | #' @export 4 | prediction.glmnet <- 5 | function( 6 | model, 7 | data, 8 | lambda = model[["lambda"]][1L], 9 | at = NULL, 10 | type = c("response", "link"), 11 | calculate_se = FALSE, 12 | ... 13 | ) { 14 | 15 | # glmnet models only operate with a matrix interface 16 | 17 | type <- match.arg(type) 18 | 19 | # extract predicted values 20 | data <- data 21 | if (missing(data) || is.null(data)) { 22 | warning(sprintf("'data' is required for models of class '%s'", class(model))) 23 | } else { 24 | # setup data 25 | out <- build_datalist(data, at = at, as.data.frame = TRUE) 26 | at_specification <- attr(out, "at_specification") 27 | # calculate predictions 28 | tmp <- predict(model, newx = out, type = type, s = lambda, ...) 29 | # cbind back together 30 | pred <- make_data_frame(out, fitted = tmp[, 1L, drop = TRUE], se.fitted = rep(NA_real_, nrow(out))) 31 | } 32 | 33 | # variance(s) of average predictions 34 | vc <- NA_real_ 35 | 36 | # output 37 | structure(pred, 38 | class = c("prediction", "data.frame"), 39 | at = if (is.null(at)) at else at_specification, 40 | type = type, 41 | call = if ("call" %in% names(model)) model[["call"]] else NULL, 42 | model_class = class(model), 43 | row.names = seq_len(nrow(pred)), 44 | vcov = vc, 45 | jacobian = NULL, 46 | weighted = FALSE) 47 | } 48 | -------------------------------------------------------------------------------- /R/prediction_glmx.R: -------------------------------------------------------------------------------- 1 | #' @rdname prediction 2 | #' @export 3 | prediction.glmx <- 4 | function(model, 5 | data = find_data(model, parent.frame()), 6 | at = NULL, 7 | type = c("response", "link"), 8 | calculate_se = FALSE, 9 | ...) { 10 | 11 | type <- match.arg(type) 12 | 13 | # extract predicted values 14 | data <- data 15 | if (missing(data) || is.null(data)) { 16 | pred <- make_data_frame(fitted = predict(model, newdata = data, type = type, ...)) 17 | } else { 18 | # setup data 19 | if (is.null(at)) { 20 | out <- data 21 | } else { 22 | out <- build_datalist(data, at = at, as.data.frame = TRUE) 23 | at_specification <- attr(out, "at_specification") 24 | } 25 | # calculate predictions 26 | tmp <- predict(model, 27 | newdata = out, 28 | type = type, 29 | ...) 30 | # cbind back together 31 | pred <- make_data_frame(out, fitted = tmp, se.fitted = rep(NA_real_, length(tmp))) 32 | } 33 | 34 | # variance(s) of average predictions 35 | vc <- NA_real_ 36 | 37 | # output 38 | structure(pred, 39 | class = c("prediction", "data.frame"), 40 | at = if (is.null(at)) at else at_specification, 41 | type = type, 42 | call = if ("call" %in% names(model)) model[["call"]] else NULL, 43 | model_class = class(model), 44 | row.names = seq_len(nrow(pred)), 45 | vcov = vc, 46 | jacobian = NULL, 47 | weighted = FALSE) 48 | } 49 | -------------------------------------------------------------------------------- /R/prediction_gls.R: -------------------------------------------------------------------------------- 1 | #' @rdname prediction 2 | #' @export 3 | prediction.gls <- 4 | function(model, 5 | data = find_data(model), 6 | at = NULL, 7 | calculate_se = FALSE, 8 | ...) { 9 | 10 | # extract predicted values 11 | data <- data 12 | if (missing(data) || is.null(data)) { 13 | pred <- make_data_frame(fitted = predict(model, type = "class", ...), 14 | se.fitted = NA_real_) 15 | } else { 16 | # setup data 17 | if (is.null(at)) { 18 | out <- data 19 | } else { 20 | out <- build_datalist(data, at = at, as.data.frame = TRUE) 21 | at_specification <- attr(out, "at_specification") 22 | } 23 | # calculate predictions 24 | tmp <- predict(model, 25 | newdata = out, 26 | type = "class", 27 | ...) 28 | # cbind back together 29 | pred <- make_data_frame(out, fitted = tmp, se.fitted = rep(NA_real_, length(tmp))) 30 | } 31 | 32 | # variance(s) of average predictions 33 | vc <- NA_real_ 34 | 35 | # output 36 | structure(pred, 37 | class = c("prediction", "data.frame"), 38 | at = if (is.null(at)) at else at_specification, 39 | type = NA_character_, 40 | call = if ("call" %in% names(model)) model[["call"]] else NULL, 41 | model_class = class(model), 42 | row.names = seq_len(nrow(pred)), 43 | vcov = vc, 44 | jacobian = NULL, 45 | weighted = FALSE) 46 | } 47 | 48 | -------------------------------------------------------------------------------- /R/prediction_hetglm.R: -------------------------------------------------------------------------------- 1 | #' @rdname prediction 2 | #' @export 3 | prediction.hetglm <- 4 | function(model, 5 | data = find_data(model, parent.frame()), 6 | at = NULL, 7 | type = c("response", "link", "scale"), 8 | calculate_se = FALSE, 9 | ...) { 10 | 11 | type <- match.arg(type) 12 | 13 | # extract predicted values 14 | data <- data 15 | if (missing(data) || is.null(data)) { 16 | pred <- make_data_frame(fitted = predict(model, type = type, ...)) 17 | } else { 18 | # setup data 19 | if (is.null(at)) { 20 | out <- data 21 | } else { 22 | out <- build_datalist(data, at = at, as.data.frame = TRUE) 23 | at_specification <- attr(out, "at_specification") 24 | } 25 | # calculate predictions 26 | tmp <- predict(model, 27 | newdata = out, 28 | type = type, 29 | ...) 30 | # cbind back together 31 | pred <- make_data_frame(out, fitted = tmp, se.fitted = rep(NA_real_, length(tmp))) 32 | } 33 | 34 | # variance(s) of average predictions 35 | vc <- NA_real_ 36 | 37 | # output 38 | structure(pred, 39 | class = c("prediction", "data.frame"), 40 | at = if (is.null(at)) at else at_specification, 41 | type = type, 42 | call = if ("call" %in% names(model)) model[["call"]] else NULL, 43 | model_class = class(model), 44 | row.names = seq_len(nrow(pred)), 45 | vcov = vc, 46 | jacobian = NULL, 47 | weighted = FALSE) 48 | } 49 | -------------------------------------------------------------------------------- /R/prediction_hurdle.R: -------------------------------------------------------------------------------- 1 | #' @rdname prediction 2 | #' @export 3 | prediction.hurdle <- 4 | function(model, 5 | data = find_data(model, parent.frame()), 6 | at = NULL, 7 | type = c("response", "count", "prob", "zero"), 8 | calculate_se = FALSE, 9 | ...) { 10 | 11 | type <- match.arg(type) 12 | 13 | # extract predicted values 14 | data <- data 15 | if (missing(data) || is.null(data)) { 16 | pred <- predict(model, type = type, ...) 17 | pred <- make_data_frame(fitted = pred[["fit"]]) 18 | } else { 19 | # setup data 20 | if (is.null(at)) { 21 | out <- data 22 | } else { 23 | out <- build_datalist(data, at = at, as.data.frame = TRUE) 24 | at_specification <- attr(out, "at_specification") 25 | } 26 | # calculate predictions 27 | pred <- predict(model, newdata = out, type = type, ...) 28 | pred <- make_data_frame(out, fitted = pred, se.fitted = rep(NA_real_, nrow(out))) 29 | } 30 | 31 | # variance(s) of average predictions 32 | vc <- NA_real_ 33 | 34 | # output 35 | structure(pred, 36 | class = c("prediction", "data.frame"), 37 | at = if (is.null(at)) at else at_specification, 38 | type = type, 39 | call = if ("call" %in% names(model)) model[["call"]] else NULL, 40 | model_class = class(model), 41 | row.names = seq_len(nrow(pred)), 42 | vcov = vc, 43 | jacobian = NULL, 44 | weighted = FALSE) 45 | } 46 | -------------------------------------------------------------------------------- /R/prediction_hxlr.R: -------------------------------------------------------------------------------- 1 | #' @rdname prediction 2 | #' @export 3 | prediction.hxlr <- 4 | function(model, 5 | data = find_data(model), 6 | at = NULL, 7 | type = c("class", "probability", "cumprob", "location", "scale"), 8 | calculate_se = FALSE, 9 | ...) { 10 | 11 | type <- match.arg(type) 12 | 13 | # extract predicted values 14 | data <- data 15 | if (missing(data) || is.null(data)) { 16 | pred <- make_data_frame(fitted = predict(model, type = type, ...), 17 | se.fitted = NA_real_) 18 | } else { 19 | # setup data 20 | if (is.null(at)) { 21 | out <- data 22 | } else { 23 | out <- build_datalist(data, at = at, as.data.frame = TRUE) 24 | at_specification <- attr(out, "at_specification") 25 | } 26 | # calculate predictions 27 | tmp <- predict(model, newdata = out, type = "class", ...) 28 | # cbind back together 29 | pred <- make_data_frame(out, fitted = tmp, se.fitted = rep(NA_real_, nrow(out))) 30 | } 31 | 32 | # variance(s) of average predictions 33 | vc <- NA_real_ 34 | 35 | # output 36 | structure(pred, 37 | class = c("prediction", "data.frame"), 38 | at = if (is.null(at)) at else at_specification, 39 | type = type, 40 | call = if ("call" %in% names(model)) model[["call"]] else NULL, 41 | model_class = class(model), 42 | row.names = seq_len(nrow(pred)), 43 | vcov = vc, 44 | jacobian = NULL, 45 | weighted = FALSE) 46 | } 47 | -------------------------------------------------------------------------------- /R/prediction_ivreg.R: -------------------------------------------------------------------------------- 1 | #' @rdname prediction 2 | #' @export 3 | prediction.ivreg <- function(model, data = find_data(model, parent.frame()), at = NULL, calculate_se = FALSE, ...) { 4 | 5 | # extract predicted values 6 | data <- data 7 | if (missing(data) || is.null(data)) { 8 | pred <- make_data_frame(fitted = predict(model, ...), 9 | se.fitted = NA_real_) 10 | } else { 11 | # setup data 12 | if (is.null(at)) { 13 | out <- data 14 | } else { 15 | out <- build_datalist(data, at = at, as.data.frame = TRUE) 16 | at_specification <- attr(out, "at_specification") 17 | } 18 | # calculate predictions 19 | tmp <- predict(model, newdata = out, ...) 20 | # cbind back together 21 | pred <- make_data_frame(out, fitted = tmp, se.fitted = rep(NA_real_, nrow(out))) 22 | } 23 | 24 | # variance(s) of average predictions 25 | vc <- NA_real_ 26 | 27 | # output 28 | structure(pred, 29 | class = c("prediction", "data.frame"), 30 | at = if (is.null(at)) at else at_specification, 31 | type = NA_character_, 32 | call = if ("call" %in% names(model)) model[["call"]] else NULL, 33 | model_class = class(model), 34 | row.names = seq_len(nrow(pred)), 35 | vcov = vc, 36 | jacobian = NULL, 37 | weighted = FALSE) 38 | } 39 | -------------------------------------------------------------------------------- /R/prediction_knnreg.R: -------------------------------------------------------------------------------- 1 | #' @rdname prediction 2 | #' @export 3 | prediction.knnreg <- function(model, data, at = NULL, calculate_se = FALSE, ...) { 4 | 5 | # extract predicted values 6 | if (missing(data) || is.null(data)) { 7 | pred <- make_data_frame(fitted = predict(object = model, ...)[,1L]) 8 | } else { 9 | # setup data 10 | if (is.null(at)) { 11 | out <- data 12 | } else { 13 | out <- build_datalist(data, at = at, as.data.frame = TRUE) 14 | at_specification <- attr(out, "at_specification") 15 | } 16 | pred <- make_data_frame(fitted = predict(model, newdata = data, ...)) 17 | } 18 | pred[["se.fitted"]] <- NA_real_ 19 | 20 | # variance(s) of average predictions 21 | vc <- NA_real_ 22 | 23 | # output 24 | structure(pred, 25 | class = c("prediction", "data.frame"), 26 | at = if (is.null(at)) at else at_specification, 27 | type = NA_character_, 28 | call = if ("call" %in% names(model)) model[["call"]] else NULL, 29 | model_class = class(model), 30 | row.names = seq_len(nrow(pred)), 31 | vcov = vc, 32 | jacobian = NULL, 33 | weighted = FALSE) 34 | } 35 | -------------------------------------------------------------------------------- /R/prediction_kqr.R: -------------------------------------------------------------------------------- 1 | #' @rdname prediction 2 | #' @export 3 | prediction.kqr <- function(model, data, at = NULL, calculate_se = FALSE, ...) { 4 | 5 | requireNamespace("kernlab") 6 | 7 | # extract predicted values 8 | if (missing(data) || is.null(data)) { 9 | pred <- make_data_frame(fitted = kernlab::predict(object = model, ...)[,1L]) 10 | } else { 11 | # setup data 12 | if (is.null(at)) { 13 | out <- data 14 | } else { 15 | out <- build_datalist(data, at = at, as.data.frame = TRUE) 16 | at_specification <- attr(out, "at_specification") 17 | } 18 | pred <- make_data_frame(fitted = kernlab::predict(model, newdata = data,...)[,1L]) 19 | } 20 | pred[["se.fitted"]] <- NA_real_ 21 | 22 | # variance(s) of average predictions 23 | vc <- NA_real_ 24 | 25 | # output 26 | structure(pred, 27 | class = c("prediction", "data.frame"), 28 | at = if (is.null(at)) at else at_specification, 29 | type = NA_character_, 30 | call = if ("call" %in% names(model)) model[["call"]] else NULL, 31 | model_class = class(model), 32 | row.names = seq_len(nrow(pred)), 33 | vcov = vc, 34 | jacobian = NULL, 35 | weighted = FALSE) 36 | } 37 | -------------------------------------------------------------------------------- /R/prediction_ksvm.R: -------------------------------------------------------------------------------- 1 | #' @rdname prediction 2 | #' @export 3 | prediction.ksvm <- prediction.gausspr 4 | -------------------------------------------------------------------------------- /R/prediction_lda.R: -------------------------------------------------------------------------------- 1 | # @rdname prediction 2 | # @export 3 | prediction.lda <- 4 | function(model, 5 | data = find_data(model, parent.frame()), 6 | at = NULL, 7 | calculate_se = FALSE, 8 | category, 9 | ...) { 10 | 11 | # extract predicted values 12 | data <- data 13 | if (missing(data) || is.null(data)) { 14 | pred <- predict(model, ...) 15 | colnames(pred[["posterior"]]) <- paste0("Pr(", colnames(pred[["posterior"]]), ")") 16 | pred <- make_data_frame(class = pred[["class"]], 17 | pred[["x"]], 18 | pred[["posterior"]]) 19 | } else { 20 | # setup data 21 | if (is.null(at)) { 22 | out <- data 23 | } else { 24 | out <- build_datalist(data, at = at, as.data.frame = TRUE) 25 | at_specification <- attr(out, "at_specification") 26 | } 27 | # calculate predictions 28 | tmp <- predict(model, newdata = out, ...) 29 | colnames(tmp[["posterior"]]) <- paste0("Pr(", colnames(tmp[["posterior"]]), ")") 30 | # cbind back together 31 | pred <- make_data_frame(out, make_data_frame(tmp[["x"]]), class = tmp[["class"]], tmp[["posterior"]]) 32 | pred[["se.fitted"]] <- NA_real_ 33 | } 34 | 35 | # handle category argument 36 | if (missing(category)) { 37 | w <- grep("^Pr\\(", names(pred))[1L] 38 | category <- names(pred)[w] 39 | pred[["fitted"]] <- pred[[w]] 40 | } else { 41 | w <- which(names(pred) == paste0("Pr(", category, ")")) 42 | if (!length(w)) { 43 | stop(sprintf("category %s not found", category)) 44 | } 45 | pred[["fitted"]] <- pred[[ w[1L] ]] 46 | } 47 | 48 | # variance(s) of average predictions 49 | vc <- NA_real_ 50 | 51 | # output 52 | structure(pred, 53 | class = c("prediction", "data.frame"), 54 | at = if (is.null(at)) at else at_specification, 55 | type = NA_character_, 56 | call = if ("call" %in% names(model)) model[["call"]] else NULL, 57 | model_class = class(model), 58 | row.names = seq_len(nrow(pred)), 59 | vcov = vc, 60 | jacobian = NULL, 61 | category = category, 62 | weighted = FALSE) 63 | } 64 | -------------------------------------------------------------------------------- /R/prediction_lm.R: -------------------------------------------------------------------------------- 1 | #' @rdname prediction 2 | #' @export 3 | prediction.lm <- 4 | function(model, 5 | data = find_data(model, parent.frame()), 6 | at = NULL, 7 | type = "response", 8 | vcov = stats::vcov(model), 9 | calculate_se = TRUE, 10 | ...) { 11 | 12 | type <- match.arg(type) 13 | 14 | # extract predicted values 15 | data <- data 16 | if (missing(data) || is.null(data)) { 17 | if (isTRUE(calculate_se)) { 18 | pred <- predict(model, type = type, se.fit = TRUE, ...) 19 | pred <- make_data_frame(fitted = pred[["fit"]], se.fitted = pred[["se.fit"]]) 20 | } else { 21 | pred <- predict(model, type = type, se.fit = FALSE, ...) 22 | pred <- make_data_frame(fitted = pred, se.fitted = rep(NA_real_, length(pred))) 23 | } 24 | } else { 25 | # reduce memory profile 26 | model[["model"]] <- NULL 27 | 28 | # setup data 29 | datalist <- build_datalist(data, at = at, as.data.frame = TRUE) 30 | at_specification <- attr(datalist, "at_specification") 31 | # calculate predictions 32 | if (isTRUE(calculate_se)) { 33 | tmp <- predict(model, newdata = datalist, type = type, se.fit = TRUE, ...) 34 | # cbind back together 35 | pred <- make_data_frame(datalist, fitted = tmp[["fit"]], se.fitted = tmp[["se.fit"]]) 36 | } else { 37 | tmp <- predict(model, newdata = datalist, type = type, se.fit = FALSE, ...) 38 | # cbind back together 39 | pred <- make_data_frame(datalist, fitted = tmp, se.fitted = rep(NA_real_, nrow(datalist))) 40 | } 41 | } 42 | 43 | # variance(s) of average predictions 44 | if (isTRUE(calculate_se)) { 45 | # handle case where SEs are calculated 46 | J <- NULL 47 | model_terms <- delete.response(terms(model)) 48 | if (is.null(at)) { 49 | # no 'at_specification', so calculate variance of overall average prediction 50 | model_frame <- model.frame(model_terms, data, na.action = na.pass, xlev = model$xlevels) 51 | model_mat <- model.matrix(model_terms, model_frame, contrasts.arg = model$contrasts) 52 | means_for_prediction <- colMeans(model_mat) 53 | vc <- (means_for_prediction %*% vcov %*% means_for_prediction)[1L, 1L, drop = TRUE] 54 | } else { 55 | # with 'at_specification', calculate variance of all counterfactual predictions 56 | datalist <- build_datalist(data, at = at, as.data.frame = FALSE) 57 | vc <- unlist(lapply(datalist, function(one) { 58 | model_frame <- model.frame(model_terms, one, na.action = na.pass, xlev = model$xlevels) 59 | model_mat <- model.matrix(model_terms, model_frame, contrasts.arg = model$contrasts) 60 | means_for_prediction <- colMeans(model_mat) 61 | means_for_prediction %*% vcov %*% means_for_prediction 62 | })) 63 | } 64 | } else { 65 | # handle case where SEs are *not* calculated 66 | J <- NULL 67 | if (length(at)) { 68 | vc <- rep(NA_real_, nrow(at_specification)) 69 | } else { 70 | vc <- NA_real_ 71 | } 72 | } 73 | 74 | # output 75 | structure(pred, 76 | class = c("prediction", "data.frame"), 77 | at = if (is.null(at)) at else at_specification, 78 | type = type, 79 | call = if ("call" %in% names(model)) model[["call"]] else NULL, 80 | model_class = class(model), 81 | row.names = seq_len(nrow(pred)), 82 | vcov = vc, 83 | jacobian = J, 84 | weighted = FALSE) 85 | } 86 | -------------------------------------------------------------------------------- /R/prediction_lme.R: -------------------------------------------------------------------------------- 1 | #' @rdname prediction 2 | #' @export 3 | prediction.lme <- 4 | function(model, data = find_data(model), at = NULL, calculate_se = FALSE, ...) { 5 | 6 | # extract predicted values 7 | data <- data 8 | if (missing(data) || is.null(data)) { 9 | pred <- make_data_frame(fitted = predict(model, ...)) 10 | } else { 11 | # setup data 12 | if (is.null(at)) { 13 | out <- data 14 | } else { 15 | out <- build_datalist(data, at = at, as.data.frame = TRUE) 16 | at_specification <- attr(out, "at_specification") 17 | } 18 | # calculate predictions 19 | tmp <- predict(model, 20 | newdata = out, 21 | ...) 22 | # cbind back together 23 | pred <- make_data_frame(out, fitted = tmp, se.fitted = rep(NA_real_, nrow(out))) 24 | } 25 | 26 | # variance(s) of average predictions 27 | vc <- NA_real_ 28 | 29 | # output 30 | structure(pred, 31 | class = c("prediction", "data.frame"), 32 | at = if (is.null(at)) at else at_specification, 33 | type = NA_character_, 34 | call = if ("call" %in% names(model)) model[["call"]] else NULL, 35 | model_class = class(model), 36 | row.names = seq_len(nrow(pred)), 37 | vcov = vc, 38 | jacobian = NULL, 39 | weighted = FALSE) 40 | } 41 | -------------------------------------------------------------------------------- /R/prediction_loess.R: -------------------------------------------------------------------------------- 1 | #' @rdname prediction 2 | #' @export 3 | prediction.loess <- function(model, data = find_data(model, parent.frame()), at = NULL, type = "response", calculate_se = TRUE, ...) { 4 | 5 | type <- match.arg(type) 6 | 7 | # extract predicted values 8 | data <- data 9 | if (missing(data) || is.null(data)) { 10 | pred <- predict(model, type = type, se = TRUE, ...) 11 | pred <- make_data_frame(fitted = pred[["fit"]], se.fitted = pred[["se.fit"]]) 12 | } else { 13 | # setup data 14 | if (is.null(at)) { 15 | out <- data 16 | } else { 17 | out <- build_datalist(data, at = at, as.data.frame = TRUE) 18 | at_specification <- attr(out, "at_specification") 19 | } 20 | # calculate predictions 21 | tmp <- predict(model, newdata = out, type = type, se = TRUE, ...) 22 | # cbind back together 23 | pred <- make_data_frame(out, fitted = tmp[["fit"]], se.fitted = tmp[["se.fit"]]) 24 | } 25 | 26 | # variance(s) of average predictions 27 | J <- NULL 28 | vc <- NA_real_ 29 | 30 | # output 31 | structure(pred, 32 | class = c("prediction", "data.frame"), 33 | at = if (is.null(at)) at else at_specification, 34 | type = type, 35 | call = if ("call" %in% names(model)) model[["call"]] else NULL, 36 | model_class = class(model), 37 | row.names = seq_len(nrow(pred)), 38 | vcov = vc, 39 | jacobian = J, 40 | weighted = FALSE) 41 | } 42 | -------------------------------------------------------------------------------- /R/prediction_lqs.R: -------------------------------------------------------------------------------- 1 | #' @rdname prediction 2 | #' @export 3 | prediction.lqs <- 4 | function(model, 5 | data = find_data(model), 6 | at = NULL, 7 | calculate_se = FALSE, 8 | ...) { 9 | 10 | # extract predicted values 11 | data <- data 12 | if (missing(data) || is.null(data)) { 13 | pred <- make_data_frame(fitted = predict(model, ...), se.fitted = NA_real_) 14 | } else { 15 | # setup data 16 | if (is.null(at)) { 17 | out <- data 18 | } else { 19 | out <- build_datalist(data, at = at, as.data.frame = TRUE) 20 | at_specification <- attr(out, "at_specification") 21 | } 22 | # calculate predictions 23 | tmp <- predict(model, 24 | newdata = out, 25 | ...) 26 | # cbind back together 27 | pred <- make_data_frame(out, fitted = tmp, se.fitted = rep(NA_real_, nrow(out))) 28 | } 29 | 30 | # variance(s) of average predictions 31 | vc <- NA_real_ 32 | 33 | # output 34 | structure(pred, 35 | class = c("prediction", "data.frame"), 36 | at = if (is.null(at)) at else at_specification, 37 | type = NA_character_, 38 | call = if ("call" %in% names(model)) model[["call"]] else NULL, 39 | model_class = class(model), 40 | row.names = seq_len(nrow(pred)), 41 | vcov = vc, 42 | jacobian = NULL, 43 | weighted = FALSE) 44 | } 45 | -------------------------------------------------------------------------------- /R/prediction_mars.R: -------------------------------------------------------------------------------- 1 | #' @rdname prediction 2 | #' @export 3 | prediction.mars <- 4 | function(model, 5 | data = NULL, 6 | at = NULL, 7 | type = "fitted", 8 | calculate_se = FALSE, 9 | ...) { 10 | 11 | type <- match.arg(type) 12 | 13 | # extract predicted values 14 | data <- data 15 | if (missing(data) || is.null(data)) { 16 | pred <- predict(model, type = type, ...) 17 | pred <- make_data_frame(fitted = pred[,1L], se.fitted = rep(NA_real_, length(pred))) 18 | } else { 19 | # setup data 20 | data <- build_datalist(data, at = at, as.data.frame = TRUE) 21 | at_specification <- attr(data, "at_specification") 22 | # calculate predictions 23 | if (!is.matrix(data)) { 24 | data <- as.matrix(data) 25 | } 26 | tmp <- predict(model, newdata = data, type = type, ...) 27 | # cbind back together 28 | pred <- make_data_frame(data, fitted = tmp[,1L], se.fitted = rep(NA_real_, nrow(data))) 29 | } 30 | 31 | # variance(s) of average predictions 32 | vc <- NA_real_ 33 | 34 | # output 35 | structure(pred, 36 | class = c("prediction", "data.frame"), 37 | at = if (is.null(at)) at else at_specification, 38 | type = NA_character_, 39 | call = if ("call" %in% names(model)) model[["call"]] else NULL, 40 | model_class = class(model), 41 | row.names = seq_len(nrow(pred)), 42 | vcov = vc, 43 | jacobian = NULL, 44 | weighted = FALSE) 45 | } 46 | -------------------------------------------------------------------------------- /R/prediction_mca.R: -------------------------------------------------------------------------------- 1 | #' @rdname prediction 2 | #' @export 3 | prediction.mca <- 4 | function(model, 5 | data = find_data(model), 6 | at = NULL, 7 | calculate_se = FALSE, 8 | ...) { 9 | 10 | # extract predicted values 11 | # setup data 12 | if (is.null(at)) { 13 | out <- data 14 | } else { 15 | out <- build_datalist(data, at = at, as.data.frame = TRUE) 16 | at_specification <- attr(out, "at_specification") 17 | } 18 | # calculate predictions 19 | tmp <- predict(model, newdata = out, ...) 20 | # cbind back together 21 | pred <- make_data_frame(out, tmp) 22 | pred[["fitted"]] <- NA_real_ 23 | pred[["se.fitted"]] <- NA_real_ 24 | 25 | # variance(s) of average predictions 26 | vc <- NA_real_ 27 | 28 | # output 29 | structure(pred, 30 | class = c("prediction", "data.frame"), 31 | at = if (is.null(at)) at else at_specification, 32 | type = NA_character_, 33 | call = if ("call" %in% names(model)) model[["call"]] else NULL, 34 | model_class = class(model), 35 | row.names = seq_len(nrow(pred)), 36 | vcov = vc, 37 | jacobian = NULL, 38 | weighted = FALSE) 39 | } 40 | -------------------------------------------------------------------------------- /R/prediction_mclogit.R: -------------------------------------------------------------------------------- 1 | #' @rdname prediction 2 | #' @export 3 | prediction.mclogit <- prediction.default 4 | -------------------------------------------------------------------------------- /R/prediction_merMod.R: -------------------------------------------------------------------------------- 1 | #' @rdname prediction 2 | #' @param re.form An argument passed forward to \code{\link[lme4]{predict.merMod}}. 3 | #' @export 4 | prediction.merMod <- 5 | function(model, data = find_data(model), at = NULL, type = c("response", "link"), re.form = NULL, calculate_se = FALSE, ...) { 6 | 7 | type <- match.arg(type) 8 | 9 | # extract predicted values 10 | data <- data 11 | if (missing(data) || is.null(data)) { 12 | pred <- make_data_frame(fitted = predict(model, type = type, re.form = re.form, ...)) 13 | } else { 14 | # setup data 15 | if (is.null(at)) { 16 | out <- data 17 | } else { 18 | out <- build_datalist(data, at = at, as.data.frame = TRUE) 19 | at_specification <- attr(out, "at_specification") 20 | } 21 | # calculate predictions 22 | tmp <- predict(model, newdata = out, type = type, re.form = re.form, ...) 23 | pred <- make_data_frame(out, fitted = tmp, se.fitted = rep(NA_real_, nrow(out))) 24 | } 25 | 26 | # variance(s) of average predictions 27 | vc <- NA_real_ 28 | 29 | # output 30 | structure(pred, 31 | class = c("prediction", "data.frame"), 32 | at = if (is.null(at)) at else at_specification, 33 | type = type, 34 | call = if ("call" %in% names(model)) model[["call"]] else NULL, 35 | model_class = class(model), 36 | row.names = seq_len(nrow(pred)), 37 | vcov = vc, 38 | jacobian = NULL, 39 | weighted = FALSE) 40 | } 41 | -------------------------------------------------------------------------------- /R/prediction_mlogit.R: -------------------------------------------------------------------------------- 1 | # @rdname prediction 2 | # @export 3 | prediction.mlogit <- 4 | function(model, 5 | data = find_data(model, parent.frame()), 6 | at = NULL, 7 | calculate_se = FALSE, 8 | category, 9 | ...) { 10 | 11 | # extract predicted values 12 | data <- data 13 | if (missing(data) || is.null(data)) { 14 | warning(sprintf("'data' is ignored for models of class '%s'", class(model))) 15 | } 16 | # setup data 17 | if (is.null(at)) { 18 | out <- data 19 | } else { 20 | out <- build_datalist(data, at = at, as.data.frame = TRUE) 21 | at_specification <- attr(out, "at_specification") 22 | } 23 | # calculate predictions 24 | tmp <- make_data_frame(predict(model, newdata = out, ...)) 25 | names(tmp) <- paste0("Pr(", seq_len(ncol(tmp)), ")") 26 | # cbind back together 27 | pred <- make_data_frame(out, tmp) 28 | rm(tmp) 29 | 30 | # handle category argument 31 | if (missing(category)) { 32 | w <- grep("^Pr\\(", names(pred))[1L] 33 | category <- names(pred)[w] 34 | pred[["fitted"]] <- pred[[w]] 35 | } else { 36 | w <- which(names(pred) == paste0("Pr(", category, ")")) 37 | if (!length(w)) { 38 | stop(sprintf("category %s not found", category)) 39 | } 40 | pred[["fitted"]] <- pred[[ w[1L] ]] 41 | } 42 | pred[["se.fitted"]] <- NA_real_ 43 | 44 | # variance(s) of average predictions 45 | vc <- NA_real_ 46 | 47 | # output 48 | structure(pred, 49 | class = c("prediction", "data.frame"), 50 | at = if (is.null(at)) at else at_specification, 51 | type = NA_character_, 52 | call = if ("call" %in% names(model)) model[["call"]] else NULL, 53 | model_class = class(model), 54 | row.names = seq_len(nrow(pred)), 55 | vcov = vc, 56 | jacobian = NULL, 57 | category = category, 58 | weighted = FALSE) 59 | } 60 | -------------------------------------------------------------------------------- /R/prediction_mnlogit.R: -------------------------------------------------------------------------------- 1 | # @rdname prediction 2 | # @export 3 | prediction.mnlogit <- 4 | function(model, 5 | data = find_data(model, parent.frame()), 6 | at = NULL, 7 | calculate_se = FALSE, 8 | category, 9 | ...) { 10 | 11 | # extract predicted values 12 | data <- data 13 | if (missing(data) || is.null(data)) { 14 | pred <- make_data_frame(fitted.class = predict(model, probability = FALSE, ...)) 15 | probs <- make_data_frame(predict(model, probability = TRUE, ...)) 16 | names(probs) <- paste0("Pr(", names(probs), ")") 17 | pred <- make_data_frame(pred, probs) 18 | } else { 19 | # setup data 20 | if (is.null(at)) { 21 | out <- data 22 | } else { 23 | out <- build_datalist(data, at = at, as.data.frame = TRUE) 24 | at_specification <- attr(out, "at_specification") 25 | } 26 | # calculate predictions 27 | tmp <- predict(model, newdata = out, probability = FALSE, ...) 28 | tmp_probs <- make_data_frame(predict(model, newdata = out, probability = TRUE, ...)) 29 | names(tmp_probs) <- paste0("Pr(", names(tmp_probs), ")") 30 | # cbind back together 31 | pred <- make_data_frame(out, fitted.class = tmp, tmp_probs) 32 | rm(tmp, tmp_probs) 33 | } 34 | 35 | # handle category argument 36 | if (missing(category)) { 37 | w <- grep("^Pr\\(", names(pred))[1L] 38 | category <- names(pred)[w] 39 | pred[["fitted"]] <- pred[[w]] 40 | } else { 41 | w <- which(names(pred) == paste0("Pr(", category, ")")) 42 | if (!length(w)) { 43 | stop(sprintf("category %s not found", category)) 44 | } 45 | pred[["fitted"]] <- pred[[ w[1L] ]] 46 | } 47 | pred[["se.fitted"]] <- NA_real_ 48 | 49 | # variance(s) of average predictions 50 | vc <- NA_real_ 51 | 52 | # output 53 | structure(pred, 54 | class = c("prediction", "data.frame"), 55 | at = if (is.null(at)) at else at_specification, 56 | type = NA_character_, 57 | call = if ("call" %in% names(model)) model[["call"]] else NULL, 58 | model_class = class(model), 59 | row.names = seq_len(nrow(pred)), 60 | vcov = vc, 61 | jacobian = NULL, 62 | category = category, 63 | weighted = FALSE) 64 | } -------------------------------------------------------------------------------- /R/prediction_mnp.R: -------------------------------------------------------------------------------- 1 | #' @rdname prediction 2 | #' @export 3 | prediction.mnp <- 4 | function(model, 5 | data = find_data(model, parent.frame()), 6 | at = NULL, 7 | type = NULL, 8 | calculate_se = FALSE, 9 | category, 10 | ...) { 11 | 12 | if (!is.null(type)) { 13 | warning(sprintf("'type' is ignored for models of class '%s'", class(model))) 14 | } 15 | 16 | # extract predicted values 17 | data <- data 18 | if (missing(data) || is.null(data)) { 19 | probs <- make_data_frame(predict(model, type = "prob", ...)[["p"]]) 20 | names(probs) <- paste0("Pr(", names(probs), ")") 21 | tmp <- predict(model, type = "choice", ...)[["y"]] 22 | d <- dim(tmp) 23 | if (length(d) == 3) { 24 | stop("'prediction.mnp' only works when 'n.draws = 1'") 25 | } 26 | probs[["fitted.class"]] <- lapply(seq_len(d[1L]), function(i) tmp[i,]) 27 | pred <- probs 28 | rm(probs, tmp) 29 | } else { 30 | # setup data 31 | if (is.null(at)) { 32 | out <- data 33 | } else { 34 | out <- build_datalist(data, at = at, as.data.frame = TRUE) 35 | at_specification <- attr(out, "at_specification") 36 | } 37 | # calculate predictions 38 | tmp_probs <- make_data_frame(predict(model, newdata = out, type = "prob", ...)[["p"]]) 39 | names(tmp_probs) <- paste0("Pr(", names(tmp_probs), ")") 40 | tmp <- predict(model, newdata = out, type = "choice", ...)[["y"]] 41 | d <- dim(tmp) 42 | if (length(d) == 3) { 43 | stop("'prediction.mnp' only works when 'n.draws = 1'") 44 | } 45 | tmp_probs[["fitted.class"]] <- lapply(seq_len(d[1L]), function(i) tmp[i,]) 46 | # cbind back together 47 | pred <- make_data_frame(out, tmp_probs) 48 | rm(tmp, tmp_probs) 49 | } 50 | 51 | # handle category argument 52 | if (missing(category)) { 53 | w <- grep("^Pr\\(", names(pred))[1L] 54 | category <- names(pred)[w] 55 | pred[["fitted"]] <- pred[[w]] 56 | } else { 57 | w <- which(names(pred) == paste0("Pr(", category, ")")) 58 | if (!length(w)) { 59 | stop(sprintf("category %s not found", category)) 60 | } 61 | pred[["fitted"]] <- pred[[ w[1L] ]] 62 | } 63 | pred[["se.fitted"]] <- NA_real_ 64 | 65 | # variance(s) of average predictions 66 | vc <- NA_real_ 67 | 68 | # output 69 | structure(pred, 70 | class = c("prediction", "data.frame"), 71 | at = if (is.null(at)) at else at_specification, 72 | type = NA_character_, 73 | call = if ("call" %in% names(model)) model[["call"]] else NULL, 74 | model_class = class(model), 75 | row.names = seq_len(nrow(pred)), 76 | vcov = vc, 77 | jacobian = NULL, 78 | category = category, 79 | weighted = FALSE) 80 | } 81 | -------------------------------------------------------------------------------- /R/prediction_multinom.R: -------------------------------------------------------------------------------- 1 | #' @rdname prediction 2 | #' @export 3 | prediction.multinom <- 4 | function(model, 5 | data = find_data(model, parent.frame()), 6 | at = NULL, 7 | type = NULL, 8 | calculate_se = FALSE, 9 | category, 10 | ...) { 11 | 12 | if (!is.null(type)) { 13 | warning(sprintf("'type' is ignored for models of class '%s'", class(model))) 14 | } 15 | 16 | # extract predicted values 17 | data <- data 18 | if (missing(data) || is.null(data)) { 19 | pred <- make_data_frame(fitted.class = predict(model, type = "class", ...)) 20 | probs <- make_data_frame(predict(model, type = "probs", ...)) 21 | names(probs) <- paste0("Pr(", names(probs), ")") 22 | pred <- make_data_frame(pred, probs) 23 | } else { 24 | # setup data 25 | if (is.null(at)) { 26 | out <- data 27 | } else { 28 | out <- build_datalist(data, at = at, as.data.frame = TRUE) 29 | at_specification <- attr(out, "at_specification") 30 | } 31 | # calculate predictions 32 | tmp <- predict(model, newdata = out, type = "class", ...) 33 | tmp_probs <- make_data_frame(predict(model, newdata = out, type = "probs", ...)) 34 | names(tmp_probs) <- paste0("Pr(", names(tmp_probs), ")") 35 | # cbind back together 36 | pred <- make_data_frame(out, fitted.class = tmp, tmp_probs) 37 | rm(tmp, tmp_probs) 38 | } 39 | 40 | # handle category argument 41 | if (missing(category)) { 42 | w <- grep("^Pr\\(", names(pred))[1L] 43 | category <- names(pred)[w] 44 | pred[["fitted"]] <- pred[[w]] 45 | } else { 46 | w <- which(names(pred) == paste0("Pr(", category, ")")) 47 | if (!length(w)) { 48 | stop(sprintf("category %s not found", category)) 49 | } 50 | pred[["fitted"]] <- pred[[ w[1L] ]] 51 | } 52 | pred[["se.fitted"]] <- NA_real_ 53 | 54 | # variance(s) of average predictions 55 | vc <- NA_real_ 56 | 57 | # output 58 | structure(pred, 59 | class = c("prediction", "data.frame"), 60 | at = if (is.null(at)) at else at_specification, 61 | type = NA_character_, 62 | call = if ("call" %in% names(model)) model[["call"]] else NULL, 63 | model_class = class(model), 64 | row.names = seq_len(nrow(pred)), 65 | vcov = vc, 66 | jacobian = NULL, 67 | category = category, 68 | weighted = FALSE) 69 | } 70 | -------------------------------------------------------------------------------- /R/prediction_naiveBayes.R: -------------------------------------------------------------------------------- 1 | # @rdname prediction 2 | # @export 3 | prediction.naiveBayes <- 4 | function(model, 5 | data = find_data(model, parent.frame()), 6 | at = NULL, 7 | type = NULL, 8 | calculate_se = FALSE, 9 | category, 10 | ...) { 11 | 12 | # extract predicted values 13 | data <- data 14 | if (missing(data) || is.null(data)) { 15 | warning(sprintf("'data' is ignored for models of class '%s'", class(model))) 16 | } 17 | if (!is.null(type)) { 18 | warning(sprintf("'type' is ignored for models of class '%s'", class(model))) 19 | } 20 | 21 | # setup data 22 | if (is.null(at)) { 23 | out <- data 24 | } else { 25 | out <- build_datalist(data, at = at, as.data.frame = TRUE) 26 | at_specification <- attr(out, "at_specification") 27 | } 28 | # calculate predictions 29 | pred <- predict(model, newdata = out, type = "class", ...) 30 | probs <- make_data_frame(predict(model, newdata = out, type = "raw", ...)) 31 | names(probs) <- paste0("Pr(", names(probs), ")") 32 | # cbind back together 33 | pred <- make_data_frame(out, probs, fitted.class = pred, se.fitted = rep(NA_real_, nrow(out))) 34 | 35 | # handle category argument 36 | if (missing(category)) { 37 | w <- grep("^Pr\\(", names(pred))[1L] 38 | category <- names(pred)[w] 39 | pred[["fitted"]] <- pred[[w]] 40 | } else { 41 | w <- which(names(pred) == paste0("Pr(", category, ")")) 42 | if (!length(w)) { 43 | stop(sprintf("category %s not found", category)) 44 | } 45 | pred[["fitted"]] <- pred[[ w[1L] ]] 46 | } 47 | 48 | # variance(s) of average predictions 49 | vc <- NA_real_ 50 | 51 | # output 52 | structure(pred, 53 | class = c("prediction", "data.frame"), 54 | at = if (is.null(at)) at else at_specification, 55 | type = NA_character_, 56 | call = if ("call" %in% names(model)) model[["call"]] else NULL, 57 | model_class = class(model), 58 | row.names = seq_len(nrow(pred)), 59 | vcov = vc, 60 | jacobian = NULL, 61 | category = category, 62 | weighted = FALSE) 63 | } 64 | -------------------------------------------------------------------------------- /R/prediction_nls.R: -------------------------------------------------------------------------------- 1 | #' @rdname prediction 2 | #' @export 3 | prediction.nls <- function(model, data = find_data(model, parent.frame()), at = NULL, calculate_se = FALSE, ...) { 4 | 5 | # extract predicted values 6 | data <- data 7 | if (missing(data) || is.null(data)) { 8 | pred <- make_data_frame(fitted = predict(model, ...), 9 | se.fitted = NA_real_) 10 | } else { 11 | # setup data 12 | if (is.null(at)) { 13 | out <- data 14 | } else { 15 | out <- build_datalist(data, at = at, as.data.frame = TRUE) 16 | at_specification <- attr(out, "at_specification") 17 | } 18 | # calculate predictions 19 | tmp <- predict(model, 20 | newdata = out, 21 | ...) 22 | # cbind back together 23 | pred <- make_data_frame(out, fitted = tmp, se.fitted = rep(NA_real_, length(tmp))) 24 | } 25 | 26 | # variance(s) of average predictions 27 | vc <- NA_real_ 28 | 29 | # output 30 | structure(pred, 31 | class = c("prediction", "data.frame"), 32 | at = if (is.null(at)) at else at_specification, 33 | type = NA_character_, 34 | call = if ("call" %in% names(model)) model[["call"]] else NULL, 35 | model_class = class(model), 36 | row.names = seq_len(nrow(pred)), 37 | vcov = vc, 38 | jacobian = NULL, 39 | weighted = FALSE) 40 | } 41 | 42 | -------------------------------------------------------------------------------- /R/prediction_nnet.R: -------------------------------------------------------------------------------- 1 | #' @rdname prediction 2 | #' @export 3 | prediction.nnet <- 4 | function(model, 5 | data = find_data(model, parent.frame()), 6 | at = NULL, 7 | type = NULL, 8 | calculate_se = FALSE, 9 | category, 10 | ...) { 11 | 12 | if (!is.null(type)) { 13 | warning(sprintf("'type' is ignored for models of class '%s'", class(model))) 14 | } 15 | 16 | # extract predicted values 17 | data <- data 18 | if (missing(data) || is.null(data)) { 19 | pred <- make_data_frame(fitted.class = predict(model, type = "class", ...)) 20 | probs <- make_data_frame(predict(model, type = "raw", ...)) 21 | names(probs) <- paste0("Pr(", names(probs), ")") 22 | pred <- make_data_frame(pred, probs) 23 | } else { 24 | # setup data 25 | if (is.null(at)) { 26 | out <- data 27 | } else { 28 | out <- build_datalist(data, at = at, as.data.frame = TRUE) 29 | at_specification <- attr(out, "at_specification") 30 | } 31 | # calculate predictions 32 | tmp <- predict(model, newdata = out, type = "class", ...) 33 | tmp_probs <- make_data_frame(predict(model, newdata = out, type = "raw", ...)) 34 | names(tmp_probs) <- paste0("Pr(", names(tmp_probs), ")") 35 | # cbind back together 36 | pred <- make_data_frame(out, fitted.class = tmp, se.fitted = rep(NA_real_, nrow(out)), tmp_probs) 37 | rm(tmp, tmp_probs) 38 | } 39 | 40 | # handle category argument 41 | if (missing(category)) { 42 | w <- grep("^Pr\\(", names(pred))[1L] 43 | category <- names(pred)[w] 44 | pred[["fitted"]] <- pred[[w]] 45 | } else { 46 | w <- which(names(pred) == paste0("Pr(", category, ")")) 47 | if (!length(w)) { 48 | stop(sprintf("category %s not found", category)) 49 | } 50 | pred[["fitted"]] <- pred[[ w[1L] ]] 51 | } 52 | 53 | # variance(s) of average predictions 54 | vc <- NA_real_ 55 | 56 | # output 57 | structure(pred, 58 | class = c("prediction", "data.frame"), 59 | at = if (is.null(at)) at else at_specification, 60 | type = NA_character_, 61 | call = if ("call" %in% names(model)) model[["call"]] else NULL, 62 | model_class = class(model), 63 | row.names = seq_len(nrow(pred)), 64 | vcov = vc, 65 | jacobian = NULL, 66 | category = category, 67 | weighted = FALSE) 68 | } 69 | -------------------------------------------------------------------------------- /R/prediction_plm.R: -------------------------------------------------------------------------------- 1 | #' @rdname prediction 2 | #' @export 3 | prediction.plm <- 4 | function(model, 5 | data = find_data(model, parent.frame()), 6 | at = NULL, 7 | calculate_se = FALSE, 8 | ...) { 9 | 10 | # extract predicted values 11 | data <- data 12 | if (missing(data) || is.null(data)) { 13 | pred <- make_data_frame(fitted = predict(model, ...)) 14 | } else { 15 | # setup data 16 | if (is.null(at)) { 17 | out <- data 18 | } else { 19 | out <- build_datalist(data, at = at, as.data.frame = TRUE) 20 | at_specification <- attr(out, "at_specification") 21 | } 22 | # calculate predictions 23 | tmp <- predict(model, newdata = out, ...) 24 | # cbind back together 25 | pred <- make_data_frame(out, fitted = tmp, se.fitted = rep(NA_real_, nrow(out))) 26 | } 27 | 28 | # variance(s) of average predictions 29 | vc <- NA_real_ 30 | 31 | # output 32 | structure(pred, 33 | class = c("prediction", "data.frame"), 34 | at = if (is.null(at)) at else at_specification, 35 | type = NA_character_, 36 | call = if ("call" %in% names(model)) model[["call"]] else NULL, 37 | model_class = class(model), 38 | row.names = seq_len(nrow(pred)), 39 | vcov = vc, 40 | jacobian = NULL, 41 | weighted = FALSE) 42 | } 43 | -------------------------------------------------------------------------------- /R/prediction_polr.R: -------------------------------------------------------------------------------- 1 | #' @rdname prediction 2 | #' @export 3 | prediction.polr <- prediction.multinom 4 | -------------------------------------------------------------------------------- /R/prediction_polyreg.R: -------------------------------------------------------------------------------- 1 | #' @rdname prediction 2 | #' @export 3 | prediction.polyreg <- 4 | function(model, 5 | data = NULL, 6 | at = NULL, 7 | type = "fitted", 8 | calculate_se = FALSE, 9 | ...) { 10 | 11 | type <- match.arg(type) 12 | 13 | # extract predicted values 14 | data <- data 15 | if (missing(data) || is.null(data)) { 16 | pred <- predict(model, type = type, ...) 17 | pred <- make_data_frame(fitted = pred[,1L], se.fitted = rep(NA_real_, length(pred))) 18 | } else { 19 | # setup data 20 | data <- build_datalist(data, at = at, as.data.frame = TRUE) 21 | at_specification <- attr(data, "at_specification") 22 | # calculate predictions 23 | if (!is.matrix(data)) { 24 | data <- as.matrix(data) 25 | } 26 | tmp <- predict(model, newdata = data, type = type, ...) 27 | # cbind back together 28 | pred <- make_data_frame(data, fitted = tmp[,1L], se.fitted = rep(NA_real_, nrow(data))) 29 | } 30 | 31 | # variance(s) of average predictions 32 | vc <- NA_real_ 33 | 34 | # output 35 | structure(pred, 36 | class = c("prediction", "data.frame"), 37 | at = if (is.null(at)) at else at_specification, 38 | type = type, 39 | call = if ("call" %in% names(model)) model[["call"]] else NULL, 40 | model_class = class(model), 41 | row.names = seq_len(nrow(pred)), 42 | vcov = vc, 43 | jacobian = NULL, 44 | weighted = FALSE) 45 | } 46 | -------------------------------------------------------------------------------- /R/prediction_ppr.R: -------------------------------------------------------------------------------- 1 | #' @rdname prediction 2 | #' @export 3 | prediction.ppr <- function(model, data = find_data(model, parent.frame()), at = NULL, calculate_se = FALSE, ...) { 4 | 5 | # extract predicted values 6 | data <- data 7 | if (missing(data) || is.null(data)) { 8 | pred <- make_data_frame(fitted = predict(model, ...), 9 | se.fitted = NA_real_) 10 | } else { 11 | # setup data 12 | if (is.null(at)) { 13 | out <- data 14 | } else { 15 | out <- build_datalist(data, at = at, as.data.frame = TRUE) 16 | at_specification <- attr(out, "at_specification") 17 | } 18 | # calculate predictions 19 | tmp <- predict(model, 20 | newdata = out, 21 | ...) 22 | # cbind back together 23 | pred <- make_data_frame(out, fitted = tmp, se.fitted = rep(NA_real_, nrow(out))) 24 | } 25 | 26 | # variance(s) of average predictions 27 | vc <- NA_real_ 28 | 29 | # output 30 | structure(pred, 31 | class = c("prediction", "data.frame"), 32 | at = if (is.null(at)) at else at_specification, 33 | type = NA_character_, 34 | call = if ("call" %in% names(model)) model[["call"]] else NULL, 35 | model_class = class(model), 36 | row.names = seq_len(nrow(pred)), 37 | vcov = vc, 38 | jacobian = NULL, 39 | weighted = FALSE) 40 | } 41 | -------------------------------------------------------------------------------- /R/prediction_princomp.R: -------------------------------------------------------------------------------- 1 | #' @rdname prediction 2 | #' @export 3 | prediction.princomp <- function(model, data = find_data(model, parent.frame()), at = NULL, calculate_se = FALSE, ...) { 4 | 5 | # extract predicted values 6 | data <- data 7 | if (missing(data) || is.null(data)) { 8 | pred <- make_data_frame(predict(model, ...)) 9 | } else { 10 | # setup data 11 | if (is.null(at)) { 12 | out <- data 13 | } else { 14 | out <- build_datalist(data, at = at, as.data.frame = TRUE) 15 | at_specification <- attr(out, "at_specification") 16 | } 17 | # calculate predictions 18 | tmp <- predict(model, 19 | newdata = out, 20 | ...) 21 | # cbind back together 22 | pred <- make_data_frame(out, tmp, fitted = rep(NA_real_, nrow(out)), se.fitted = rep(NA_real_, nrow(out))) 23 | } 24 | 25 | # variance(s) of average predictions 26 | vc <- NA_real_ 27 | 28 | # output 29 | structure(pred, 30 | class = c("prediction", "data.frame"), 31 | at = if (is.null(at)) at else at_specification, 32 | type = NA_character_, 33 | call = if ("call" %in% names(model)) model[["call"]] else NULL, 34 | model_class = class(model), 35 | row.names = seq_len(nrow(pred)), 36 | vcov = vc, 37 | jacobian = NULL, 38 | weighted = FALSE) 39 | } 40 | -------------------------------------------------------------------------------- /R/prediction_qda.R: -------------------------------------------------------------------------------- 1 | # @rdname prediction 2 | # @export 3 | prediction.qda <- 4 | function(model, 5 | data = find_data(model, parent.frame()), 6 | at = NULL, 7 | calculate_se = FALSE, 8 | category, 9 | ...) { 10 | 11 | # extract predicted values 12 | data <- data 13 | if (missing(data) || is.null(data)) { 14 | pred <- predict(model, ...) 15 | colnames(pred[["posterior"]]) <- paste0("Pr(", colnames(pred[["posterior"]]), ")") 16 | pred <- make_data_frame(fitted.class = pred[["class"]], 17 | pred[["posterior"]]) 18 | } else { 19 | # setup data 20 | if (is.null(at)) { 21 | out <- data 22 | } else { 23 | out <- build_datalist(data, at = at, as.data.frame = TRUE) 24 | at_specification <- attr(out, "at_specification") 25 | } 26 | # calculate predictions 27 | tmp <- predict(model, newdata = out, ...) 28 | colnames(tmp[["posterior"]]) <- paste0("Pr(", colnames(tmp[["posterior"]]), ")") 29 | # cbind back together 30 | pred <- make_data_frame(out, fitted.class = tmp[["class"]], tmp[["posterior"]], se.fitted = rep(NA_real_, nrow (out))) 31 | } 32 | 33 | # handle category argument 34 | if (missing(category)) { 35 | w <- grep("^Pr\\(", names(pred))[1L] 36 | category <- names(pred)[w] 37 | pred[["fitted"]] <- pred[[w]] 38 | } else { 39 | w <- which(names(pred) == paste0("Pr(", category, ")")) 40 | if (!length(w)) { 41 | stop(sprintf("category %s not found", category)) 42 | } 43 | pred[["fitted"]] <- pred[[ w[1L] ]] 44 | } 45 | 46 | # variance(s) of average predictions 47 | vc <- NA_real_ 48 | 49 | # output 50 | structure(pred, 51 | class = c("prediction", "data.frame"), 52 | at = if (is.null(at)) at else at_specification, 53 | type = NA_character_, 54 | call = if ("call" %in% names(model)) model[["call"]] else NULL, 55 | model_class = class(model), 56 | row.names = seq_len(nrow(pred)), 57 | vcov = vc, 58 | jacobian = NULL, 59 | category = category, 60 | weighted = FALSE) 61 | } 62 | -------------------------------------------------------------------------------- /R/prediction_rlm.R: -------------------------------------------------------------------------------- 1 | #' @rdname prediction 2 | #' @export 3 | prediction.rlm <- prediction.default 4 | -------------------------------------------------------------------------------- /R/prediction_rpart.R: -------------------------------------------------------------------------------- 1 | #' @rdname prediction 2 | #' @export 3 | prediction.rpart <- 4 | function(model, 5 | data = find_data(model, parent.frame()), 6 | at = NULL, 7 | type = NULL, 8 | calculate_se = FALSE, 9 | category, 10 | ...) { 11 | 12 | if (!is.null(type)) { 13 | warning(sprintf("'type' is ignored for models of class '%s'", class(model))) 14 | } 15 | 16 | # extract predicted values 17 | data <- data 18 | if (missing(data) || is.null(data)) { 19 | pred <- make_data_frame(fitted.class = predict(model, type = "class", ...)) 20 | probs <- make_data_frame(predict(model, type = "prob", ...)) 21 | names(probs) <- paste0("Pr(", names(probs), ")") 22 | pred <- make_data_frame(pred, probs) 23 | } else { 24 | # setup data 25 | if (is.null(at)) { 26 | out <- data 27 | } else { 28 | out <- build_datalist(data, at = at, as.data.frame = TRUE) 29 | at_specification <- attr(out, "at_specification") 30 | } 31 | # calculate predictions 32 | tmp <- predict(model, newdata = out, type = "class", ...) 33 | tmp_probs <- make_data_frame(predict(model, newdata = out, type = "prob", ...)) 34 | names(tmp_probs) <- paste0("Pr(", names(tmp_probs), ")") 35 | # cbind back together 36 | pred <- make_data_frame(out, fitted.class = tmp, tmp_probs) 37 | rm(tmp, tmp_probs) 38 | } 39 | 40 | # handle category argument 41 | if (missing(category)) { 42 | w <- grep("^Pr\\(", names(pred))[1L] 43 | category <- names(pred)[w] 44 | pred[["fitted"]] <- pred[[w]] 45 | } else { 46 | w <- which(names(pred) == paste0("Pr(", category, ")")) 47 | if (!length(w)) { 48 | stop(sprintf("category %s not found", category)) 49 | } 50 | pred[["fitted"]] <- pred[[ w[1L] ]] 51 | } 52 | pred[["se.fitted"]] <- NA_real_ 53 | 54 | # variance(s) of average predictions 55 | vc <- NA_real_ 56 | 57 | # output 58 | structure(pred, 59 | class = c("prediction", "data.frame"), 60 | at = if (is.null(at)) at else at_specification, 61 | type = NA_character_, 62 | call = if ("call" %in% names(model)) model[["call"]] else NULL, 63 | model_class = class(model), 64 | row.names = seq_len(nrow(pred)), 65 | vcov = vc, 66 | jacobian = NULL, 67 | category = category, 68 | weighted = FALSE) 69 | } 70 | -------------------------------------------------------------------------------- /R/prediction_rq.R: -------------------------------------------------------------------------------- 1 | #' @rdname prediction 2 | #' @export 3 | prediction.rq <- 4 | function(model, 5 | data = find_data(model, parent.frame()), 6 | at = NULL, 7 | calculate_se = TRUE, 8 | ...) { 9 | 10 | # extract predicted value at input value 11 | data <- data 12 | if (missing(data) || is.null(data)) { 13 | pred <- data.frame(fitted = predict(model, ...), 14 | se.fitted = NA_real_) 15 | } else { 16 | # setup data 17 | if (is.null(at)) { 18 | out <- data 19 | } else { 20 | out <- build_datalist(data, at = at, as.data.frame = TRUE) 21 | at_specification <- attr(out, "at_specification") 22 | } 23 | # calculate predictions 24 | tmp <- predict(model, 25 | newdata = out, 26 | ...) 27 | # cbind back together 28 | pred <- make_data_frame(out, fitted = tmp, se.fitted = rep(NA_real_, nrow(out))) 29 | } 30 | 31 | # variance(s) of average predictions 32 | vc <- NA_real_ 33 | 34 | # output 35 | structure(pred, 36 | class = c("prediction", "data.frame"), 37 | at = if (is.null(at)) at else at_specification, 38 | type = NA_character_, 39 | call = if ("call" %in% names(model)) model[["call"]] else NULL, 40 | model_class = class(model), 41 | row.names = seq_len(nrow(pred)), 42 | vcov = vc, 43 | jacobian = NULL, 44 | weighted = FALSE) 45 | } 46 | -------------------------------------------------------------------------------- /R/prediction_selection.R: -------------------------------------------------------------------------------- 1 | #' @rdname prediction 2 | #' @export 3 | prediction.selection <- function(model, data = find_data(model, parent.frame()), at = NULL, type = "response", calculate_se = FALSE, ...) { 4 | 5 | # extract predicted value at input value 6 | data <- data 7 | if (missing(data) || is.null(data)) { 8 | pred <- make_data_frame(fitted = predict(model, type = type, ...), 9 | se.fitted = NA_real_) 10 | } else { 11 | # setup data 12 | if (is.null(at)) { 13 | out <- data 14 | } else { 15 | out <- build_datalist(data, at = at, as.data.frame = TRUE) 16 | at_specification <- attr(out, "at_specification") 17 | } 18 | # calculate predictions 19 | tmp <- predict(model, 20 | newdata = out, 21 | type = type, 22 | ...) 23 | # cbind back together 24 | pred <- make_data_frame(out, fitted = tmp, se.fitted = rep(NA_real_, length(tmp))) 25 | } 26 | 27 | # variance(s) of average predictions 28 | vc <- NA_real_ 29 | 30 | # output 31 | structure(pred, 32 | class = c("prediction", "data.frame"), 33 | at = if (is.null(at)) at else at_specification, 34 | type = type, 35 | call = if ("call" %in% names(model)) model[["call"]] else NULL, 36 | model_class = class(model), 37 | row.names = seq_len(nrow(pred)), 38 | vcov = vc, 39 | jacobian = NULL, 40 | weighted = FALSE) 41 | } 42 | -------------------------------------------------------------------------------- /R/prediction_speedglm.R: -------------------------------------------------------------------------------- 1 | #' @rdname prediction 2 | #' @export 3 | prediction.speedglm <- 4 | function(model, 5 | data = find_data(model, parent.frame()), 6 | at = NULL, 7 | type = c("response", "link"), 8 | calculate_se = FALSE, 9 | ...) { 10 | 11 | type <- match.arg(type) 12 | 13 | # extract predicted values 14 | data <- data 15 | if (missing(data) || is.null(data)) { 16 | pred <- predict(model, type = type, ...) 17 | pred <- make_data_frame(fitted = pred, se.fitted = rep(NA_real_, length(pred))) 18 | } else { 19 | # reduce memory profile 20 | model[["model"]] <- NULL 21 | 22 | # setup data 23 | out <- build_datalist(data, at = at, as.data.frame = TRUE) 24 | at_specification <- attr(out, "at_specification") 25 | # calculate predictions 26 | tmp <- predict(model, newdata = out, type = type, se.fit = FALSE, ...) 27 | # cbind back together 28 | pred <- make_data_frame(out, fitted = tmp, se.fitted = rep(NA_real_, nrow(out))) 29 | } 30 | 31 | # variance(s) of average predictions 32 | vc <- NA_real_ 33 | 34 | # output 35 | structure(pred, 36 | class = c("prediction", "data.frame"), 37 | at = if (is.null(at)) at else at_specification, 38 | type = type, 39 | call = if ("call" %in% names(model)) model[["call"]] else NULL, 40 | model_class = class(model), 41 | row.names = seq_len(nrow(pred)), 42 | vcov = vc, 43 | jacobian = NULL, 44 | weighted = FALSE) 45 | } 46 | -------------------------------------------------------------------------------- /R/prediction_speedlm.R: -------------------------------------------------------------------------------- 1 | #' @rdname prediction 2 | #' @export 3 | prediction.speedlm <- 4 | function(model, 5 | data = find_data(model, parent.frame()), 6 | at = NULL, 7 | calculate_se = FALSE, 8 | ...) { 9 | 10 | # extract predicted values 11 | data <- data 12 | if (missing(data) || is.null(data)) { 13 | pred <- predict(model, ...) 14 | pred <- make_data_frame(fitted = pred, se.fitted = rep(NA_real_, length(pred))) 15 | } else { 16 | # setup data 17 | data <- build_datalist(data, at = at, as.data.frame = TRUE) 18 | at_specification <- attr(data, "at_specification") 19 | # calculate predictions 20 | tmp <- predict(model, newdata = data, ...) 21 | # cbind back together 22 | pred <- make_data_frame(data, fitted = tmp, se.fitted = rep(NA_real_, nrow(data))) 23 | } 24 | 25 | # variance(s) of average predictions 26 | vc <- NA_real_ 27 | 28 | # output 29 | structure(pred, 30 | class = c("prediction", "data.frame"), 31 | at = if (is.null(at)) at else at_specification, 32 | type = "response", 33 | call = if ("call" %in% names(model)) model[["call"]] else NULL, 34 | model_class = class(model), 35 | row.names = seq_len(nrow(pred)), 36 | vcov = vc, 37 | jacobian = NULL, 38 | weighted = FALSE) 39 | } 40 | -------------------------------------------------------------------------------- /R/prediction_survreg.R: -------------------------------------------------------------------------------- 1 | #' @rdname prediction 2 | #' @export 3 | prediction.survreg <- 4 | function(model, 5 | data = find_data(model, parent.frame()), 6 | at = NULL, 7 | type = c("response", "lp", "quantile", "uquantile"), 8 | calculate_se = TRUE, 9 | ...) { 10 | 11 | type <- match.arg(type) 12 | 13 | # extract predicted values 14 | data <- data 15 | if (missing(data) || is.null(data)) { 16 | pred <- predict(model, type = type, se.fit = TRUE, ...) 17 | pred <- make_data_frame(fitted = pred[["fit"]], se.fitted = pred[["se.fit"]]) 18 | } else { 19 | # setup data 20 | if (is.null(at)) { 21 | out <- data 22 | } else { 23 | out <- build_datalist(data, at = at, as.data.frame = TRUE) 24 | at_specification <- attr(out, "at_specification") 25 | } 26 | # calculate predictions 27 | tmp <- predict(model, newdata = out, type = type, se.fit = TRUE, ...) 28 | # cbind back together 29 | pred <- make_data_frame(out, fitted = tmp[["fit"]], se.fitted = tmp[["se.fit"]]) 30 | } 31 | 32 | # variance(s) of average predictions 33 | vc <- NA_real_ 34 | 35 | # output 36 | structure(pred, 37 | class = c("prediction", "data.frame"), 38 | at = if (is.null(at)) at else at_specification, 39 | type = type, 40 | call = if ("call" %in% names(model)) model[["call"]] else NULL, 41 | model_class = class(model), 42 | row.names = seq_len(nrow(pred)), 43 | vcov = vc, 44 | jacobian = NULL, 45 | weighted = FALSE) 46 | } 47 | -------------------------------------------------------------------------------- /R/prediction_svm.R: -------------------------------------------------------------------------------- 1 | #' @rdname prediction 2 | #' @export 3 | prediction.svm <- 4 | function(model, 5 | data = NULL, 6 | at = NULL, 7 | calculate_se = TRUE, 8 | category, 9 | ...) { 10 | 11 | # extract predicted value 12 | data <- data 13 | anyp <- grep("prob.+", names(model)) 14 | if (length(anyp) && !is.null(model[[ anyp[1L] ]])) { 15 | probability <- TRUE 16 | } else { 17 | probability <- FALSE 18 | } 19 | if (missing(data) || is.null(data)) { 20 | tmp <- predict(model, decision.values = TRUE, probability = probability, ...) 21 | pred <- data.frame(fitted.class = tmp) 22 | attributes(pred[["fitted.class"]]) <- NULL 23 | if (!is.null(attributes(tmp)[["probabilities"]])) { 24 | probs <- data.frame(attributes(tmp)[["probabilities"]]) 25 | names(probs) <- paste0("Pr(", names(probs), ")") 26 | pred <- make_data_frame(pred, probs) 27 | } 28 | if (!is.null(attributes(tmp)[["decision.values"]])) { 29 | dvs <- data.frame(attributes(tmp)[["decision.values"]]) 30 | names(dvs) <- paste0("dv(", names(dvs), ")") 31 | pred <- make_data_frame(pred, dvs) 32 | } 33 | } else { 34 | if (is.null(at)) { 35 | out <- data 36 | } else { 37 | out <- build_datalist(data, at = at, as.data.frame = TRUE) 38 | at_specification <- attr(out, "at_specification") 39 | } 40 | tmp <- predict(model, newdata = out, decision.values = TRUE, probability = probability, ...) 41 | pred <- make_data_frame(out, fitted.class = tmp) 42 | attributes(pred[["fitted.class"]]) <- NULL 43 | if (!is.null(attributes(tmp)[["probabilities"]])) { 44 | probs <- data.frame(attributes(tmp)[["probabilities"]]) 45 | names(probs) <- paste0("Pr(", names(probs), ")") 46 | pred <- make_data_frame(pred, probs) 47 | } 48 | if (!is.null(attributes(tmp)[["decision.values"]])) { 49 | dvs <- data.frame(attributes(tmp)[["decision.values"]]) 50 | names(dvs) <- paste0("dv(", names(dvs), ")") 51 | pred <- make_data_frame(pred, dvs) 52 | } 53 | } 54 | 55 | # handle category argument 56 | if (missing(category)) { 57 | w <- grep("^Pr\\(", names(pred))[1L] 58 | if (is.na(w)) { 59 | pred[["fitted"]] <- NA_real_ 60 | category <- NULL 61 | } else { 62 | category <- names(pred)[w] 63 | pred[["fitted"]] <- pred[[w]] 64 | } 65 | } else { 66 | w <- which(names(pred) == paste0("Pr(", category, ")")) 67 | if (!length(w)) { 68 | stop(sprintf("category %s not found", category)) 69 | } 70 | pred[["fitted"]] <- pred[[ w[1L] ]] 71 | } 72 | pred[["se.fitted"]] <- NA_real_ 73 | 74 | # obs-x-(ncol(data)+2+nlevels(outcome)) data.frame of predictions 75 | # variance(s) of average predictions 76 | vc <- NA_real_ 77 | 78 | # output 79 | structure(pred, 80 | class = c("prediction", "data.frame"), 81 | at = if (is.null(at)) at else at_specification, 82 | type = NA_character_, 83 | call = if ("call" %in% names(model)) model[["call"]] else NULL, 84 | model_class = class(model), 85 | row.names = seq_len(nrow(pred)), 86 | vcov = vc, 87 | jacobian = NULL, 88 | category = category, 89 | weighted = FALSE) 90 | } 91 | -------------------------------------------------------------------------------- /R/prediction_svyglm.R: -------------------------------------------------------------------------------- 1 | #' @rdname prediction 2 | #' @export 3 | prediction.svyglm <- 4 | function(model, 5 | data = find_data(model, parent.frame()), 6 | at = NULL, 7 | type = c("response", "link"), 8 | calculate_se = TRUE, 9 | ...) { 10 | 11 | type <- match.arg(type) 12 | 13 | # extract predicted values 14 | data <- data 15 | if (missing(data) || is.null(data)) { 16 | pred <- predict(model, type = type, se.fit = TRUE, ...) 17 | pred <- data.frame(fitted = unclass(pred), 18 | se.fitted = sqrt(unname(attributes(pred)[["var"]]))) 19 | } else { 20 | # setup data 21 | if (is.null(at)) { 22 | out <- data 23 | } else { 24 | out <- build_datalist(data, at = at, as.data.frame = TRUE) 25 | at_specification <- attr(out, "at_specification") 26 | } 27 | # calculate predictions 28 | tmp <- predict(model, newdata = out, type = type, se.fit = TRUE, ...) 29 | pred <- make_data_frame(out, fitted = unclass(tmp), se.fitted = sqrt(unname(attributes(tmp)[["var"]]))) 30 | } 31 | 32 | # variance(s) of average predictions 33 | vc <- NA_real_ 34 | 35 | # output 36 | structure(pred, 37 | class = c("prediction", "data.frame"), 38 | at = if (is.null(at)) at else at_specification, 39 | type = type, 40 | call = if ("call" %in% names(model)) model[["call"]] else NULL, 41 | model_class = class(model), 42 | row.names = seq_len(nrow(pred)), 43 | vcov = vc, 44 | jacobian = NULL, 45 | weighted = TRUE) 46 | } 47 | -------------------------------------------------------------------------------- /R/prediction_train.R: -------------------------------------------------------------------------------- 1 | #' @rdname prediction 2 | #' @export 3 | prediction.train <- 4 | function(model, 5 | data = find_data(model), 6 | at = NULL, 7 | type = c("raw", "prob"), 8 | ...) { 9 | 10 | type <- match.arg(type) 11 | 12 | # extract predicted values 13 | data <- data 14 | if (missing(data) || is.null(data)) { 15 | pred <- predict(model, type = type, se.fit = FALSE, ...) 16 | pred <- make_data_frame(fitted = pred, se.fitted = rep(NA_real_, length(pred))) 17 | } else { 18 | # setup data 19 | data <- build_datalist(data, at = at, as.data.frame = TRUE) 20 | at_specification <- attr(data, "at_specification") 21 | # calculate predictions 22 | tmp <- predict(model, newdata = data, type = type, se.fit = FALSE, ...) 23 | # cbind back together 24 | pred <- make_data_frame(data, fitted = tmp, se.fitted = rep(NA_real_, nrow(data))) 25 | } 26 | 27 | # variance(s) of average predictions 28 | vc <- NA_real_ 29 | 30 | # output 31 | structure(pred, 32 | class = c("prediction", "data.frame"), 33 | at = if (is.null(at)) at else at_specification, 34 | type = type, 35 | call = if ("call" %in% names(model)) model[["call"]] else NULL, 36 | model_class = class(model), 37 | row.names = seq_len(nrow(pred)), 38 | vcov = vc, 39 | jacobian = NULL, 40 | weighted = FALSE) 41 | } 42 | -------------------------------------------------------------------------------- /R/prediction_tree.R: -------------------------------------------------------------------------------- 1 | # @rdname prediction 2 | # @export 3 | prediction.tree <- 4 | function(model, 5 | data = find_data(model, parent.frame()), 6 | at = NULL, 7 | type = NULL, 8 | calculate_se = FALSE, 9 | category, 10 | ...) { 11 | 12 | if (!is.null(type)) { 13 | warning(sprintf("'type' is ignored for models of class '%s'", class(model))) 14 | } 15 | 16 | # extract predicted values 17 | data <- data 18 | if (missing(data) || is.null(data)) { 19 | if (is.factor(model[["y"]])) { 20 | pred <- make_data_frame(fitted.class = predict(model, type = "class", ...)) 21 | probs <- make_data_frame(predict(model, type = "vector", ...)) 22 | names(probs) <- paste0("Pr(", names(probs), ")") 23 | } else { 24 | pred <- make_data_frame(fitted = predict(model, type = "vector"), 25 | fitted.class = predict(model, type = "class", ...)) 26 | } 27 | pred <- make_data_frame(pred, probs) 28 | } else { 29 | # setup data 30 | if (is.null(at)) { 31 | out <- data 32 | } else { 33 | out <- build_datalist(data, at = at, as.data.frame = TRUE) 34 | at_specification <- attr(out, "at_specification") 35 | } 36 | # calculate predictions 37 | tmp <- predict(model, newdata = out, type = "class", ...) 38 | tmp_probs <- make_data_frame(predict(model, newdata = out, type = "probs", ...)) 39 | names(tmp_probs) <- paste0("Pr(", names(tmp_probs), ")") 40 | # cbind back together 41 | pred <- make_data_frame(out, fitted.class = tmp, tmp_probs) 42 | rm(tmp, tmp_probs) 43 | } 44 | 45 | # handle category argument 46 | if (missing(category)) { 47 | w <- grep("^Pr\\(", names(pred))[1L] 48 | category <- names(pred)[w] 49 | pred[["fitted"]] <- pred[[w]] 50 | } else { 51 | w <- which(names(pred) == paste0("Pr(", category, ")")) 52 | if (!length(w)) { 53 | stop(sprintf("category %s not found", category)) 54 | } 55 | pred[["fitted"]] <- pred[[ w[1L] ]] 56 | } 57 | pred[["se.fitted"]] <- NA_real_ 58 | 59 | # variance(s) of average predictions 60 | vc <- NA_real_ 61 | 62 | # output 63 | structure(pred, 64 | class = c("prediction", "data.frame"), 65 | at = if (is.null(at)) at else at_specification, 66 | type = NA_character_, 67 | call = if ("call" %in% names(model)) model[["call"]] else NULL, 68 | model_class = class(model), 69 | row.names = seq_len(nrow(pred)), 70 | vcov = vc, 71 | jacobian = NULL, 72 | category = category, 73 | weighted = FALSE) 74 | } 75 | -------------------------------------------------------------------------------- /R/prediction_truncreg.R: -------------------------------------------------------------------------------- 1 | #' @rdname prediction 2 | #' @export 3 | prediction.truncreg <- function(model, data, at = NULL, calculate_se = FALSE, ...) { 4 | 5 | # extract predicted values 6 | if (missing(data) || is.null(data)) { 7 | pred <- make_data_frame(fitted = predict(object = model, ...)) 8 | } else { 9 | # setup data 10 | if (is.null(at)) { 11 | out <- data 12 | } else { 13 | out <- build_datalist(data, at = at, as.data.frame = TRUE) 14 | at_specification <- attr(out, "at_specification") 15 | } 16 | pred <- make_data_frame(fitted = predict(model, newdata = data, ...)) 17 | } 18 | pred[["se.fitted"]] <- NA_real_ 19 | 20 | # variance(s) of average predictions 21 | vc <- NA_real_ 22 | 23 | # output 24 | structure(pred, 25 | class = c("prediction", "data.frame"), 26 | at = if (is.null(at)) at else at_specification, 27 | type = NA_character_, 28 | call = if ("call" %in% names(model)) model[["call"]] else NULL, 29 | model_class = class(model), 30 | row.names = seq_len(nrow(pred)), 31 | vcov = vc, 32 | jacobian = NULL, 33 | weighted = FALSE) 34 | } 35 | -------------------------------------------------------------------------------- /R/prediction_vgam.R: -------------------------------------------------------------------------------- 1 | # @rdname prediction 2 | # @export 3 | prediction.vgam <- 4 | function(model, 5 | data = find_data(model, parent.frame()), 6 | at = NULL, 7 | type = c("response", "link"), 8 | calculate_se = FALSE, 9 | category, 10 | ...) { 11 | 12 | type <- match.arg(type) 13 | 14 | # extract predicted values 15 | data <- data 16 | if (missing(data) || is.null(data)) { 17 | pred <- make_data_frame(predict(model, type = type, se.fit = FALSE, ...)) 18 | } else { 19 | # setup data 20 | if (is.null(at)) { 21 | out <- data 22 | } else { 23 | out <- build_datalist(data, at = at, as.data.frame = TRUE) 24 | at_specification <- attr(out, "at_specification") 25 | } 26 | # calculate predictions 27 | tmp <- predict(model, newdata = out, type = type, se.fit = FALSE, ...) 28 | if (!is.null(dim(tmp))) { 29 | tmp <- as.matrix(tmp, ncol = 1) 30 | } 31 | # cbind back together 32 | pred <- make_data_frame(out, fitted = make_data_frame(tmp), se.fitted = rep(NA_real_, nrow(out))) 33 | } 34 | 35 | # handle category argument 36 | if (missing(category)) { 37 | category <- names(pred)[!names(pred) %in% names(data)][1L] 38 | pred[["fitted"]] <- pred[[category]] 39 | } else { 40 | w <- grep(category, names(pred)) 41 | if (!length(w)) { 42 | stop(sprintf("category %s not found", category)) 43 | } 44 | pred[["fitted"]] <- pred[[ w[1L] ]] 45 | } 46 | 47 | # variance(s) of average predictions 48 | vc <- NA_real_ 49 | 50 | # output 51 | structure(pred, 52 | class = c("prediction", "data.frame"), 53 | at = if (is.null(at)) at else at_specification, 54 | type = type, 55 | call = if ("call" %in% names(model)) model[["call"]] else NULL, 56 | model_class = class(model), 57 | row.names = seq_len(nrow(pred)), 58 | vcov = vc, 59 | jacobian = NULL, 60 | category = category, 61 | weighted = FALSE) 62 | } 63 | -------------------------------------------------------------------------------- /R/prediction_vglm.R: -------------------------------------------------------------------------------- 1 | # @rdname prediction 2 | # @export 3 | prediction.vglm <- 4 | function(model, 5 | data = find_data(model, parent.frame()), 6 | at = NULL, 7 | type = c("response", "link"), 8 | calculate_se = TRUE, 9 | category, 10 | ...) { 11 | 12 | type <- match.arg(type) 13 | 14 | # extract predicted values 15 | data <- data 16 | arg <- list(...) 17 | if (missing(data) || is.null(data)) { 18 | if ("se.fit" %in% names(arg)) { 19 | tmp <- predict(model, type = type, ...) 20 | pred <- make_data_frame(tmp[["fitted.values"]], se.fitted = tmp[["se.fit"]]) 21 | } else { 22 | pred <- make_data_frame(predict(model, type = type, se.fit = FALSE, ...)) 23 | } 24 | } else { 25 | # setup data 26 | if (is.null(at)) { 27 | out <- data 28 | } else { 29 | out <- build_datalist(data, at = at, as.data.frame = TRUE) 30 | at_specification <- attr(out, "at_specification") 31 | } 32 | # calculate predictions 33 | if ("se.fit" %in% names(arg)) { 34 | tmp <- predict(model, newdata = out, type = type, ...) 35 | # cbind back together 36 | pred <- make_data_frame(out, tmp[["fitted.values"]], se.fitted = tmp[["se.fit"]]) 37 | } else { 38 | tmp <- predict(model, newdata = out, type = type, ...) 39 | # cbind back together 40 | pred <- make_data_frame(out, tmp[["fitted.values"]], se.fitted = rep(NA_real_, nrow(out))) 41 | } 42 | rm(tmp) 43 | } 44 | 45 | # handle category argument 46 | if (missing(category)) { 47 | category <- names(pred)[!names(pred) %in% names(data)][1L] 48 | pred[["fitted"]] <- pred[[category]] 49 | } else { 50 | w <- grep(category, names(pred)) 51 | if (!length(w)) { 52 | stop(sprintf("category %s not found", category)) 53 | } 54 | pred[["fitted"]] <- pred[[ w[1L] ]] 55 | } 56 | 57 | # variance(s) of average predictions 58 | vc <- NA_real_ 59 | 60 | # output 61 | structure(pred, 62 | class = c("prediction", "data.frame"), 63 | at = if (is.null(at)) at else at_specification, 64 | type = type, 65 | call = if ("call" %in% names(model)) model[["call"]] else NULL, 66 | model_class = class(model), 67 | row.names = seq_len(nrow(pred)), 68 | vcov = vc, 69 | jacobian = NULL, 70 | category = category, 71 | weighted = FALSE) 72 | } 73 | -------------------------------------------------------------------------------- /R/prediction_zeroinfl.R: -------------------------------------------------------------------------------- 1 | #' @rdname prediction 2 | #' @export 3 | prediction.zeroinfl <- prediction.hurdle 4 | -------------------------------------------------------------------------------- /R/print.R: -------------------------------------------------------------------------------- 1 | #' @export 2 | print.prediction <- function(x, digits = 4, ...) { 3 | 4 | # gather metadata 5 | f <- x[["fitted"]] 6 | fc <- x[["fitted.class"]] 7 | ## at 8 | at <- attributes(x)[["at"]] 9 | at_names <- setdiff(names(attr(x, "at")), "index") 10 | 11 | ## weights 12 | is_weighted <- attr(x, "weighted") 13 | if (isTRUE(is_weighted)) { 14 | wts <- x[["_weights"]] 15 | } 16 | 17 | # calculate overall predictions 18 | ## if no 'at_specification', simply calculate overall average/mode and print 19 | if (is.null(at)) { 20 | # object is a single replication with no 'at' specification 21 | if ("fitted.class" %in% names(x) || is.list(fc)) { 22 | # factor outcome 23 | m <- sort(table(x[["fitted.class"]]), decreasing = TRUE)[1L] 24 | message( 25 | sprintf("Data frame with %d %s%swith modal prediction (of %d %s):", 26 | length(fc), 27 | ngettext(length(fc), "prediction", "predictions"), 28 | if (!is.null(attr(x, "call"))) sprintf(" from\n %s\n", paste0(deparse(attr(x, "call")), collapse = "\n")) else "", 29 | nlevels(factor(fc)), 30 | ngettext(nlevels(f), "level", "levels"), 31 | shQuote(names(m)) 32 | ) 33 | ) 34 | } else { 35 | # numeric outcome 36 | message( 37 | sprintf("Data frame with %d %s%swith average prediction: %s", 38 | length(f), 39 | ngettext(length(fc), "prediction", "predictions"), 40 | if (!is.null(attr(x, "call"))) sprintf(" from\n %s\n", paste0(deparse(attr(x, "call")), collapse = "\n")) else "", 41 | sprintf(paste0("%0.", digits, "f"), mean(f, na.rm = TRUE)) 42 | ) 43 | ) 44 | } 45 | } else { 46 | # otherwise, object has an 'at' specification, reflecting multiple requested predictions 47 | 48 | # convert 'at_specification' into data frame 49 | xby <- x[ , setdiff(names(at), "index"), drop = FALSE] 50 | 51 | if ("fitted.class" %in% names(x) || is.list(fc)) { 52 | # factor outcome 53 | out <- aggregate(x[["fitted.class"]], xby, FUN = function(set) names(sort(table(set), decreasing = TRUE))[1L]) 54 | message( 55 | sprintf("Data frame with %d %s%swith modal %s (of %d %s):", 56 | nrow(x), 57 | ngettext(nrow(x), "prediction", "predictions"), 58 | if (!is.null(attr(x, "call"))) sprintf(" from\n %s\n", paste0(deparse(attr(x, "call")), collapse = "\n")) else "", 59 | ngettext(nrow(out), "prediction", "predictions"), 60 | nlevels(factor(fc)), 61 | ngettext(nlevels(fc), "level", "levels") 62 | ) 63 | ) 64 | } else { 65 | # numeric outcome 66 | out <- aggregate(x[["fitted"]], xby, FUN = mean, na.rm = TRUE) 67 | message( 68 | sprintf("Data frame with %d %s%swith average %s:", 69 | nrow(x), 70 | ngettext(nrow(x), "prediction", "predictions"), 71 | if (!is.null(attr(x, "call"))) sprintf(" from\n %s\n", paste0(deparse(attr(x, "call")), collapse = "\n")) else "", 72 | ngettext(nrow(out), "prediction", "predictions") 73 | ) 74 | ) 75 | } 76 | print(out, digits = digits, row.names = FALSE, ...) 77 | } 78 | 79 | # return invisibly 80 | invisible(x) 81 | } 82 | -------------------------------------------------------------------------------- /R/seq_range.R: -------------------------------------------------------------------------------- 1 | #' @title Create a sequence over the range of a vector 2 | #' @description Define a sequence of evenly spaced values from the minimum to the maximum of a vector 3 | #' @param x A numeric vector 4 | #' @param n An integer specifying the length of sequence (i.e., number of points across the range of \code{x}) 5 | #' @return A vector of length \code{n}. 6 | #' @examples 7 | #' identical(range(1:5), seq_range(1:5, n = 2)) 8 | #' seq_range(1:5, n = 3) 9 | #' 10 | #' @seealso \code{\link{mean_or_mode}}, \code{\link{build_datalist}} 11 | #' @export 12 | seq_range <- function(x, n = 2) { 13 | seq(min(x, na.rm = TRUE), 14 | max(x, na.rm = TRUE), 15 | length.out = n) 16 | } 17 | -------------------------------------------------------------------------------- /R/summary.R: -------------------------------------------------------------------------------- 1 | #' @import stats 2 | #' @export 3 | summary.prediction <- function(object, level = 0.95, ...) { 4 | # summary method 5 | 6 | # gather metadata 7 | f <- object[["fitted"]] 8 | fc <- object[["fitted.class"]] 9 | vc <- attributes(object)[["vcov"]] 10 | if (is.null(vc)) { 11 | vc <- NA_real_ 12 | } 13 | 14 | # convert 'at_specification' into data frame 15 | at <- attributes(object)[["at"]] 16 | # aggregate average predictions from data 17 | if (is.null(at)) { 18 | objectby <- list(rep(1L, nrow(object))) 19 | out <- aggregate(object[["fitted"]], objectby, FUN = mean, na.rm = TRUE) 20 | out[["Group.1"]] <- NULL 21 | } else { 22 | objectby <- object[ , setdiff(names(at), "index"), drop = FALSE] 23 | 24 | out <- aggregate(object[["fitted"]], objectby, FUN = mean, na.rm = TRUE) 25 | } 26 | 27 | # extract calculated variance from object 28 | out[["SE"]] <- sqrt(vc) 29 | 30 | # cleanup output 31 | names(out)[names(out) == "x"] <- "Prediction" 32 | at_names <- names(out)[!names(out) %in% c("Prediction", "SE")] 33 | at_names <- if (length(at_names)) paste0("at(", at_names, ")") else NULL 34 | names(out)[!names(out) %in% c("Prediction", "SE")] <- at_names 35 | 36 | # add z and p 37 | out[["z"]] <- out[,"Prediction"]/out[,"SE"] 38 | out[["p"]] <- 2 * pnorm(abs(out[,"z"]), lower.tail = FALSE) 39 | 40 | # add CI 41 | a <- (1 - level)/2 42 | a <- c(a, 1 - a) 43 | fac <- qnorm(a) 44 | ci <- array(NA_real_, dim = c(nrow(out), 2L)) 45 | ci[] <- out[["Prediction"]] + out[["SE"]] %o% fac 46 | colnames(ci) <- c("lower", "upper") 47 | out <- cbind(out, ci) 48 | 49 | # return 50 | structure(out[, c(at_names, "Prediction", "SE", "z", "p", "lower", "upper"), drop = FALSE], 51 | class = c("summary.prediction", "data.frame")) 52 | } 53 | 54 | #' @export 55 | print.summary.prediction <- function(x, digits = 4, ...) { 56 | print(`class<-`(x, "data.frame"), digits = digits, row.names = FALSE, ...) 57 | } 58 | 59 | #' @rdname prediction 60 | #' @param level A numeric value specifying the confidence level for calculating p-values and confidence intervals. 61 | #' @export 62 | prediction_summary <- function(model, ..., level = 0.95) { 63 | predictions <- prediction(model, ...) 64 | summary(predictions, level = 0.95) 65 | } 66 | -------------------------------------------------------------------------------- /R/utils.R: -------------------------------------------------------------------------------- 1 | #' @importFrom utils head 2 | #' @export 3 | head.prediction <- function(x, ...) { 4 | head(`class<-`(x, "data.frame"), ...) 5 | } 6 | 7 | #' @importFrom utils tail 8 | #' @export 9 | tail.prediction <- function(x, ...) { 10 | tail(`class<-`(x, "data.frame"), ...) 11 | } 12 | -------------------------------------------------------------------------------- /appveyor.yml: -------------------------------------------------------------------------------- 1 | # Download script file from GitHub 2 | init: 3 | ps: | 4 | $ErrorActionPreference = "Stop" 5 | Invoke-WebRequest http://raw.github.com/krlmlr/r-appveyor/master/scripts/appveyor-tool.ps1 -OutFile "..\appveyor-tool.ps1" 6 | Import-Module '..\appveyor-tool.ps1' 7 | 8 | install: 9 | ps: Bootstrap 10 | 11 | build_script: 12 | - travis-tool.sh install_deps 13 | 14 | test_script: 15 | - travis-tool.sh run_tests 16 | 17 | artifacts: 18 | - path: '*.Rcheck\**\*.log' 19 | name: Logs 20 | 21 | - path: '*.Rcheck\**\*.out' 22 | name: Logs 23 | 24 | - path: '*.Rcheck\**\*.fail' 25 | name: Logs 26 | 27 | - path: '*.Rcheck\**\*.Rout' 28 | name: Logs 29 | 30 | - path: '\*_*.tar.gz' 31 | name: Bits 32 | 33 | - path: '\*_*.zip' 34 | name: Bits 35 | -------------------------------------------------------------------------------- /data-raw/margex.R: -------------------------------------------------------------------------------- 1 | # build script for 'margex' dataset 2 | 3 | # load packages 4 | requireNamespace("margex") 5 | requireNamespace("rio") 6 | 7 | # load data 8 | webuse::webuse("margex") 9 | 10 | # factorize 11 | margex$sex <- rio::factorize(margex$sex) 12 | margex$group <- factor(margex$group) 13 | margex$agegroup <- rio::factorize(margex$agegroup) 14 | margex$treatment <- factor(margex$treatment) 15 | margex$arm <- factor(margex$arm) 16 | 17 | # drop attributes 18 | attr(margex$y, "format.stata") <- NULL 19 | attr(margex$outcome, "format.stata") <- NULL 20 | attr(margex$age, "format.stata") <- NULL 21 | attr(margex$distance, "format.stata") <- NULL 22 | attr(margex$ycn, "format.stata") <- NULL 23 | attr(margex$yc, "format.stata") <- NULL 24 | attr(margex$arm, "format.stata") <- NULL 25 | 26 | # overwrite 27 | devtools::use_data(margex, overwrite = TRUE) 28 | -------------------------------------------------------------------------------- /data/margex.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/leeper/prediction/c239565c6b029e339969d1d13a480b66ffd438e9/data/margex.rda -------------------------------------------------------------------------------- /docs/ISSUE_TEMPLATE.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | NA • prediction 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 48 | 49 | 50 | 51 | 52 | 53 |
54 |
55 | 98 | 99 | 100 |
101 | 102 |
103 |
104 |
105 |

NA

106 |
107 | 108 | 109 |

Please specify whether your issue is about:

110 |
    111 |
  • [ ] a possible bug
    • 112 |
  • [ ] a question about package functionality
    • 113 |
  • [ ] a suggested code or documentation change, improvement to the code, or feature request
    • 114 |
115 |

If you are reporting (1) a bug or (2) a question about code, please supply:

116 | 123 |

Put your code here:

124 | 
## load package
125 | library("prediction")
126 | 
127 | ## code goes here
128 | 
129 | 
130 | ## session info for your system
131 | sessionInfo()
132 | 133 | 134 |
135 | 136 |
137 | 138 | 139 |
140 |
141 |

Developed by Thomas J. Leeper.

142 |
143 | 144 |
145 |

Site built with pkgdown 1.3.0.

146 |
147 |
148 |
149 | 150 | 151 | 152 | 153 | 154 | 155 | -------------------------------------------------------------------------------- /docs/LICENSE-text.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | License • prediction 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 48 | 49 | 50 | 51 | 52 | 53 |
54 |
55 | 98 | 99 | 100 |
101 | 102 |
103 |
104 |
105 |

License

106 |
107 | 108 | 
YEAR: 2016-2018
109 | COPYRIGHT HOLDER: Thomas J. Leeper
110 |
111 | 112 |
113 | 114 |
115 | 116 | 117 |
118 |
119 |

Developed by Thomas J. Leeper.

120 |
121 | 122 |
123 |

Site built with pkgdown 1.3.0.

124 |
125 |
126 |
127 | 128 | 129 | 130 | 131 | 132 | 133 | -------------------------------------------------------------------------------- /docs/LICENSE.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | The MIT License (MIT) • prediction 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 48 | 49 | 50 | 51 | 52 | 53 |
54 |
55 | 98 | 99 | 100 |
101 | 102 |
103 |
104 |
105 |

The MIT License (MIT)

106 |
107 | 108 |
109 | 110 |

Copyright © 2016-2018 Thomas J. Leeper

111 |

Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the “Software”), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:

112 |

The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.

113 |

THE SOFTWARE IS PROVIDED “AS IS”, WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

114 |
115 | 116 |
117 | 118 |
119 | 120 | 121 |
122 |
123 |

Developed by Thomas J. Leeper.

124 |
125 | 126 |
127 |

Site built with pkgdown 1.3.0.

128 |
129 |
130 |
131 | 132 | 133 | 134 | 135 | 136 | 137 | -------------------------------------------------------------------------------- /docs/PULL_REQUEST_TEMPLATE.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | NA • prediction 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 48 | 49 | 50 | 51 | 52 | 53 |
54 |
55 | 98 | 99 | 100 |
101 | 102 |
103 |
104 |
105 |

NA

106 |
107 | 108 | 109 |

Please ensure the following before submitting a PR:

110 |
    111 |
  • [ ] if suggesting code changes or improvements, open an issue first
    • 112 |
  • [ ] for all but trivial changes (e.g., typo fixes), add your name to DESCRIPTION 113 |
    • 114 |
  • [ ] for all but trivial changes (e.g., typo fixes), documentation your change in NEWS.md with a parenthetical reference to the issue number being addressed
    • 115 |
  • [ ] if changing documentation, edit files in /R not /man and run devtools::document() to update documentation
    • 116 |
  • [ ] add code or new test files to /tests for any new functionality or bug fix
    • 117 |
  • [ ] make sure R CMD check runs without error before submitting the PR
    • 118 |
119 | 120 | 121 |
122 | 123 |
124 | 125 | 126 |
127 |
128 |

Developed by Thomas J. Leeper.

129 |
130 | 131 |
132 |

Site built with pkgdown 1.3.0.

133 |
134 |
135 |
136 | 137 | 138 | 139 | 140 | 141 | 142 | -------------------------------------------------------------------------------- /docs/authors.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | Citation and Authors • prediction 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 48 | 49 | 50 | 51 | 52 | 53 |
54 |
55 | 98 | 99 | 100 |
101 | 102 |
103 |
104 |
105 |

Citation

106 | Source: inst/CITATION 107 |
108 | 109 |

Leeper TJ (2019). 110 | prediction: Tidy, Type-Safe 'prediction()' Methods. 111 | R package version 0.3.13. 112 |

113 | 
@Manual{,
114 |   title = {prediction: Tidy, Type-Safe 'prediction()' Methods},
115 |   author = {Thomas J. Leeper},
116 |   year = {2019},
117 |   note = {R package version 0.3.13},
118 | }
119 |
120 |

Authors

121 |
122 | 123 |
    124 |
  • 125 |

    Thomas J. Leeper. Author, maintainer. ORCID 126 |

    127 |
    • 128 |
  • 129 |

    Carl Ganz. Contributor. 130 |

    131 |
    • 132 |
133 | 134 |
135 | 136 |
137 | 138 | 139 |
140 |
141 |

Developed by Thomas J. Leeper.

142 |
143 | 144 |
145 |

Site built with pkgdown 1.3.0.

146 |
147 |
148 |
149 | 150 | 151 | 152 | 153 | 154 | 155 | -------------------------------------------------------------------------------- /docs/docsearch.js: -------------------------------------------------------------------------------- 1 | $(function() { 2 | 3 | // register a handler to move the focus to the search bar 4 | // upon pressing shift + "/" (i.e. "?") 5 | $(document).on('keydown', function(e) { 6 | if (e.shiftKey && e.keyCode == 191) { 7 | e.preventDefault(); 8 | $("#search-input").focus(); 9 | } 10 | }); 11 | 12 | $(document).ready(function() { 13 | // do keyword highlighting 14 | /* modified from https://jsfiddle.net/julmot/bL6bb5oo/ */ 15 | var mark = function() { 16 | 17 | var referrer = document.URL ; 18 | var paramKey = "q" ; 19 | 20 | if (referrer.indexOf("?") !== -1) { 21 | var qs = referrer.substr(referrer.indexOf('?') + 1); 22 | var qs_noanchor = qs.split('#')[0]; 23 | var qsa = qs_noanchor.split('&'); 24 | var keyword = ""; 25 | 26 | for (var i = 0; i < qsa.length; i++) { 27 | var currentParam = qsa[i].split('='); 28 | 29 | if (currentParam.length !== 2) { 30 | continue; 31 | } 32 | 33 | if (currentParam[0] == paramKey) { 34 | keyword = decodeURIComponent(currentParam[1].replace(/\+/g, "%20")); 35 | } 36 | } 37 | 38 | if (keyword !== "") { 39 | $(".contents").unmark({ 40 | done: function() { 41 | $(".contents").mark(keyword); 42 | } 43 | }); 44 | } 45 | } 46 | }; 47 | 48 | mark(); 49 | }); 50 | }); 51 | 52 | /* Search term highlighting ------------------------------*/ 53 | 54 | function matchedWords(hit) { 55 | var words = []; 56 | 57 | var hierarchy = hit._highlightResult.hierarchy; 58 | // loop to fetch from lvl0, lvl1, etc. 59 | for (var idx in hierarchy) { 60 | words = words.concat(hierarchy[idx].matchedWords); 61 | } 62 | 63 | var content = hit._highlightResult.content; 64 | if (content) { 65 | words = words.concat(content.matchedWords); 66 | } 67 | 68 | // return unique words 69 | var words_uniq = [...new Set(words)]; 70 | return words_uniq; 71 | } 72 | 73 | function updateHitURL(hit) { 74 | 75 | var words = matchedWords(hit); 76 | var url = ""; 77 | 78 | if (hit.anchor) { 79 | url = hit.url_without_anchor + '?q=' + escape(words.join(" ")) + '#' + hit.anchor; 80 | } else { 81 | url = hit.url + '?q=' + escape(words.join(" ")); 82 | } 83 | 84 | return url; 85 | } 86 | -------------------------------------------------------------------------------- /docs/favicon.ico: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/leeper/prediction/c239565c6b029e339969d1d13a480b66ffd438e9/docs/favicon.ico -------------------------------------------------------------------------------- /docs/jquery.sticky-kit.min.js: -------------------------------------------------------------------------------- 1 | /* Sticky-kit v1.1.2 | WTFPL | Leaf Corcoran 2015 | */ 2 | /* 3 | Source: https://github.com/leafo/sticky-kit 4 | License: MIT 5 | */ 6 | (function(){var b,f;b=this.jQuery||window.jQuery;f=b(window);b.fn.stick_in_parent=function(d){var A,w,J,n,B,K,p,q,k,E,t;null==d&&(d={});t=d.sticky_class;B=d.inner_scrolling;E=d.recalc_every;k=d.parent;q=d.offset_top;p=d.spacer;w=d.bottoming;null==q&&(q=0);null==k&&(k=void 0);null==B&&(B=!0);null==t&&(t="is_stuck");A=b(document);null==w&&(w=!0);J=function(a,d,n,C,F,u,r,G){var v,H,m,D,I,c,g,x,y,z,h,l;if(!a.data("sticky_kit")){a.data("sticky_kit",!0);I=A.height();g=a.parent();null!=k&&(g=g.closest(k)); 7 | if(!g.length)throw"failed to find stick parent";v=m=!1;(h=null!=p?p&&a.closest(p):b("
"))&&h.css("position",a.css("position"));x=function(){var c,f,e;if(!G&&(I=A.height(),c=parseInt(g.css("border-top-width"),10),f=parseInt(g.css("padding-top"),10),d=parseInt(g.css("padding-bottom"),10),n=g.offset().top+c+f,C=g.height(),m&&(v=m=!1,null==p&&(a.insertAfter(h),h.detach()),a.css({position:"",top:"",width:"",bottom:""}).removeClass(t),e=!0),F=a.offset().top-(parseInt(a.css("margin-top"),10)||0)-q, 8 | u=a.outerHeight(!0),r=a.css("float"),h&&h.css({width:a.outerWidth(!0),height:u,display:a.css("display"),"vertical-align":a.css("vertical-align"),"float":r}),e))return l()};x();if(u!==C)return D=void 0,c=q,z=E,l=function(){var b,l,e,k;if(!G&&(e=!1,null!=z&&(--z,0>=z&&(z=E,x(),e=!0)),e||A.height()===I||x(),e=f.scrollTop(),null!=D&&(l=e-D),D=e,m?(w&&(k=e+u+c>C+n,v&&!k&&(v=!1,a.css({position:"fixed",bottom:"",top:c}).trigger("sticky_kit:unbottom"))),eb&&!v&&(c-=l,c=Math.max(b-u,c),c=Math.min(q,c),m&&a.css({top:c+"px"})))):e>F&&(m=!0,b={position:"fixed",top:c},b.width="border-box"===a.css("box-sizing")?a.outerWidth()+"px":a.width()+"px",a.css(b).addClass(t),null==p&&(a.after(h),"left"!==r&&"right"!==r||h.append(a)),a.trigger("sticky_kit:stick")),m&&w&&(null==k&&(k=e+u+c>C+n),!v&&k)))return v=!0,"static"===g.css("position")&&g.css({position:"relative"}), 10 | a.css({position:"absolute",bottom:d,top:"auto"}).trigger("sticky_kit:bottom")},y=function(){x();return l()},H=function(){G=!0;f.off("touchmove",l);f.off("scroll",l);f.off("resize",y);b(document.body).off("sticky_kit:recalc",y);a.off("sticky_kit:detach",H);a.removeData("sticky_kit");a.css({position:"",bottom:"",top:"",width:""});g.position("position","");if(m)return null==p&&("left"!==r&&"right"!==r||a.insertAfter(h),h.remove()),a.removeClass(t)},f.on("touchmove",l),f.on("scroll",l),f.on("resize", 11 | y),b(document.body).on("sticky_kit:recalc",y),a.on("sticky_kit:detach",H),setTimeout(l,0)}};n=0;for(K=this.length;n 2 | 3 | 5 | 8 | 12 | 13 | -------------------------------------------------------------------------------- /docs/logo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/leeper/prediction/c239565c6b029e339969d1d13a480b66ffd438e9/docs/logo.png -------------------------------------------------------------------------------- /docs/pkgdown.css: -------------------------------------------------------------------------------- 1 | /* Sticky footer */ 2 | 3 | /** 4 | * Basic idea: https://philipwalton.github.io/solved-by-flexbox/demos/sticky-footer/ 5 | * Details: https://github.com/philipwalton/solved-by-flexbox/blob/master/assets/css/components/site.css 6 | * 7 | * .Site -> body > .container 8 | * .Site-content -> body > .container .row 9 | * .footer -> footer 10 | * 11 | * Key idea seems to be to ensure that .container and __all its parents__ 12 | * have height set to 100% 13 | * 14 | */ 15 | 16 | html, body { 17 | height: 100%; 18 | } 19 | 20 | body > .container { 21 | display: flex; 22 | height: 100%; 23 | flex-direction: column; 24 | 25 | padding-top: 60px; 26 | } 27 | 28 | body > .container .row { 29 | flex: 1 0 auto; 30 | } 31 | 32 | footer { 33 | margin-top: 45px; 34 | padding: 35px 0 36px; 35 | border-top: 1px solid #e5e5e5; 36 | color: #666; 37 | display: flex; 38 | flex-shrink: 0; 39 | } 40 | footer p { 41 | margin-bottom: 0; 42 | } 43 | footer div { 44 | flex: 1; 45 | } 46 | footer .pkgdown { 47 | text-align: right; 48 | } 49 | footer p { 50 | margin-bottom: 0; 51 | } 52 | 53 | img.icon { 54 | float: right; 55 | } 56 | 57 | img { 58 | max-width: 100%; 59 | } 60 | 61 | /* Fix bug in bootstrap (only seen in firefox) */ 62 | summary { 63 | display: list-item; 64 | } 65 | 66 | /* Typographic tweaking ---------------------------------*/ 67 | 68 | .contents .page-header { 69 | margin-top: calc(-60px + 1em); 70 | } 71 | 72 | /* Section anchors ---------------------------------*/ 73 | 74 | a.anchor { 75 | margin-left: -30px; 76 | display:inline-block; 77 | width: 30px; 78 | height: 30px; 79 | visibility: hidden; 80 | 81 | background-image: url(./link.svg); 82 | background-repeat: no-repeat; 83 | background-size: 20px 20px; 84 | background-position: center center; 85 | } 86 | 87 | .hasAnchor:hover a.anchor { 88 | visibility: visible; 89 | } 90 | 91 | @media (max-width: 767px) { 92 | .hasAnchor:hover a.anchor { 93 | visibility: hidden; 94 | } 95 | } 96 | 97 | 98 | /* Fixes for fixed navbar --------------------------*/ 99 | 100 | .contents h1, .contents h2, .contents h3, .contents h4 { 101 | padding-top: 60px; 102 | margin-top: -40px; 103 | } 104 | 105 | /* Static header placement on mobile devices */ 106 | @media (max-width: 767px) { 107 | .navbar-fixed-top { 108 | position: absolute; 109 | } 110 | .navbar { 111 | padding: 0; 112 | } 113 | } 114 | 115 | 116 | /* Sidebar --------------------------*/ 117 | 118 | #sidebar { 119 | margin-top: 30px; 120 | } 121 | #sidebar h2 { 122 | font-size: 1.5em; 123 | margin-top: 1em; 124 | } 125 | 126 | #sidebar h2:first-child { 127 | margin-top: 0; 128 | } 129 | 130 | #sidebar .list-unstyled li { 131 | margin-bottom: 0.5em; 132 | } 133 | 134 | .orcid { 135 | height: 16px; 136 | vertical-align: middle; 137 | } 138 | 139 | /* Reference index & topics ----------------------------------------------- */ 140 | 141 | .ref-index th {font-weight: normal;} 142 | 143 | .ref-index td {vertical-align: top;} 144 | .ref-index .icon {width: 40px;} 145 | .ref-index .alias {width: 40%;} 146 | .ref-index-icons .alias {width: calc(40% - 40px);} 147 | .ref-index .title {width: 60%;} 148 | 149 | .ref-arguments th {text-align: right; padding-right: 10px;} 150 | .ref-arguments th, .ref-arguments td {vertical-align: top;} 151 | .ref-arguments .name {width: 20%;} 152 | .ref-arguments .desc {width: 80%;} 153 | 154 | /* Nice scrolling for wide elements --------------------------------------- */ 155 | 156 | table { 157 | display: block; 158 | overflow: auto; 159 | } 160 | 161 | /* Syntax highlighting ---------------------------------------------------- */ 162 | 163 | pre { 164 | word-wrap: normal; 165 | word-break: normal; 166 | border: 1px solid #eee; 167 | } 168 | 169 | pre, code { 170 | background-color: #f8f8f8; 171 | color: #333; 172 | } 173 | 174 | pre code { 175 | overflow: auto; 176 | word-wrap: normal; 177 | white-space: pre; 178 | } 179 | 180 | pre .img { 181 | margin: 5px 0; 182 | } 183 | 184 | pre .img img { 185 | background-color: #fff; 186 | display: block; 187 | height: auto; 188 | } 189 | 190 | code a, pre a { 191 | color: #375f84; 192 | } 193 | 194 | a.sourceLine:hover { 195 | text-decoration: none; 196 | } 197 | 198 | .fl {color: #1514b5;} 199 | .fu {color: #000000;} /* function */ 200 | .ch,.st {color: #036a07;} /* string */ 201 | .kw {color: #264D66;} /* keyword */ 202 | .co {color: #888888;} /* comment */ 203 | 204 | .message { color: black; font-weight: bolder;} 205 | .error { color: orange; font-weight: bolder;} 206 | .warning { color: #6A0366; font-weight: bolder;} 207 | 208 | /* Clipboard --------------------------*/ 209 | 210 | .hasCopyButton { 211 | position: relative; 212 | } 213 | 214 | .btn-copy-ex { 215 | position: absolute; 216 | right: 0; 217 | top: 0; 218 | visibility: hidden; 219 | } 220 | 221 | .hasCopyButton:hover button.btn-copy-ex { 222 | visibility: visible; 223 | } 224 | 225 | /* mark.js ----------------------------*/ 226 | 227 | mark { 228 | background-color: rgba(255, 255, 51, 0.5); 229 | border-bottom: 2px solid rgba(255, 153, 51, 0.3); 230 | padding: 1px; 231 | } 232 | 233 | /* vertical spacing after htmlwidgets */ 234 | .html-widget { 235 | margin-bottom: 10px; 236 | } 237 | -------------------------------------------------------------------------------- /docs/pkgdown.js: -------------------------------------------------------------------------------- 1 | /* http://gregfranko.com/blog/jquery-best-practices/ */ 2 | (function($) { 3 | $(function() { 4 | 5 | $("#sidebar") 6 | .stick_in_parent({offset_top: 40}) 7 | .on('sticky_kit:bottom', function(e) { 8 | $(this).parent().css('position', 'static'); 9 | }) 10 | .on('sticky_kit:unbottom', function(e) { 11 | $(this).parent().css('position', 'relative'); 12 | }); 13 | 14 | $('body').scrollspy({ 15 | target: '#sidebar', 16 | offset: 60 17 | }); 18 | 19 | $('[data-toggle="tooltip"]').tooltip(); 20 | 21 | var cur_path = paths(location.pathname); 22 | var links = $("#navbar ul li a"); 23 | var max_length = -1; 24 | var pos = -1; 25 | for (var i = 0; i < links.length; i++) { 26 | if (links[i].getAttribute("href") === "#") 27 | continue; 28 | // Ignore external links 29 | if (links[i].host !== location.host) 30 | continue; 31 | 32 | var nav_path = paths(links[i].pathname); 33 | 34 | var length = prefix_length(nav_path, cur_path); 35 | if (length > max_length) { 36 | max_length = length; 37 | pos = i; 38 | } 39 | } 40 | 41 | // Add class to parent
  • , and enclosing
  • if in dropdown 42 | if (pos >= 0) { 43 | var menu_anchor = $(links[pos]); 44 | menu_anchor.parent().addClass("active"); 45 | menu_anchor.closest("li.dropdown").addClass("active"); 46 | } 47 | }); 48 | 49 | function paths(pathname) { 50 | var pieces = pathname.split("/"); 51 | pieces.shift(); // always starts with / 52 | 53 | var end = pieces[pieces.length - 1]; 54 | if (end === "index.html" || end === "") 55 | pieces.pop(); 56 | return(pieces); 57 | } 58 | 59 | // Returns -1 if not found 60 | function prefix_length(needle, haystack) { 61 | if (needle.length > haystack.length) 62 | return(-1); 63 | 64 | // Special case for length-0 haystack, since for loop won't run 65 | if (haystack.length === 0) { 66 | return(needle.length === 0 ? 0 : -1); 67 | } 68 | 69 | for (var i = 0; i < haystack.length; i++) { 70 | if (needle[i] != haystack[i]) 71 | return(i); 72 | } 73 | 74 | return(haystack.length); 75 | } 76 | 77 | /* Clipboard --------------------------*/ 78 | 79 | function changeTooltipMessage(element, msg) { 80 | var tooltipOriginalTitle=element.getAttribute('data-original-title'); 81 | element.setAttribute('data-original-title', msg); 82 | $(element).tooltip('show'); 83 | element.setAttribute('data-original-title', tooltipOriginalTitle); 84 | } 85 | 86 | if(ClipboardJS.isSupported()) { 87 | $(document).ready(function() { 88 | var copyButton = ""; 89 | 90 | $(".examples, div.sourceCode").addClass("hasCopyButton"); 91 | 92 | // Insert copy buttons: 93 | $(copyButton).prependTo(".hasCopyButton"); 94 | 95 | // Initialize tooltips: 96 | $('.btn-copy-ex').tooltip({container: 'body'}); 97 | 98 | // Initialize clipboard: 99 | var clipboardBtnCopies = new ClipboardJS('[data-clipboard-copy]', { 100 | text: function(trigger) { 101 | return trigger.parentNode.textContent; 102 | } 103 | }); 104 | 105 | clipboardBtnCopies.on('success', function(e) { 106 | changeTooltipMessage(e.trigger, 'Copied!'); 107 | e.clearSelection(); 108 | }); 109 | 110 | clipboardBtnCopies.on('error', function() { 111 | changeTooltipMessage(e.trigger,'Press Ctrl+C or Command+C to copy'); 112 | }); 113 | }); 114 | } 115 | })(window.jQuery || window.$) 116 | -------------------------------------------------------------------------------- /docs/pkgdown.yml: -------------------------------------------------------------------------------- 1 | pandoc: 1.19.2.1 2 | pkgdown: 1.3.0 3 | pkgdown_sha: ~ 4 | articles: [] 5 | 6 | -------------------------------------------------------------------------------- /docs/reference/figures/logo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/leeper/prediction/c239565c6b029e339969d1d13a480b66ffd438e9/docs/reference/figures/logo.png -------------------------------------------------------------------------------- /inst/CITATION: -------------------------------------------------------------------------------- 1 | citHeader("To cite package 'prediction' in publications use:") 2 | 3 | year <- sub(".*(2[[:digit:]]{3})-.*", "\\1", meta$Date, perl = TRUE) 4 | vers <- paste("R package version", meta$Version) 5 | 6 | citEntry(entry="Manual", 7 | title = "prediction: Tidy, Type-Safe 'prediction()' Methods", 8 | author = personList(as.person("Thomas J. Leeper")), 9 | year = year, 10 | note = vers, 11 | textVersion = 12 | paste("Thomas J. Leeper (", 13 | year, 14 | "). prediction: Tidy, Type-Safe 'prediction()' Methods. ", 15 | vers, ".", sep="")) -------------------------------------------------------------------------------- /man/build_datalist.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/build_datalist.R 3 | \name{build_datalist} 4 | \alias{build_datalist} 5 | \title{Build list of data.frames} 6 | \usage{ 7 | build_datalist(data, at = NULL, as.data.frame = FALSE, ...) 8 | } 9 | \arguments{ 10 | \item{data}{A data.frame containing the original data.} 11 | 12 | \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.} 13 | 14 | \item{as.data.frame}{A logical indicating whether to return a single stacked data frame rather than a list of data frames} 15 | 16 | \item{\dots}{Ignored.} 17 | } 18 | \value{ 19 | A list of data.frames, unless \code{as.data.frame = TRUE} in which case a single, stacked data frame is returned. 20 | } 21 | \description{ 22 | Construct a list of data.frames based upon an input data.frame and a list of one or more \code{at} values 23 | } 24 | \examples{ 25 | # basic examples 26 | require("datasets") 27 | build_datalist(head(mtcars), at = list(cyl = c(4, 6))) 28 | 29 | str(build_datalist(head(mtcars), at = list(cyl = c(4,6), wt = c(2.75,3,3.25))), 1) 30 | 31 | str(build_datalist(head(mtcars), at = data.frame(cyl = c(4,4), wt = c(2.75,3)))) 32 | 33 | } 34 | \seealso{ 35 | \code{\link{find_data}}, \code{\link{mean_or_mode}}, \code{\link{seq_range}} 36 | } 37 | \author{ 38 | Thomas J. Leeper 39 | } 40 | \keyword{data} 41 | \keyword{manip} 42 | -------------------------------------------------------------------------------- /man/figures/logo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/leeper/prediction/c239565c6b029e339969d1d13a480b66ffd438e9/man/figures/logo.png -------------------------------------------------------------------------------- /man/find_data.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/find_data.R 3 | \name{find_data} 4 | \alias{find_data} 5 | \alias{find_data.default} 6 | \alias{find_data.data.frame} 7 | \alias{find_data.crch} 8 | \alias{find_data.glimML} 9 | \alias{find_data.glm} 10 | \alias{find_data.hxlr} 11 | \alias{find_data.lm} 12 | \alias{find_data.mca} 13 | \alias{find_data.merMod} 14 | \alias{find_data.svyglm} 15 | \alias{find_data.train} 16 | \alias{find_data.vgam} 17 | \alias{find_data.vglm} 18 | \title{Extract data from a model object} 19 | \usage{ 20 | find_data(model, ...) 21 | 22 | \method{find_data}{default}(model, env = parent.frame(), ...) 23 | 24 | \method{find_data}{data.frame}(model, ...) 25 | 26 | \method{find_data}{crch}(model, env = parent.frame(), ...) 27 | 28 | \method{find_data}{glimML}(model, ...) 29 | 30 | \method{find_data}{glm}(model, env = parent.frame(), ...) 31 | 32 | \method{find_data}{hxlr}(model, env = parent.frame(), ...) 33 | 34 | \method{find_data}{lm}(model, env = parent.frame(), ...) 35 | 36 | \method{find_data}{mca}(model, env = parent.frame(), ...) 37 | 38 | \method{find_data}{merMod}(model, env = parent.frame(), ...) 39 | 40 | \method{find_data}{svyglm}(model, env = parent.frame(), ...) 41 | 42 | \method{find_data}{train}(model, ...) 43 | 44 | \method{find_data}{vgam}(model, env = parent.frame(), ...) 45 | 46 | \method{find_data}{vglm}(model, env = parent.frame(), ...) 47 | } 48 | \arguments{ 49 | \item{model}{The model object.} 50 | 51 | \item{\dots}{Additional arguments passed to methods.} 52 | 53 | \item{env}{An environment in which to look for the \code{data} argument to the modelling call.} 54 | } 55 | \value{ 56 | 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. 57 | } 58 | \description{ 59 | Attempt to reconstruct the data used to create a model object 60 | } 61 | \details{ 62 | 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. 63 | } 64 | \examples{ 65 | require("datasets") 66 | x <- lm(mpg ~ cyl * hp + wt, data = head(mtcars)) 67 | find_data(x) 68 | 69 | } 70 | \seealso{ 71 | \code{\link{prediction}}, \code{\link{build_datalist}}, \code{\link{mean_or_mode}}, \code{\link{seq_range}} 72 | } 73 | -------------------------------------------------------------------------------- /man/margex.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/margex.R 3 | \docType{data} 4 | \name{margex} 5 | \alias{margex} 6 | \title{Artificial data for margins, copied from Stata} 7 | \format{A data frame with 3000 observations on the following 11 variables. 8 | \describe{ 9 | \item{\samp{y}}{A numeric vector} 10 | \item{\samp{outcome}}{A binary numeric vector with values (0,1)} 11 | \item{\samp{sex}}{A factor with two levels} 12 | \item{\samp{group}}{A factor with three levels} 13 | \item{\samp{age}}{A numeric vector} 14 | \item{\samp{distance}}{A numeric vector} 15 | \item{\samp{ycn}}{A numeric vector} 16 | \item{\samp{yc}}{A numeric vector} 17 | \item{\samp{treatment}}{A factor with two levels} 18 | \item{\samp{agegroup}}{A factor with three levels} 19 | \item{\samp{arm}}{A factor with three levels} 20 | }} 21 | \source{ 22 | \url{http://www.stata-press.com/data/r14/margex.dta} 23 | } 24 | \usage{ 25 | margex 26 | } 27 | \description{ 28 | The dataset is identical to the one provided by Stata and available from \code{webuse::webuse("margex")} with categorical variables explicitly encoded as factors. 29 | } 30 | \examples{ 31 | \donttest{ 32 | 33 | # Examples from Stata's help files 34 | # Also available from: webuse::webuse("margex") 35 | data("margex") 36 | 37 | # A simple case after regress 38 | # . regress y i.sex i.group 39 | # . margins sex 40 | m1 <- lm(y ~ factor(sex) + factor(group), data = margex) 41 | prediction(m1, at = list(sex = c("male", "female"))) 42 | 43 | # A simple case after logistic 44 | # . logistic outcome i.sex i.group 45 | # . margins sex 46 | m2 <- glm(outcome ~ sex + group, binomial(), data = margex) 47 | prediction(m2, at = list(sex = c("male", "female"))) 48 | 49 | # Average response versus response at average 50 | # . margins sex 51 | prediction(m2, at = list(sex = c("male", "female"))) 52 | # . margins sex, atmeans 53 | ## TODO 54 | 55 | # Multiple margins from one margins command 56 | # . margins sex group 57 | prediction(m2, at = list(sex = c("male", "female"))) 58 | prediction(m2, at = list(group = c("1", "2", "3"))) 59 | 60 | # Margins with interaction terms 61 | # . logistic outcome i.sex i.group sex#group 62 | # . margins sex group 63 | m3 <- glm(outcome ~ sex * group, binomial(), data = margex) 64 | prediction(m3, at = list(sex = c("male", "female"))) 65 | prediction(m3, at = list(group = c("1", "2", "3"))) 66 | 67 | # Margins with continuous variables 68 | # . logistic outcome i.sex i.group sex#group age 69 | # . margins sex group 70 | m4 <- glm(outcome ~ sex * group + age, binomial(), data = margex) 71 | prediction(m4, at = list(sex = c("male", "female"))) 72 | prediction(m4, at = list(group = c("1", "2", "3"))) 73 | 74 | # Margins of continuous variables 75 | # . margins, at(age=40) 76 | prediction(m4, at = list(age = 40)) 77 | # . margins, at(age=(30 35 40 45 50)) 78 | prediction(m4, at = list(age = c(30, 35, 40, 45, 50))) 79 | 80 | # Margins of interactions 81 | # . margins sex#group 82 | prediction(m4, at = list(sex = c("male", "female"), group = c("1", "2", "3"))) 83 | 84 | } 85 | } 86 | \seealso{ 87 | \code{\link{prediction}} 88 | } 89 | \keyword{datasets} 90 | -------------------------------------------------------------------------------- /man/mean_or_mode.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/mean_or_mode.R 3 | \name{mean_or_mode} 4 | \alias{mean_or_mode} 5 | \alias{mean_or_mode.default} 6 | \alias{mean_or_mode.numeric} 7 | \alias{mean_or_mode.data.frame} 8 | \alias{median_or_mode} 9 | \alias{median_or_mode.default} 10 | \alias{median_or_mode.numeric} 11 | \alias{median_or_mode.data.frame} 12 | \title{Class-dependent variable aggregation} 13 | \usage{ 14 | mean_or_mode(x) 15 | 16 | \method{mean_or_mode}{default}(x) 17 | 18 | \method{mean_or_mode}{numeric}(x) 19 | 20 | \method{mean_or_mode}{data.frame}(x) 21 | 22 | median_or_mode(x) 23 | 24 | \method{median_or_mode}{default}(x) 25 | 26 | \method{median_or_mode}{numeric}(x) 27 | 28 | \method{median_or_mode}{data.frame}(x) 29 | } 30 | \arguments{ 31 | \item{x}{A vector.} 32 | } 33 | \value{ 34 | A numeric or factor vector of length 1. 35 | } 36 | \description{ 37 | 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. 38 | } 39 | \examples{ 40 | require("datasets") 41 | # mean for numerics 42 | mean_or_mode(iris) 43 | mean_or_mode(iris[["Sepal.Length"]]) 44 | mean_or_mode(iris[["Species"]]) 45 | 46 | # median for numerics 47 | median_or_mode(iris) 48 | 49 | } 50 | \seealso{ 51 | \code{\link{prediction}}, \code{\link{build_datalist}}, \code{\link{seq_range}} 52 | } 53 | -------------------------------------------------------------------------------- /man/seq_range.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/seq_range.R 3 | \name{seq_range} 4 | \alias{seq_range} 5 | \title{Create a sequence over the range of a vector} 6 | \usage{ 7 | seq_range(x, n = 2) 8 | } 9 | \arguments{ 10 | \item{x}{A numeric vector} 11 | 12 | \item{n}{An integer specifying the length of sequence (i.e., number of points across the range of \code{x})} 13 | } 14 | \value{ 15 | A vector of length \code{n}. 16 | } 17 | \description{ 18 | Define a sequence of evenly spaced values from the minimum to the maximum of a vector 19 | } 20 | \examples{ 21 | identical(range(1:5), seq_range(1:5, n = 2)) 22 | seq_range(1:5, n = 3) 23 | 24 | } 25 | \seealso{ 26 | \code{\link{mean_or_mode}}, \code{\link{build_datalist}} 27 | } 28 | -------------------------------------------------------------------------------- /po/R-prediction.pot: -------------------------------------------------------------------------------- 1 | msgid "" 2 | msgstr "" 3 | "Project-Id-Version: prediction 0.3.15\n" 4 | "POT-Creation-Date: 2019-12-24 14:49\n" 5 | "PO-Revision-Date: YEAR-MO-DA HO:MI+ZONE\n" 6 | "Last-Translator: FULL NAME \n" 7 | "Language-Team: LANGUAGE \n" 8 | "MIME-Version: 1.0\n" 9 | "Content-Type: text/plain; charset=CHARSET\n" 10 | "Content-Transfer-Encoding: 8bit\n" 11 | 12 | 13 | msgid "Illegal factor levels for variable '" 14 | msgstr "" 15 | 16 | msgid "':" 17 | msgstr "" 18 | 19 | msgid "," 20 | msgstr "" 21 | 22 | msgid "A 'at' value for '" 23 | msgstr "" 24 | 25 | msgid "' is" 26 | msgstr "" 27 | 28 | msgid "Some 'at' values for '" 29 | msgstr "" 30 | 31 | msgid "' are" 32 | msgstr "" 33 | 34 | msgid "'at' contains unnamed list elements" 35 | msgstr "" 36 | 37 | msgid "(" 38 | msgstr "" 39 | 40 | msgid ")" 41 | msgstr "" 42 | 43 | msgid "" 44 | msgstr "" 45 | 46 | msgid "'find_data()' requires a formula call" 47 | msgstr "" 48 | 49 | msgid "'find_data()' cannot locate variable(s) used in 'subset'" 50 | msgstr "" 51 | 52 | msgid "'find_data.vgam()' requires the 'methods' package" 53 | msgstr "" 54 | 55 | msgid "prediction() for objects of class 'bigglm' only work when 'data' is specified" 56 | msgstr "" 57 | 58 | msgid "prediction() for objects of class 'biglm' only work when 'data' is specified" 59 | msgstr "" 60 | 61 | msgid "'type' is ignored for models of class '%s'" 62 | msgstr "" 63 | 64 | msgid "category %s not found" 65 | msgstr "" 66 | 67 | msgid "'data' is required for models of class '%s'" 68 | msgstr "" 69 | 70 | msgid "'data' is ignored for models of class '%s'" 71 | msgstr "" 72 | 73 | msgid "'prediction.mnp' only works when 'n.draws = 1'" 74 | msgstr "" 75 | 76 | msgid "Data frame with %d %s%swith modal prediction (of %d %s):" 77 | msgstr "" 78 | 79 | msgid "prediction" 80 | msgstr "" 81 | 82 | msgid "predictions" 83 | msgstr "" 84 | 85 | msgid "call" 86 | msgstr "" 87 | 88 | msgid "from\n %s" 89 | msgstr "" 90 | 91 | msgid "level" 92 | msgstr "" 93 | 94 | msgid "levels" 95 | msgstr "" 96 | 97 | msgid "Data frame with %d %s%swith average prediction: %s" 98 | msgstr "" 99 | 100 | msgid "%0." 101 | msgstr "" 102 | 103 | msgid "f" 104 | msgstr "" 105 | 106 | msgid "Data frame with %d %s%swith modal %s (of %d %s):" 107 | msgstr "" 108 | 109 | msgid "Data frame with %d %s%swith average %s:" 110 | msgstr "" 111 | 112 | msgid "Unrecognized variable name in 'at': " 113 | msgid_plural "Unrecognized variable names in 'at': " 114 | msgstr[0] "" 115 | msgstr[1] "" 116 | 117 | msgid "prediction" 118 | msgid_plural "predictions" 119 | msgstr[0] "" 120 | msgstr[1] "" 121 | 122 | msgid "level" 123 | msgid_plural "levels" 124 | msgstr[0] "" 125 | msgstr[1] "" 126 | -------------------------------------------------------------------------------- /tests/testthat-prediction.R: -------------------------------------------------------------------------------- 1 | library("testthat") 2 | library("prediction") 3 | test_check("prediction") 4 | -------------------------------------------------------------------------------- /tests/testthat/tests-build_datalist.R: -------------------------------------------------------------------------------- 1 | context("Test `build_data_list()` behavior") 2 | 3 | test_that("Test build_datalist()", { 4 | expect_true(inherits(build_datalist(mtcars, at = NULL), "list"), label = "build_datalist(at = NULL) works") 5 | expect_true(inherits(build_datalist(mtcars, at = list(cyl = 4)), "list"), label = "build_datalist(at = ) works") 6 | 7 | expect_true(length(build_datalist(mtcars, at = list(cyl = c(4, 6), wt = 2:3))) == 4, label = "build_datalist() length") 8 | 9 | expect_error(build_datalist(mtcars, at = list(foo = 1)), label = "build_datalist(at = foo) errors") 10 | expect_error(build_datalist(mtcars, at = list(1)), label = "build_datalist() unnamed list errors") 11 | expect_warning(build_datalist(mtcars, at = list(cyl = 2)), label = "build_datalist() range warning") 12 | }) 13 | 14 | test_that("Test build_datalist() with data.table", { 15 | dt <- data.table::data.table(y=1:5, x=1:5) 16 | expect_true(inherits(build_datalist(dt, at = list(x = 2)), "list"), label = "build_datalist(at = NULL) works with data.table") 17 | }) 18 | 19 | test_that("Factors in build_datalist()", { 20 | mtcars$cyl <- factor(mtcars$cyl) 21 | e <- build_datalist(mtcars, at = list(cyl = 4)) 22 | expect_true(inherits(e, "list"), label = "build_datalist(at = factor()) works") 23 | expect_true(identical(levels(mtcars$cyl), levels(e[[1L]][["cyl"]])), label = "build_datalist(at = factor()) preserves factor levels") 24 | 25 | expect_error(build_datalist(mtcars, at = list(cyl = 7)), label = "build_datalist(at = ) errors on illegal factor level") 26 | 27 | mtcars$cyl <- as.character(mtcars$cyl) 28 | expect_true(inherits(build_datalist(mtcars, at = list(cyl = 4)), "list"), label = "build_datalist(at = ) works") 29 | }) 30 | -------------------------------------------------------------------------------- /tests/testthat/tests-find_data.R: -------------------------------------------------------------------------------- 1 | library("datasets") 2 | 3 | context("Test `find_data()` behavior") 4 | 5 | test_that("Test find_data.default()", { 6 | expect_true(inherits(find_data(lm(mpg ~ cyl, data = mtcars)), "data.frame"), label = "find_data.default() works") 7 | 8 | m1 <- lm(mpg ~ cyl, data = mtcars, subset = am == 1) 9 | expect_true(nrow(find_data(m1)) == nrow(mtcars[mtcars$am == 1, ]), label = "find_data.default(data, subset) works") 10 | 11 | mtcars2 <- mtcars 12 | mtcars2[1:3,] <- NA_real_ 13 | 14 | m2 <- lm(mpg ~ cyl, data = mtcars2) 15 | expect_true(nrow(find_data(m2)) == nrow(mtcars2[-c(1:3), ]), label = "find_data.default(data, na.action) works") 16 | 17 | m3 <- lm(mpg ~ cyl, data = mtcars2, subset = am == 1) 18 | expect_true(nrow(find_data(m3)) == nrow(na.omit(mtcars2[mtcars2$am == 1, ])), label = "find_data.default(data, subset, na.action) works") 19 | 20 | expect_error(find_data(StructTS(log10(UKgas), type = "BSM")), label = "find_data.default([no formula]) errors") 21 | }) 22 | 23 | test_that("Test find_data.lm()", { 24 | expect_true(inherits(find_data(lm(mpg ~ cyl, data = mtcars)), "data.frame"), label = "find_data.lm() works") 25 | }) 26 | 27 | test_that("Test find_data.glm()", { 28 | expect_true(inherits(find_data(glm(mpg ~ cyl, data = mtcars)), "data.frame"), label = "find_data.glm() works") 29 | }) 30 | 31 | test_that("Test find_data.data.frame()", { 32 | expect_true(inherits(find_data(mtcars), "data.frame"), label = "find_data.data.frame() works") 33 | }) 34 | 35 | test_that("Test find_data.lm() and prediction.lm() with missing data", { 36 | mtcars2 <- mtcars 37 | mtcars2$mpg[1:4] <- NA_real_ 38 | 39 | # na.omit 40 | m1 <- lm(mpg ~ cyl, data = mtcars2, na.action = na.omit) 41 | expect_true(identical(dim(find_data(m1)), dim(na.omit(mtcars2))), 42 | label = "find_data.lm() drops missing data when 'na.action = na.omit'") 43 | expect_true(nrow(prediction(m1)) == nrow(na.omit(mtcars2)), 44 | label = "prediction.lm() returns correct rows when 'na.action = na.omit'") 45 | 46 | # na.exclude 47 | m2 <- lm(mpg ~ cyl, data = mtcars2, na.action = na.exclude) 48 | expect_true(identical(dim(find_data(m2)), dim(na.omit(mtcars2))), 49 | label = "find_data.lm() drops missing data when 'na.action = na.exclude'") 50 | expect_true(nrow(prediction(m2)) == nrow(na.omit(mtcars2)), 51 | label = "prediction.lm() returns correct rows when 'na.action = na.exclude'") 52 | 53 | # prediction with missing data passed explicitly 54 | m3 <- lm(mpg ~ cyl, data = mtcars) # missing outcome 55 | p3 <- prediction(m3, mtcars2, na.action = na.pass) 56 | expect_true(nrow(p3) == nrow(mtcars), 57 | label = "prediction.lm() returns correct rows when prediction(na.action = na.pass) for missing outcome") 58 | expect_true(all(!is.na(p3$fitted)[1:4]), 59 | label = "prediction.lm() returns numeric predictions when prediction(na.action = na.pass) for missing outcome") 60 | expect_true(nrow(prediction(m3, mtcars2, na.action = na.omit)) == nrow(mtcars2), 61 | label = "prediction.lm() returns correct rows when prediction(na.action = na.omit) for missing outcome") 62 | expect_true(nrow(prediction(m3, mtcars2, na.action = na.exclude)) == nrow(mtcars2), 63 | label = "prediction.lm() returns correct rows when prediction(na.action = na.exclude) for missing outcome") 64 | 65 | m4 <- lm(cyl ~ mpg, data = mtcars) # missing covariate 66 | p4 <- prediction(m4, mtcars2, na.action = na.pass) 67 | expect_true(nrow(p4) == nrow(mtcars), 68 | label = "prediction.lm() returns correct rows when prediction(na.action = na.pass) for missing covariate") 69 | expect_true(all(is.na(p4$fitted)[1:4]), 70 | label = "prediction.lm() returns NA predictions when prediction(na.action = na.pass) for missing covariate") 71 | expect_error(prediction(m4, mtcars2, na.action = na.omit), 72 | label = "prediction.lm() fails when prediction(na.action = na.omit) for missing covariate") 73 | expect_error(prediction(m4, mtcars2, na.action = na.exclude), 74 | label = "prediction.lm() fails when prediction(na.action = na.exclude) for missing covariate") 75 | 76 | rm(mtcars2) 77 | }) 78 | 79 | test_that("Test find_data.lm() with subsetted data", { 80 | mtcars2 <- mtcars 81 | mtcars2$mpg[1:4] <- NA_real_ 82 | m1 <- lm(mpg ~ cyl, data = mtcars2, subset = !is.na(mpg)) 83 | expect_true(identical(dim(find_data(m1)), dim(na.omit(mtcars2))), 84 | label = "find_data.lm() has correct dimensions when subsetting") 85 | expect_true(nrow(prediction(m1)) == nrow(na.omit(mtcars2)), 86 | label = "prediction.lm() returns correct rows when subsetting") 87 | x <- c(rep(TRUE, 30), FALSE, FALSE) 88 | m2 <- lm(mpg ~ cyl, data = mtcars2, subset = x) 89 | expect_true(identical(nrow(find_data(m2)), nrow(na.omit(mtcars2))-2L), 90 | label = "find_data.lm() subsets correctly when subsetting variable is global") 91 | expect_true(identical(rownames(find_data(m2)), head(rownames(na.omit(mtcars2)), 26)), 92 | label = "find_data.lm() returns correct rows when subsetting and missing data are present") 93 | rm(mtcars2) 94 | }) 95 | 96 | test_that("Test find_data.lm() with subsetted data", { 97 | skip_if_not_installed("survey") 98 | library("survey") 99 | data(api) 100 | dstrat <- svydesign(id=~1, strata=~stype, weights=~pw, data=apistrat, fpc=~fpc) 101 | m <- svyglm(growth ~ target, dstrat) 102 | f <- find_data(m, design = dstrat) 103 | 104 | expect_true(identical(nrow(f), length(predict(m))), label = "Survey design model has correct rows") 105 | expect_true(identical(nrow(prediction(m)), length(predict(m))), label = "Survey design model has correct rows") 106 | }) 107 | --------------------------------------------------------------------------------