prediction/0000755000176200001440000000000013501766223012417 5ustar liggesusersprediction/inst/0000755000176200001440000000000013005363015013363 5ustar liggesusersprediction/inst/CITATION0000644000176200001440000000113513076130015014520 0ustar liggesuserscitHeader("To cite package 'prediction' in publications use:") year <- sub(".*(2[[:digit:]]{3})-.*", "\\1", meta$Date, perl = TRUE) vers <- paste("R package version", meta$Version) citEntry(entry="Manual", title = "prediction: Tidy, Type-Safe 'prediction()' Methods", author = personList(as.person("Thomas J. Leeper")), year = year, note = vers, textVersion = paste("Thomas J. Leeper (", year, "). prediction: Tidy, Type-Safe 'prediction()' Methods. ", vers, ".", sep=""))prediction/tests/0000755000176200001440000000000013005364763013563 5ustar liggesusersprediction/tests/testthat/0000755000176200001440000000000013501766223015421 5ustar liggesusersprediction/tests/testthat/tests-build_datalist.R0000644000176200001440000000240713075625471021700 0ustar liggesuserscontext("Test `build_data_list()` behavior") test_that("Test build_datalist()", { expect_true(inherits(build_datalist(mtcars, at = NULL), "list"), label = "build_datalist(at = NULL) works") expect_true(inherits(build_datalist(mtcars, at = list(cyl = 4)), "list"), label = "build_datalist(at = ) works") expect_true(length(build_datalist(mtcars, at = list(cyl = c(4, 6), wt = 2:3))) == 4, label = "build_datalist() length") expect_error(build_datalist(mtcars, at = list(foo = 1)), label = "build_datalist(at = foo) errors") expect_error(build_datalist(mtcars, at = list(1)), label = "build_datalist() unnamed list errors") expect_warning(build_datalist(mtcars, at = list(cyl = 2)), label = "build_datalist() range warning") }) test_that("Factors in build_datalist()", { mtcars$cyl <- factor(mtcars$cyl) expect_true(inherits(build_datalist(mtcars, at = list(cyl = 4)), "list"), label = "build_datalist(at = factor()) works") expect_error(build_datalist(mtcars, at = list(cyl = 7)), label = "build_datalist(at = ) errors on illegal factor level") mtcars$cyl <- as.character(mtcars$cyl) expect_true(inherits(build_datalist(mtcars, at = list(cyl = 4)), "list"), label = "build_datalist(at = ) works") }) prediction/tests/testthat/tests-find_data.R0000644000176200001440000001177713501406665020633 0ustar liggesuserslibrary("datasets") context("Test `find_data()` behavior") test_that("Test find_data.default()", { expect_true(inherits(find_data(lm(mpg ~ cyl, data = mtcars)), "data.frame"), label = "find_data.default() works") m1 <- lm(mpg ~ cyl, data = mtcars, subset = am == 1) expect_true(nrow(find_data(m1)) == nrow(mtcars[mtcars$am == 1, ]), label = "find_data.default(data, subset) works") mtcars2 <- mtcars mtcars2[1:3,] <- NA_real_ m2 <- lm(mpg ~ cyl, data = mtcars2) expect_true(nrow(find_data(m2)) == nrow(mtcars2[-c(1:3), ]), label = "find_data.default(data, na.action) works") m3 <- lm(mpg ~ cyl, data = mtcars2, subset = am == 1) expect_true(nrow(find_data(m3)) == nrow(na.omit(mtcars2[mtcars2$am == 1, ])), label = "find_data.default(data, subset, na.action) works") expect_error(find_data(StructTS(log10(UKgas), type = "BSM")), label = "find_data.default([no formula]) errors") }) test_that("Test find_data.lm()", { expect_true(inherits(find_data(lm(mpg ~ cyl, data = mtcars)), "data.frame"), label = "find_data.lm() works") }) test_that("Test find_data.glm()", { expect_true(inherits(find_data(glm(mpg ~ cyl, data = mtcars)), "data.frame"), label = "find_data.glm() works") }) test_that("Test find_data.data.frame()", { expect_true(inherits(find_data(mtcars), "data.frame"), label = "find_data.data.frame() works") }) test_that("Test find_data.lm() and prediction.lm() with missing data", { mtcars2 <- mtcars mtcars2$mpg[1:4] <- NA_real_ # na.omit m1 <- lm(mpg ~ cyl, data = mtcars2, na.action = na.omit) expect_true(identical(dim(find_data(m1)), dim(na.omit(mtcars2))), label = "find_data.lm() drops missing data when 'na.action = na.omit'") expect_true(nrow(prediction(m1)) == nrow(na.omit(mtcars2)), label = "prediction.lm() returns correct rows when 'na.action = na.omit'") # na.exclude m2 <- lm(mpg ~ cyl, data = mtcars2, na.action = na.exclude) expect_true(identical(dim(find_data(m2)), dim(na.omit(mtcars2))), label = "find_data.lm() drops missing data when 'na.action = na.exclude'") expect_true(nrow(prediction(m2)) == nrow(na.omit(mtcars2)), label = "prediction.lm() returns correct rows when 'na.action = na.exclude'") # prediction with missing data passed explicitly m3 <- lm(mpg ~ cyl, data = mtcars) # missing outcome p3 <- prediction(m3, mtcars2, na.action = na.pass) expect_true(nrow(p3) == nrow(mtcars), label = "prediction.lm() returns correct rows when prediction(na.action = na.pass) for missing outcome") expect_true(all(!is.na(p3$fitted)[1:4]), label = "prediction.lm() returns numeric predictions when prediction(na.action = na.pass) for missing outcome") expect_true(nrow(prediction(m3, mtcars2, na.action = na.omit)) == nrow(mtcars2), label = "prediction.lm() returns correct rows when prediction(na.action = na.omit) for missing outcome") expect_true(nrow(prediction(m3, mtcars2, na.action = na.exclude)) == nrow(mtcars2), label = "prediction.lm() returns correct rows when prediction(na.action = na.exclude) for missing outcome") m4 <- lm(cyl ~ mpg, data = mtcars) # missing covariate p4 <- prediction(m4, mtcars2, na.action = na.pass) expect_true(nrow(p4) == nrow(mtcars), label = "prediction.lm() returns correct rows when prediction(na.action = na.pass) for missing covariate") expect_true(all(is.na(p4$fitted)[1:4]), label = "prediction.lm() returns NA predictions when prediction(na.action = na.pass) for missing covariate") expect_error(prediction(m4, mtcars2, na.action = na.omit), label = "prediction.lm() fails when prediction(na.action = na.omit) for missing covariate") expect_error(prediction(m4, mtcars2, na.action = na.exclude), label = "prediction.lm() fails when prediction(na.action = na.exclude) for missing covariate") rm(mtcars2) }) test_that("Test find_data.lm() with subsetted data", { mtcars2 <- mtcars mtcars2$mpg[1:4] <- NA_real_ m1 <- lm(mpg ~ cyl, data = mtcars2, subset = !is.na(mpg)) expect_true(identical(dim(find_data(m1)), dim(na.omit(mtcars2))), label = "find_data.lm() has correct dimensions when subsetting") expect_true(nrow(prediction(m1)) == nrow(na.omit(mtcars2)), label = "prediction.lm() returns correct rows when subsetting") x <- c(rep(TRUE, 30), FALSE, FALSE) m2 <- lm(mpg ~ cyl, data = mtcars2, subset = x) expect_true(identical(nrow(find_data(m2)), nrow(na.omit(mtcars2))-2L), label = "find_data.lm() subsets correctly when subsetting variable is global") expect_true(identical(rownames(find_data(m2)), head(rownames(na.omit(mtcars2)), 26)), label = "find_data.lm() returns correct rows when subsetting and missing data are present") rm(mtcars2) }) prediction/tests/testthat/tests-core.R0000644000176200001440000001646113501755364017650 0ustar liggesusers# set comparison tolerance tol <- 0.0001 library("datasets") context("Test `prediction()` behavior") test_that("Test prediction()", { mod1 <- lm(mpg ~ cyl, data = mtcars) mod2 <- glm(mpg ~ cyl, data = mtcars) expect_true(inherits(prediction(mod1, data = mtcars), "data.frame"), label = "prediction() works w data arg (LM)") expect_true(inherits(prediction(mod2, data = mtcars), "data.frame"), label = "prediction() works w data arg (GLM)") expect_true(inherits(prediction(mod1), "data.frame"), label = "prediction() works w/o data arg (LM)") expect_true(inherits(prediction(mod2), "data.frame"), label = "prediction() works w/o data arg (GLM)") expect_error(inherits(prediction(mod1, data = NULL), "data.frame"), label = "prediction() errors w/ NULL data arg (LM)") expect_error(inherits(prediction(mod2, data = NULL), "data.frame"), label = "prediction() errors w/ NULL data arg (GLM)") expect_true(all.equal(prediction(mod1, data = mtcars)$fitted, predict(mod1), check.attributes = FALSE), label = "prediction() matches predict() (LM)") expect_true(all.equal(prediction(mod2, data = mtcars)$fitted, predict(mod2, type = "response"), check.attributes = FALSE), label = "prediction() matches predict() (GLM)") }) test_that("Test prediction(data = )", { m <- lm(mpg ~ cyl + wt, data = mtcars) p1 <- prediction(m, data = data.frame(cyl = 4, wt = 3.9)) expect_true(inherits(p1, "data.frame"), label = "prediction(lm(~), data = data.frame()) works") m <- glm(mpg ~ cyl + wt, data = mtcars) p1 <- prediction(m, data = data.frame(cyl = 4, wt = 3.9)) expect_true(inherits(p1, "data.frame"), label = "prediction(glm(~), data = data.frame()) works") }) test_that("Test prediction(at = )", { m <- lm(mpg ~ cyl, data = mtcars) p1 <- prediction(m, at = list(cyl = 4)) expect_true(inherits(p1, "data.frame"), label = "prediction(at = list(cyl = 4)) works") expect_true(nrow(p1) == nrow(mtcars), label = "prediction(at = list(cyl = 4)) works") expect_true(all.equal(p1$fitted, predict(m, within(mtcars, cyl <- 4)), check.attributes = FALSE), label = "prediction(at = list(cyl = 4)) matches predict()") p2 <- prediction(m, at = list(cyl = c(4, 6))) expect_true(inherits(p2, "data.frame"), label = "prediction(at = list(cyl = c(4, 6))) works") expect_true(nrow(p2) == 2*nrow(mtcars), label = "prediction(at = list(cyl = c(4, 6))) works") expect_true(all.equal(p2$fitted, predict(m, rbind(within(mtcars, cyl <- 4), within(mtcars, cyl <- 6))), check.attributes = FALSE), label = "prediction(at = list(cyl = c(4, 6))) matches predict()") p3 <- prediction(m, at = list(cyl = c(4, 6), wt = 2:3)) expect_true(inherits(p3, "data.frame"), label = "prediction(at = list(cyl = c(4, 6), wt = 2:3)) works") expect_true(nrow(p3) == 4*nrow(mtcars), label = "prediction(at = list(cyl = c(4, 6), wt = 2:3)) works") mtcars$cyl <- factor(mtcars$cyl) expect_error(prediction(m, at = list(cyl = 3)), label = "prediction(at = list(cyl = 3)) errors") }) context("Test behavior of 'prediction' class methods") test_that("Test print()", { expect_true(inherits(print(prediction(lm(mpg ~ cyl, data = mtcars), data = mtcars)), "data.frame"), label = "print() works with numeric outcome") expect_true(inherits(print(prediction(lm(mpg ~ cyl, data = mtcars), data = mtcars, at = list(cyl = c(4,6,8)))), "data.frame"), label = "print() works with numeric outcome and at()") }) test_that("Test summary() w/o at()", { m1 <- lm(mpg ~ cyl, data = mtcars) # prediction w/o at() p1 <- prediction(m1) s1 <- summary(p1) expect_true(inherits(summary(p1), "data.frame"), label = "summary() works with numeric outcome") expect_true(all(c("Prediction", "SE", "z", "p", "lower", "upper") %in% names(s1)), label = "summary() has correct columns w/o at()") expect_true(nrow(s1) == 1L, label = "summary() has correct rows w/o at()") ## numerical correctness expect_true(all.equal(s1[["Prediction"]][1L], mean(predict(m1)), tolerance = tol), label = "summary() returns numerically correct mean prediction") test_se <- sqrt(colMeans(cbind(1, mtcars$cyl)) %*% vcov(m1) %*% colMeans(cbind(1, mtcars$cyl)))[1,1,drop=TRUE] expect_true(all.equal(s1[["SE"]][1L], test_se, tolerance = tol), label = "summary() returns numerically correct SE of mean prediction") }) test_that("Test summary() w at()", { # prediction w/ at() m1 <- lm(mpg ~ cyl, data = mtcars) p2 <- prediction(m1, data = mtcars, at = list(cyl = c(4,6,8))) s2 <- summary(p2) expect_true(inherits(s2, "data.frame"), label = "summary() works with numeric outcome and at()") expect_true(all(c("at(cyl)", "Prediction", "SE", "z", "p", "lower", "upper") %in% names(s2)), label = "summary() has correct columns with at()") expect_true(nrow(s2) == 3L, label = "summary() has correct rows w/o at()") ## numerical correctness expect_true(all.equal(s2[["Prediction"]][1L], mean(predict(m1, newdata = within(mtcars, cyl <- 4))), tolerance = tol), label = "summary() returns numerically correct mean prediction with at()") test_se <- sqrt(colMeans(cbind(1, 4)) %*% vcov(m1) %*% colMeans(cbind(1, 4)))[1,1,drop=TRUE] expect_true(all.equal(s2[["SE"]][1L], test_se, tolerance = tol), label = "summary() returns numerically correct SE of mean prediction with at()") }) test_that("Test prediction_summary()", { m1 <- lm(mpg ~ cyl, data = mtcars) p1 <- prediction(m1) s1 <- summary(p1) expect_true(identical(s1, prediction_summary(m1)), label = "prediction_summary() is correct") }) test_that("Test head() and tail()", { p1 <- prediction(lm(mpg ~ cyl, data = mtcars), data = mtcars) expect_true(inherits(head(p1), "data.frame"), label = "head() works") expect_true(nrow(head(p1, 5L)) == 5L, label = "head() has correct rows") expect_true(inherits(tail(p1), "data.frame"), label = "tail() works") expect_true(nrow(tail(p1, 5L)) == 5L, label = "tail() has correct rows") }) context("Test utilities") test_that("Test seq_range()", { expect_true(identical(range(mtcars$wt), seq_range(mtcars$wt, 2)), label = "seq_range() is correct") expect_true(length(seq_range(mtcars$wt, 5)) == 5, label = "seq_range() length is correct") }) test_that("Test mean_or_mode()/median_or_mode()", { expect_true(mean_or_mode(mtcars$wt) == mean(mtcars$wt), label = "mean_or_mode.numeric() is correct") expect_true(median_or_mode(mtcars$wt) == median(mtcars$wt), label = "median_or_mode.numeric() is correct") mtcars$cyl <- factor(mtcars$cyl) expect_true(mean_or_mode(mtcars$cyl) == 8, label = "mean_or_mode.default() is correct") expect_true(median_or_mode(mtcars$cyl) == 8, label = "mean_or_mode.default() is correct") expect_true(identical(mean_or_mode(mtcars), lapply(mtcars, mean_or_mode)), label = "mean_or_mode.data.frame() is correct") expect_true(identical(median_or_mode(mtcars), lapply(mtcars, median_or_mode)), label = "median_or_mode.data.frame() is correct") }) prediction/tests/testthat/tests-methods.R0000644000176200001440000007353213501755364020365 0ustar liggesusers# test all prediction() methods, conditional on availability of package # this file is organized alphabetically by package name library("datasets") context("Test `prediction()` methods, conditional on package availability") if (require("AER", quietly = TRUE)) { test_that("Test prediction() for 'ivreg'", { data("CigarettesSW", package = "AER") CigarettesSW$rprice <- with(CigarettesSW, price/cpi) CigarettesSW$rincome <- with(CigarettesSW, income/population/cpi) CigarettesSW$tdiff <- with(CigarettesSW, (taxs - tax)/cpi) m <- AER::ivreg(log(packs) ~ log(rprice) + log(rincome) | log(rincome) + tdiff + I(tax/cpi), data = CigarettesSW, subset = year == "1995") p <- prediction(m) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) test_that("Test prediction() for 'tobit'", { data("Affairs", package = "AER") m <- tobit(affairs ~ age + yearsmarried + religiousness + occupation + rating, data = Affairs) p <- prediction(m) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) } if (require("aod", quietly = TRUE)) { test_that("Test prediction() for 'glimML'", { data("orob2", package = "aod") m <- aod::betabin(cbind(y, n - y) ~ seed, ~ 1, data = orob2) p <- prediction(m) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) test_that("Test prediction() for 'glimQL'", { data("orob2", package = "aod") m <- aod::quasibin(cbind(y, n - y) ~ seed * root, data = orob2, phi = 0) p <- prediction(m) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) } if (require("betareg", quietly = TRUE)) { test_that("Test prediction() for 'betareg'", { data("GasolineYield", package = "betareg") m <- betareg::betareg(yield ~ batch + temp, data = GasolineYield) p <- prediction(m) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) } if (require("biglm", quietly = TRUE)) { test_that("Test prediction() for 'biglm'", { data("trees", package = "datasets") m <- biglm::biglm(log(Volume) ~ log(Girth) + log(Height), data=trees) p <- prediction(m, calculate_se = FALSE) # temporary, while bug fixed upstream expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) #test_that("Test prediction() for 'bigglm'", { # data("trees", package = "datasets") # m <- biglm::bigglm(log(Volume) ~ log(Girth) + log(Height), data=trees, chunksize=10) # p <- prediction(m, calculate_se = FALSE) # temporary, while bug fixed upstream # expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") # expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") #}) } if (require("brglm", quietly = TRUE)) { test_that("Test prediction() for 'brglm'", { data("lizards", package = "brglm") m <- brglm::brglm(cbind(grahami, opalinus) ~ height + diameter + light + time, family = binomial(logit), data=lizards, method = "brglm.fit") p <- prediction(m) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) } if (require("caret", quietly = TRUE)) { test_that("Test prediction() for 'knnreg'", { data("BloodBrain", package = "caret") inTrain <- createDataPartition(logBBB, p = .8)[[1]] trainX <- bbbDescr[inTrain,] trainY <- logBBB[inTrain] testX <- bbbDescr[-inTrain,] m <- knnreg(trainX, trainY, k = 3) p <- prediction(m, data = testX) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) test_that("Test prediction() for 'train'", { data("iris", package = "datasets") m <- train(Sepal.Length ~ ., data = iris, method = "lm") p <- prediction(m, data = iris) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) } if (require("crch", quietly = TRUE)) { test_that("Test prediction() for 'crch'", { e <- new.env() data("RainIbk", package = "crch", envir = e) RainIbk <- e$RainIbk RainIbk$sqrtensmean <- apply(sqrt(RainIbk[,grep('^rainfc',names(RainIbk))]), 1, mean) m <- crch::crch(sqrt(rain) ~ sqrtensmean, data = RainIbk, dist = "gaussian", left = 0) p <- prediction(m, data = RainIbk) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) test_that("Test prediction() for 'hxlr'", { data("RainIbk", package = "crch") RainIbk$sqrtensmean <- apply(sqrt(RainIbk[,grep('^rainfc',names(RainIbk))]), 1, mean) q <- unique(quantile(RainIbk$rain, seq(0.1, 0.9, 0.1))) m <- crch::hxlr(sqrt(rain) ~ sqrtensmean, data = RainIbk, thresholds = sqrt(q)) expect_true(inherits(prediction(m, data = RainIbk), "prediction")) }) } if (require("e1071", quietly = TRUE)) { test_that("Test prediction() for 'naiveBayes'", { data("Titanic") m <- e1071::naiveBayes(Survived ~ ., data = Titanic) p <- prediction(m) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) test_that("Test prediction() for 'svm'", { m <- e1071::svm(Species ~ ., data = iris) p <- prediction(m) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) } if (require("earth", quietly = TRUE)) { test_that("Test prediction() for 'earth'", { data("trees", package = "datasets") m <- earth::earth(Volume ~ ., data = trees) p <- prediction(m) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) } if (require("ffbase", quietly = TRUE)) { test_that("Test prediction() for 'biglm' w/ 'ffbase' backend", { stopifnot(require("ff")) stopifnot(require("biglm")) data("trees", package = "datasets") x <- ff::as.ffdf(trees) m <- biglm::biglm(log(Volume)~log(Girth)+log(Height), data=x) p <- prediction(m, calculate_se = FALSE) # temporary, while bug fixed upstream expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) } if (require("gam", quietly = TRUE)) { test_that("Test prediction() for 'Gam'", { data("gam.data", package = "gam") m <- gam::gam(y ~ gam::s(x,6) + z,data=gam.data) p <- prediction(m) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) } if (require("gee", quietly = TRUE)) { test_that("Test prediction() for 'gee'", { data("warpbreaks") m <- gee::gee(breaks ~ tension, id=wool, data=warpbreaks, corstr="exchangeable") p <- prediction(m) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) } if (require("glmnet", quietly = TRUE)) { test_that("Test prediction() for 'glmnet'", { x <- matrix(rnorm(100*20),100,20) y <- rnorm(100) m <- glmnet::glmnet(x,y) p <- prediction(m, data = x) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) } if (require("glmx", quietly = TRUE) ) { test_that("Test prediction() for 'glmx()'", { d <- data.frame(x = runif(200, -1, 1)) d$y <- rnbinom(200, mu = exp(0 + 3 * d$x), size = 1) m <- glmx::glmx(y ~ x, data = d, family = MASS::negative.binomial, xlink = "log", xstart = 0) p <- prediction(m) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) test_that("Test prediction() for 'hetglm()'", { n <- 200 x <- rnorm(n) ystar <- 1 + x + rnorm(n, sd = exp(x)) y <- factor(ystar > 0) m <- glmx::hetglm(y ~ x | 1) p <- prediction(m) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) } if (require("kernlab", quietly = TRUE)) { require("methods", quietly = TRUE) test_that("Test prediction() for 'gausspr'", { data("promotergene", package = "kernlab") ind <- sample(1:dim(promotergene)[1],20) genetrain <- promotergene[-ind, ] genetest <- promotergene[ind, ] m <- kernlab::gausspr(Class~., data = genetrain, kernel = "rbfdot", kpar = list(sigma = 0.015)) p <- prediction(m, data = genetrain) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) test_that("Test prediction() for 'kqr'", { x <- sort(runif(300)) y <- sin(pi*x) + rnorm(300,0,sd=exp(sin(2*pi*x))) m <- kernlab::kqr(x, y, tau = 0.5, C=0.15) p <- prediction(m) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) test_that("Test prediction() for 'ksvm'", { data("promotergene", package = "kernlab") ind <- sample(1:dim(promotergene)[1],20) genetrain <- promotergene[-ind, ] genetest <- promotergene[ind, ] m <- kernlab::ksvm(Class~., data = genetrain, kernel = "rbfdot", kpar = list(sigma = 0.015), C = 70, cross = 4, prob.model = TRUE) p <- prediction(m, data = genetrain) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) } if (require("lme4", quietly = TRUE)) { test_that("Test prediction() for 'merMod'", { data("cbpp", package = "lme4") m <- lme4::glmer(cbind(incidence, size - incidence) ~ period + (1 |herd), cbpp, binomial) p <- prediction(m) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) } if (require("MASS", quietly = TRUE)) { test_that("Test prediction() for 'glm.nb'", { data("quine", package = "MASS") m <- MASS::glm.nb(Days ~ Sex/(Age + Eth*Lrn), data = quine) p <- prediction(m) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) test_that("Test prediction() for 'lda'", { data("iris3", package = "datasets") tr <- sample(1:50, 25) train <- rbind(iris3[tr,,1], iris3[tr,,2], iris3[tr,,3]) cl <- factor(c(rep("s",25), rep("c",25), rep("v",25))) m <- MASS::lda(train, cl) p <- prediction(m, data = train) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) test_that("Test prediction() for 'lqs'", { data("stackloss", package = "datasets") m <- MASS::lqs(stack.loss ~ ., data = stackloss, method = "S", nsamp = "exact") p <- prediction(m) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) test_that("Test prediction() for 'mca'", { data("farms", package = "MASS") m <- MASS::mca(farms, abbrev=TRUE) p <- prediction(m) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) test_that("Test prediction() for 'polr'", { data("housing", package = "MASS") m <- MASS::polr(Sat ~ Infl + Type + Cont, weights = Freq, data = housing) p <- prediction(m) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) test_that("Test prediction() for 'qda'", { data("iris3", package = "datasets") tr <- sample(1:50, 25) train <- rbind(iris3[tr,,1], iris3[tr,,2], iris3[tr,,3]) cl <- factor(c(rep("s",25), rep("c",25), rep("v",25))) m <- MASS::qda(train, cl) p <- prediction(m, data = train) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) test_that("Test prediction() for 'rlm'", { data("stackloss", package = "datasets") m <- MASS::rlm(stack.loss ~ ., stackloss) p <- prediction(m) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) } if (require("mclogit", quietly = TRUE)) { test_that("Test prediction() for 'mclogit'", { data("Transport", package = "mclogit") m <- mclogit::mclogit(cbind(resp,suburb)~distance+cost, data = Transport, trace = FALSE) p <- prediction(m) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) } if (require("mda", quietly = TRUE)) { test_that("Test prediction() for 'bruto'", { data("trees", package = "datasets") m <- bruto(trees[,-3], trees[3]) p <- prediction(m, data = NULL) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) test_that("Test prediction() for 'fda'", { data("iris", package = "datasets") m <- fda(Species ~ ., data = iris) p <- prediction(m) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted", "fitted.class") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) test_that("Test prediction() for 'mars'", { data("trees", package = "datasets") m <- mars(trees[,-3], trees[3]) p <- prediction(m, data = NULL) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) test_that("Test prediction() for 'mda'", { data("glass", package = "mda") m <- mda(Type ~ ., data = glass) p <- prediction(m) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) test_that("Test prediction() for 'polyreg'", { data("iris", package = "datasets") m <- polyreg(iris[,2:3], iris$Sepal.Length) p <- prediction(m, data = NULL) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) } #if (require("mnlogit", quietly = TRUE)) { # test_that("Test prediction() for 'mnlogit'", { # data("Fish", package = "mnlogit") # m <- mnlogit::mnlogit(mode ~ price | income | catch, Fish, ncores = 1) # p <- prediction(m) # expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") # expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") # }) #} if (require("MNP", quietly = TRUE)) { test_that("Test prediction() for 'mnp'", { data("japan", package = "MNP") m <- MNP::mnp(cbind(LDP, NFP, SKG, JCP) ~ gender + education + age, data = head(japan, 100), verbose = FALSE) p <- prediction(m) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) } if (require("nlme", quietly = TRUE)) { test_that("Test prediction() for 'gls'", { data("Ovary", package = "nlme") m <- nlme::gls(follicles ~ sin(2*pi*Time) + cos(2*pi*Time), Ovary, correlation = nlme::corAR1(form = ~ 1 | Mare), verbose = FALSE) p <- prediction(m) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) test_that("Test prediction() for 'lme'", { data("Orthodont", package = "nlme") m <- nlme::lme(distance ~ age, Orthodont, random = ~ age | Subject) p <- prediction(m) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) } if (require("nnet", quietly = TRUE)) { #test_that("Test prediction() for 'multinom'", { }) test_that("Test prediction() for 'nnet'", { data("iris3", package = "datasets") ird <- data.frame(rbind(iris3[,,1], iris3[,,2], iris3[,,3]), species = factor(c(rep("s",50), rep("c", 50), rep("v", 50)))) samp <- c(sample(1:50,25), sample(51:100,25), sample(101:150,25)) m <- nnet::nnet(species ~ ., data = ird, subset = samp, size = 2, rang = 0.1, decay = 5e-4, maxit = 200, trace = FALSE) p <- prediction(m) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) } if (require("ordinal", quietly = TRUE)) { test_that("Test prediction() for 'clm'", { data("wine", package = "ordinal") m <- ordinal::clm(rating ~ temp * contact, data = wine) p <- prediction(m) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) } if (require("plm", quietly = TRUE)) { test_that("Test prediction() for 'plm'", { data("Grunfeld", package = "plm") m <- plm::plm(inv ~ value + capital, data = Grunfeld, model = "pooling") p <- prediction(m) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) } if (require("pscl", quietly = TRUE)) { test_that("Test prediction() for 'hurdle'", { data("bioChemists", package = "pscl") m <- pscl::hurdle(art ~ ., data = bioChemists) p <- prediction(m) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) test_that("Test prediction() for 'zeroinfl'", { data("bioChemists", package = "pscl") m <- pscl::zeroinfl(art ~ ., data = bioChemists) p <- prediction(m) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) #test_that("Test prediction() for 'ideal'", { # expect_true(inherits(prediction(m), "prediction")) #}) } if (require("quantreg", quietly = TRUE)) { test_that("Test prediction() for 'rq'", { data("stackloss", package = "datasets") m <- quantreg::rq(stack.loss ~ stack.x, tau = .5, data = stackloss) p <- prediction(m) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) } if (require("rpart", quietly = TRUE)) { test_that("Test prediction() for 'rpart'", { data("kyphosis", package = "rpart") m <- rpart::rpart(Kyphosis ~ Age + Number + Start, data = kyphosis) p <- prediction(m) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) } if (require("sampleSelection", quietly = TRUE)) { test_that("Test prediction() for 'selection'", { data("Mroz87", package = "sampleSelection") Mroz87$kids <- (Mroz87$kids5 + Mroz87$kids618 > 0) m <- sampleSelection::heckit(lfp ~ age + I( age^2 ) + faminc + kids + educ, wage ~ exper + I( exper^2 ) + educ + city, Mroz87) p <- prediction(m) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) } if (require("speedglm", quietly = TRUE) ) { test_that("Test prediction() for 'speedglm()'", { n <- 1000 k <- 3 y <- rnorm(n) x <- round(matrix(rnorm(n * k), n, k), digits = 3) colnames(x) <- c("s1", "s2", "s3") da <- data.frame(y, x) m <- speedglm(y ~ s1 + s2 + s3, data = da) p <- prediction(m) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) test_that("Test prediction() for 'speedlm()'", { n <- 1000 k <- 3 y <- rnorm(n) x <- round(matrix(rnorm(n * k), n, k), digits = 3) colnames(x) <- c("s1", "s2", "s3") da <- data.frame(y, x) m <- speedlm(y ~ s1 + s2 + s3, data = da) p <- prediction(m) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) } if (require("stats", quietly = TRUE)) { test_that("Test prediction() for 'ar'", { data("sunspot.year", package = "datasets") m <- stats::ar(sunspot.year) p <- prediction(m, data = sunspot.year) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) test_that("Test prediction() for 'Arima'", { expect_true(inherits(prediction(stats::arima(lh, order = c(3,0,0)), n.ahead = 12), "prediction")) }) test_that("Test prediction() for 'arima0'", { m <- stats::arima0(lh, order = c(1,0,1)) expect_true(inherits(prediction(m, data = lh, n.ahead = 12), "prediction")) }) test_that("Test prediction() for 'loess'", { m <- stats::loess(dist ~ speed, cars) p <- prediction(m) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) test_that("Test prediction() for 'nls'", { m <- stats::nls(demand ~ SSasympOrig(Time, A, lrc), data = BOD) p <- prediction(m) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) test_that("Test prediction() for 'ppr'", { data("rock", package = "datasets") rock$area1 <- rock$area/10000 rock$peri1 <- rock$peri/10000 m <- stats::ppr(log(perm) ~ area1 + peri1 + shape, data = rock, nterms = 2, max.terms = 5) p <- prediction(m) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) test_that("Test prediction() for 'princomp'", { data("USArrests", package = "datasets") m <- stats::princomp(~ ., data = USArrests, cor = TRUE) p <- prediction(m) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) } if (require("survey", quietly = TRUE)) { test_that("Test prediction() for 'svyglm'", { data("api", package = "survey") dstrat <- survey::svydesign(id=~1,strata=~stype, weights=~pw, data=apistrat, fpc=~fpc) m <- survey::svyglm(api.stu~enroll, design=dstrat) p <- prediction(m) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) } if (require("survival", quietly = TRUE)) { test_that("Test prediction() for 'coxph'", { test1 <- list(time=c(4,3,1,1,2,2,3), status=c(1,1,1,0,1,1,0), x=c(0,2,1,1,1,0,0), sex=c(0,0,0,0,1,1,1)) m <- survival::coxph(survival::Surv(time, status) ~ x + survival::strata(sex), test1) p <- prediction(m) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) test_that("Test prediction() for 'survreg'", { data("ovarian", package = "survival") m <- survival::survreg(survival::Surv(futime, fustat) ~ ecog.ps + rx, ovarian, dist='weibull', scale=1) p <- prediction(m) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) } if (require("truncreg", quietly = TRUE)) { test_that("Test prediction() for 'truncreg'", { data("tobin", package = "survival") m <- truncreg::truncreg(durable ~ age + quant, data = tobin, subset = durable > 0) p <- prediction(m) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) } prediction/tests/testthat-prediction.R0000644000176200001440000000010613005364767017705 0ustar liggesuserslibrary("testthat") library("prediction") test_check("prediction") prediction/NAMESPACE0000644000176200001440000000513113501755361013637 0ustar liggesusers# Generated by roxygen2: do not edit by hand S3method(find_data,crch) S3method(find_data,data.frame) S3method(find_data,default) S3method(find_data,glimML) S3method(find_data,glm) S3method(find_data,hxlr) S3method(find_data,lm) S3method(find_data,mca) S3method(find_data,merMod) S3method(find_data,svyglm) S3method(find_data,train) S3method(find_data,vgam) S3method(find_data,vglm) S3method(head,prediction) S3method(mean_or_mode,data.frame) S3method(mean_or_mode,default) S3method(mean_or_mode,numeric) S3method(median_or_mode,data.frame) S3method(median_or_mode,default) S3method(median_or_mode,numeric) S3method(prediction,Arima) S3method(prediction,Gam) S3method(prediction,ar) S3method(prediction,arima0) S3method(prediction,betareg) S3method(prediction,biglm) S3method(prediction,bruto) S3method(prediction,clm) S3method(prediction,coxph) S3method(prediction,crch) S3method(prediction,default) S3method(prediction,earth) S3method(prediction,fda) S3method(prediction,gausspr) S3method(prediction,gee) S3method(prediction,glimML) S3method(prediction,glimQL) S3method(prediction,glm) S3method(prediction,glmnet) S3method(prediction,glmx) S3method(prediction,gls) S3method(prediction,hetglm) S3method(prediction,hurdle) S3method(prediction,hxlr) S3method(prediction,ivreg) S3method(prediction,knnreg) S3method(prediction,kqr) S3method(prediction,ksvm) S3method(prediction,lm) S3method(prediction,lme) S3method(prediction,loess) S3method(prediction,lqs) S3method(prediction,mars) S3method(prediction,mca) S3method(prediction,mclogit) S3method(prediction,merMod) S3method(prediction,mnp) S3method(prediction,multinom) S3method(prediction,nls) S3method(prediction,nnet) S3method(prediction,plm) S3method(prediction,polr) S3method(prediction,polyreg) S3method(prediction,ppr) S3method(prediction,princomp) S3method(prediction,rlm) S3method(prediction,rpart) S3method(prediction,rq) S3method(prediction,selection) S3method(prediction,speedglm) S3method(prediction,speedlm) S3method(prediction,survreg) S3method(prediction,svm) S3method(prediction,svyglm) S3method(prediction,train) S3method(prediction,truncreg) S3method(prediction,zeroinfl) S3method(print,prediction) S3method(print,summary.prediction) S3method(summary,prediction) S3method(tail,prediction) export(build_datalist) export(find_data) export(mean_or_mode) export(median_or_mode) export(prediction) export(prediction_summary) export(seq_range) import(stats) importFrom(data.table,rbindlist) importFrom(stats,model.frame) importFrom(stats,terms) importFrom(utils,head) importFrom(utils,tail) prediction/NEWS.md0000644000176200001440000002207713501755364013531 0ustar liggesusers# prediction 0.3.13 * Fixed a bug in `prediction_glm` with the `data` argument (Issue #32). # prediction 0.3.12 * Remove mnlogit dependency, as it has been removed from CRAN. # prediction 0.3.11 * Remove bigFastLm dependency, as it has been removed from CRAN. # prediction 0.3.10 * Added tests for `find_data()` and `prediction.lm()` to check for correct behavior in the presence of missing data (`na.action`) and `subset` arguments. (#28) # prediction 0.3.8 * Provisional support for variances of average predictions for GLMs. (#17) * Added an example dataset, `margex`, borrowed from Stata's identically named data. # prediction 0.3.7 * `summary(prediction(...))` now reports variances of average predictions, along with test statistics, p-values, and confidence intervals, where supported. (#17) * Added a function `prediction_summary()` which simply calls `summary(prediction(...))`. * All methods now return additional attributes. # prediction 0.3.6 * Small fixes for failing CRAN checks. (#25) * Remove `prediction.bigglm()` method (from **biglm**) due to failing tests. (#25) # prediction 0.3.5 * Fixed a bug that required specifying `stats::poly()` rather than just `poly()` in model formulae. (#22) # prediction 0.3.4 * Added `prediction.glmnet()` method for "glmnet" objects from **glmnet**. (#1) # prediction 0.3.3 * `prediction.merMod()` gains an `re.form` argument to pass forward to `predict.merMod()`. # prediction 0.3.2 * Fix typo in "speedglm" that was overwriting "glm" method. # prediction 0.3.0 * CRAN release. # prediction 0.2.11 * Added `prediction.glmML()` method for "glimML" objects from **aod**. (#1) * Added `prediction.glmQL()` method for "glimQL" objects from **aod**. (#1) * Added `prediction.truncreg()` method for "truncreg" objects from **truncreg**. (#1) * Noted implicit support for "tobit" objects from **AER**. (#1) # prediction 0.2.10 * Added `prediction.bruto()` method for "bruto" objects from **mda**. (#1) * Added `prediction.fda()` method for "fda" objects from **mda**. (#1) * Added `prediction.mars()` method for "mars" objects from **mda**. (#1) * Added `prediction.mda()` method for "mda" objects from **mda**. (#1) * Added `prediction.polyreg()` method for "polyreg" objects from **mda**. (#1) # prediction 0.2.9 * Added `prediction.speedglm()` and `prediction.speedlm()` methods for "speedglm" and "speedlm" objects from **speedglm**. (#1) * Added `prediction.bigLm()` method for "bigLm" objects from **bigFastlm**. (#1) * Added `prediction.biglm()` and `prediction.bigglm()` methods for "biglm" and "bigglm" objects from **biglm**, including those based by `"ffdf"` from **ff**. (#1) # prediction 0.2.8 * Changed internal behavior of `build_datalist()`. The function now returns an an `at_specification` attribute, which is a data frame representation of the `at` argument. # prediction 0.2.6 * Due to a change in gam_1.15, `prediction.gam()` is now `prediction.Gam()` for "Gam" objects from **gam**. (#1) # prediction 0.2.6 * Added `prediction.train()` method for "train" objects from **caret**. (#1) # prediction 0.2.5 * The `at` argument in `build_datalist()` now accepts a data frame of combinations for limiting the set of levels. # prediction 0.2.3 * Most `prediction()` methods gain a (experimental) `calculate_se` argument, which regulates whether to calculate standard errors for predictions. Setting to `FALSE` can improve performance if they are not needed. # prediction 0.2.3 * `build_datalist()` gains an `as.data.frame` argument, which - if `TRUE` - returns a stacked data frame rather than a list. This argument is now used internally in most `prediction()` functions in an effort to improve performance. (#18) # prediction 0.2.2 * Expanded test suite scope and fixed a few small bugs. * Added a `summary.prediction()` method to interact with the average predicted values that are printed when `at != NULL`. # prediction 0.2.1 * Added `prediction.knnreg()` method for "knnreg" objects from **caret**. (#1) * Added `prediction.gausspr()` method for "gausspr" objects from **kernlab**. (#1) * Added `prediction.ksvm()` method for "ksvm" objects from **kernlab**. (#1) * Added `prediction.kqr()` method for "kqr" objects from **kernlab**. (#1) * Added `prediction.earth()` method for "earth" objects from **earth**. (#1) * Added `prediction.rpart()` method for "rpart" objects from **rpart**. (#1) # prediction 0.2.0 * CRAN Release. * Added `mean_or_mode.data.frame()` and `median_or_mode.data.frame()` methods. # prediction 0.1.17 * Added `prediction.zeroinfl()` method for "zeroinfl" objects from **pscl**. (#1) * Added `prediction.hurdle()` method for "hurdle" objects from **pscl**. (#1) * Added `prediction.lme()` method for "lme" and "nlme" objects from **nlme**. (#1) * Documented `prediction.merMod()`. # prediction 0.1.16 * Added `prediction.plm()` method for "plm" objects from **plm**. (#1) # prediction 0.1.15 * Expanded test suite considerably and updated `CONTRIBUTING.md` to reflect expected test-driven development. * A few small code tweaks and bug fixes resulting from the updated test suite. # prediction 0.1.14 * Added `prediction.mnp()` method for "mnp" objects from **MNP**. (#1) * Added `prediction.mnlogit()` method for "mnlogit" objects from **mnlogit**. (#1) * Added `prediction.gee()` method for "gee" objects from **gee**. (#1) * Added `prediction.lqs()` method for "lqs" objects from **MASS**. (#1) * Added `prediction.mca()` method for "mca" objects from **MASS**. (#1) * Noted (built-in) support for "brglm" objects from **brglm** via the `prediction.glm()` method. (#1) # prediction 0.1.13 * Added a `category` argument to `prediction()` methods for models of multilevel outcomes (e.g., ordered probit, etc.) to be dictate which level is expressed as the `"fitted"` column. (#14) * Added an `at` argument to `prediction()` methods. (#13) * Made `mean_or_mode()` and `median_or_mode()` S3 generics. * Fixed a bug in `mean_or_mode()` and `median_or_mode()` where incorrect factor levels were being returned. # prediction 0.1.12 * Added `prediction.princomp()` method for "princomp" objects from **stats**. (#1) * Added `prediction.ppr()` method for "ppr" objects from **stats**. (#1) * Added `prediction.naiveBayes()` method for "naiveBayes" objects from **e1071**. (#1) * Added `prediction.rlm()` method for "rlm" objects from **MASS**. (#1) * Added `prediction.qda()` method for "qda" objects from **MASS**. (#1) * Added `prediction.lda()` method for "lda" objects from **MASS**. (#1) * `find_data()` now respects the `subset` argument in an original model call. (#15) * `find_data()` now respects the `na.action` argument in an original model call. (#15) * `find_data()` now gracefully fails when a model is specified without a formula. (#16) * `prediction()` methods no longer add a "fit" or "se.fit" class to any columns. Fitted values are identifiable by the column name only. # prediction 0.1.11 * `build_datalist()` now returns `at` value combinations as a list. # prediction 0.1.10 * Added `prediction.nnet()` method for "nnet" and "multinom" objects from **nnet**. (#1) # prediction 0.1.9 * `prediction()` methods now return the value of `data` as part of the response data frame. (#8, h/t Ben Whalley) * Slight change to `find_data()` methods for `"crch"` and `"hxlr"`. (#5) * Added `prediction.glmx()` and `prediction.hetglm()` methods for "glmx" and "hetglm" objects from **glmx**. (#1) * Added `prediction.betareg()` method for "betareg" objects from **betareg**. (#1) * Added `prediction.rq()` method for "rq" objects from **quantreg**. (#1) * Added `prediction.gam()` method for "gam" objects from **gam**. (#1) * Expanded basic test suite. # prediction 0.1.8 * Added `prediction()` and `find_data()` methods for `"crch"` `"hxlr"` objects from **crch**. (#4, h/t Carl Ganz) # prediction 0.1.7 * Added `prediction()` and `find_data()` methods for `"merMod"` objects from **lme4**. (#1) # prediction 0.1.6 * Moved the `seq_range()` function from **margins** to **prediction**. * Moved the `build_datalist()` function from **margins** to **prediction**. This will simplify the ability to calculate arbitrary predictions. # prediction 0.1.5 * Added `prediction.svm()` method for objects of class `"svm"` from **e1071**. (#1) * Fixed a bug in `prediction.polr()` when attempting to pass a `type` argument, which is always ignored. A warning is now issued when attempting to override this. # prediction 0.1.4 * Added `mean_or_mode()` and `median_or_mode()` functions, which provide a simple way to aggregate a variable of factor or numeric type. (#3) * Added `prediction()` methods for various time-series model classes: "ar", "arima0", and "Arima". # prediction 0.1.3 * `find_data()` is now a generic, methods for "lm", "glm", and "svyglm" classes. (#2, h/t Carl Ganz) # prediction 0.1.2 * Added support for "svyglm" class from the **survey** package. (#1) * Added tentative support for "clm" class from the **ordinal** package. (#1) # prediction 0.1.0 * Initial package released. prediction/data/0000755000176200001440000000000013501406664013330 5ustar liggesusersprediction/data/margex.rda0000644000176200001440000004430413501406664015310 0ustar liggesusersBZh91AY&SYnEkT<eX*@ҁ6 xel¶am8sp@P%(P>O{w0XPVP5 4S@&&!h 䘦ɐM FM=ODb4z 4h44 2 @E Szi4yF4#Ce1@dz@@hOU%44 %?R* d4 ɦCM10!CC10hdhiF#F@d`Fbb 0@d"QL4@z6I0hPiA3I2imb0C4Cɣ!'4 (5*=@hh@&-{?_{Mx<} B@)l$%fG.O=.љzzXQu6JE `X@[7%FȁXK)rDI%-,) ab-jU`pb$1p @(>HSyV7 "pV'2W pr DI_-9n+Upp .Xn ipi@emܸL2 1 lFkuh%!SUqa,n/&URl$'4daCM5B5Dcƣ• CmHjl+J 1d B *Z$"bl,&I+q!F2Ai6RBqg)2#Yo.e6Ca!,#dؔDdiyMG_7=y&ߛ;;&'0+ut^j|TM]j) nwayݷeɌ'iK)ۊYZPXcn Q n'U;|n/CiG7?ݧ{VO81ذcel&os/An״͗`nWw>jd ,ӫ4Q~ u5v R-вP>$a\/GUxEŹԍfuzݟr8nEz(6;(؄{EF[EXv{8bjH" ݿn[R5>9 y-摹A#lq@/Fpzwŵ׽M8\j@ wcC|{ɹU_0,]q72-M3xb]DME%Tܚ$ٺcN\%:5>plae\1cA:7M:^S8-a6*?>uǯ@L6Gʖӣp:}-jٻ|:͹xSģ4[4Wv-қ=5Lnp ߧvg<׳.΢o^ ߁80Ni˦7mTl*AoA4);xUnecEsAӢ=XqRWXں|hVΝFuĩֽ0d^ N)XMKcR16r&fo@NB琷CrEh㛁K*cyw+X̚¿"bƣ26[LR6ˆ5scPއ }i}sr۱Qp wۛiG=NUh8g6ɧyf7td?6ۚ6IF"S>;pci2Tmjy8ps=G6z]v6mє7[)\S lzWm3ko"vnf6I٩ i}N1_ccgR6ٝ|^| yU=g,ѪͨϺى+{lX*Z7U9^}:0I~g'0Y^א:wx4;5zbi.< WʛA3Xƺ"B5/H?Ԝ}^~ako=-{BoB۹=nЃoN =bw1>vu"s~WK՞~K쳓4JFgX-9E/\Ti'D?>=A'紹V:DfmHr&6A0새oa;=Xl0ƃVفp]Ù{Xu {n (?FjC#ׯZ MgU~$So-6UQ=R̓.x鬕2z- hAC + (=։0V*"Ug]6=j,+Xa50L)`KCCW4G?7aiV[#5^o +5BDԟ , (%VxBUSJ$*t4 iiAO'Zs V=m7n8,լ9^5`}r#ZVtQX7Wx_O||~wk}3nz6Exi_t}TV1Vu8;97h4W%~c~V;C!M-_MTظjtr &L2 G  &3ifj c(JRU[W|6jͳ6D#i1$ěim$H6$2LdLI&i"H$h$L$m$$m$I țPHO㐓IM#e4I,4"$K]ۺra,Km$J$S$dE)#D&I%u֭ 6HEI%Mm$$BhLv]fD$+,b٭6ۍcb͝]WڴMI&"M,'I1&DG4$:rKi,M$mIRI\RDHSEH-RR;vٖkXMmQmicN(U. 44'p䖝ܒHLrm+!5U4M"Iiuid$ii$hs&HemrII2XtprMŴ$&D)4$99$I»4dDI4ę&RM!&$dbF)w%Iu%%rm3.5hgYmfCٶlXY՚d[vg97-mvhڴ,llfiYgfݗarK5 [(3PI` !HDM,Diຶq$MY 2ҖD&DGJ\RRٛ6֜$9"D94Gsnw#nD$N1b&k-,ADDBDI$$ĒM e\țKVDhMh,hHțHȚLi0I&rr]*yL)C]rRk"IDDJB\$D$t9$[0ڵ]$BhDHIH"c64LHD#dIviG$q$i$$&K;4Ћj#iI2BM"&Dl$4F9$HD$-4BI$I6Hi4kQ2I2M&&l$m$mɓDIM"F"Di 3Di$2M 2&IDM!#IdLM܂DD"$i6IhРمoӥ;];;xTSm6Kmڲ&6Edќl.mY'fضkkZh6,YgwgfiYֆq%pbuU= xm^q3ݥn6iFc嶸ՔfIr`bHkXv'em23mi2ٸrCl eh%J'%m nh6ZivSmcf@ڰ;.ٳe]pweQvumj͓&nӎmZ6ɘFs.νi8fֳ݊LimtYՍkn.ͪ8Qtt۲N3ݸAge$l٭MMj.NYݡvvVQvGdvAےEgEq[[BetQ쓓;sLegec,f.muEe\Gfۣ.!;츲*,mt 2*n5ffeйt"V!H Y]=DGz$~k'@p0(k1]rF\JwUav+J'HW&F[y4$v<ԛk.ǒumњBSFERLĚRVMj,JV8 ̜匯9+!-CO~tk9o_~ײ8;Bpôx܀15E0}5q:+ \n\$0|Wk(6deHƅqHo3gmP֡WDJ[PCM9b5Oֺ}}hE%<Al&YC1U5V%\#W[m &L88L!nɓ!2OkA%;[*^*W ٗs1K7{o}u=M}tYΆ]K#/|GƏ= {gE:=Qst@(*mgeLoWoIM&F&6i&hS)9W^ SA+Ums ~whCU*e32m!QQQeBD,J3E=13DuŵR£N/;g>lu9\h&X`MSnXuc-.\HFp 2IP+(e>&[Ki7h>(HE-XB:akQ8C@İ+8&-o;!tR]?w_c>{Cew5?oٴYޫ9n#T, TH#|" O@6S6oI%~WTT9K?N 01$@ !Bzp OwɫB<@3˃L/uksʋV̒2.$JYx)ط"{W 5w$dɐz L ;K %_aK*lFQ ew6c!(H5isJ΢]>Xsk/:P>cYHT>WW9 1FJl4K{tz9ݫ06)N _s,$I`}VUr>?yU)}P;I؅8>}#_GkY>ZDlQ„Nk JcǤnzkȦAdsR n5YN #i5I!?zvI%7G G4P.CqۅWPX[ugtaSjRK/0S_4dXp 5Lm+fpAfbG[ %CN`Іk ЌE3) b'KۯF-n.kXF2' (ֶ q̡2ELe0Qb'^ûwuMRuhe\*TS "$E!ё+rl-dxޥ#L[fpO3[Rj6nj[(c$ɑjad1F:\([fuTX6֎̰cK\d%4اc շS,% wkVY\R0i&ܩChh04 iT0NLuȯII'2fe"S/dJ%>neZ޸cTx#ߔ8,ADIP6Q+Xs]Ihb ) >dߍ;]zQQ#xzvLlHeHx9O/ {Iz zR^NQ3تoOW|M-)C;]O=9ԧ~,:=y}>|QB8aWh2:Ci9\eAsבIavfwb(owv{2Z&%:7j|~Wgcx{v 'aF5t}7x{7Bus:#kj>oF'IZic8Mq4AsM xY׍#>1*5} .KЪq׸N Cʙ#c'oTwrn {g]>$)\V<՗aˆw>p,FU DB:HAAmA@C r>,mЯˮhdɺ Nvl!M;m+u \]m );mn̎gA |4*I1J18BS)1 ֕nr1$yZ1AqwO7''/?еhG8_#rsq+މpQ:+6 V Ӣ6JOdX%ҊV]5'SO'Ek1q.Ԥ!<ךعѾG*(.enZ4!Gy E{`={%NM)} C*>m~Gv:?pګ?6y[]o^<*7wODƏ#0Xt8>)L񭦪K^Q*g I_ZM}.2" PķYAHʖJm) ɲh2W<3Ȟi!{+ȤV#>NFfd~NܤmC4`!ozH b[92E Vrg5g]i`T!ZE;@j(bd׿i~H w{?p^ر r}O~@~SR{j֋ZT )c h e_[YHizFoQC=UHKz1+\$lB"04STZ"'2)खXODT D !*НbjO=NXTvQҤ%YLUōj|-K|Uai'6K;bkQITaYUSFt2jYcJ82HFn4e(>00f[N2!-&9q({NS!#TGiHSH94šL2PH*2r:"5)cXr/#3%-j 9PQ,C2Z)Nd3#"c杦p(=bĽe 'QєRGt,cA.3N#^L([#jZAռGJZ6bf1pe*Pu$qZ!8; :׎b0V+zvkN:, Hᬭ<蓕b(8PPɏZ/RTg!>]BI.u7` Y9{= EIe~_T%Pםy>ks<^XBNlyOK2d_LÚ=^K"23}3tBO-K,ƪGpWZ!c8?[& o +F Uy8B2]O]ͦzdR2ZL oNg<-u!'#[QnSHPcCPȀ@cJgif5O^Kf0nڟ9YFL gp:Q"(ӬmS LB$:L&~W_h3-e߲T[peতeFt5ФLwಅ1M1jඪ 1#C$^C8F.[RC}p>һm(5?Ջk\_&z}yn9`z?қ>r]>nozyu/@(q>Srđy~e6{јZtF \VJ"dlrnZ!Crȑ[*)sYMneX؜ph9r ̀0 O)jV,{hV˙4B6iZgXS*ь3Ah؍+fUH\Ie`%HͅSF;+fE{MmA LjbX&"\乨]l$2s4c<8J4 4HKek94*cI J*pd$L%n&`Q L0S .i/Z$@†ҬF-a-4I< n1H^tѩ8#[B`1쨱d6q0 ˍnfIaxúsOxUbէ0Ca!?>'m~-q|y:Ҿ\OgW|]YN6ڝ`(Noq9}1}׃8Aosq/p>E[^RO=m*&&V2.bOH*CJRVBQ "lgS\Y昩u`=q뢻$kHħ#֢U{(`fx똏kS@+LbbIM3)]rJmȶ0E;'f4Oz7OTsb}}Kｭ~;bW{pa$aE4` F*CojC'~ oC ɈD7v6ݼ>m}|yq.k~uͻVᒁ0Na=HX.i4(bd|Dk=z|+pjhZYkgLWiRk2d(h4,-FPyR(!izf)掾Cǁ/$:bh{ bO G>M* AVB$}\[ruiׯ՟jDNk8H_y(G+3{ݛե|BriZNF…Yy0(l/K: ?Pn>AhaH#Jsp`* (0^AX:ڤ,` Z! ΢"1UBE8X}2E$͵V=[mpcq_ XnBRuFQ$u.a;_vX>/}G`_l{܆:H8d  PWVVzxSfUUyO{߁)`Qnu [N&5bOQ2"%9.cϧAB;/jb4RPf3}T#Ht.KY??>}oa~'2dс__nm@΂Sqw0lކ;H{k ep ?_׿tsakw$S V@prediction/R/0000755000176200001440000000000013501755364012624 5ustar liggesusersprediction/R/prediction_coxph.R0000644000176200001440000000373013501406664016307 0ustar liggesusers#' @rdname prediction #' @export prediction.coxph <- function(model, data = find_data(model, parent.frame()), at = NULL, type = c("risk", "expected", "lp"), calculate_se = TRUE, ...) { type <- match.arg(type) # extract predicted values data <- data if (missing(data) || is.null(data)) { if (isTRUE(calculate_se)) { pred <- predict(model, type = type, se.fit = TRUE, ...) pred <- make_data_frame(fitted = pred[["fit"]], se.fitted = pred[["se.fit"]]) } else { pred <- predict(model, type = type, se.fit = FALSE, ...) pred <- make_data_frame(fitted = pred, se.fitted = rep(NA_real_, length(pred))) } } else { # setup data if (is.null(at)) { out <- data } else { out <- build_datalist(data, at = at, as.data.frame = TRUE) at_specification <- attr(out, "at_specification") } # calculate predictions if (isTRUE(calculate_se)) { pred <- predict(model, newdata = out, type = type, se.fit = TRUE, ...) pred <- make_data_frame(out, fitted = pred[["fit"]], se.fitted = pred[["se.fit"]]) } else { pred <- predict(model, newdata = out, type = type, se.fit = FALSE, ...) pred <- make_data_frame(out, fitted = pred, se.fitted = rep(NA_real_, length(pred))) } } # variance(s) of average predictions vc <- NA_real_ # output structure(pred, class = c("prediction", "data.frame"), at = if (is.null(at)) at else at_specification, type = type, call = if ("call" %in% names(model)) model[["call"]] else NULL, model_class = class(model), row.names = seq_len(nrow(pred)), vcov = vc, jacobian = NULL, weighted = FALSE) } prediction/R/prediction_rq.R0000644000176200001440000000266313501406664015614 0ustar liggesusers#' @rdname prediction #' @export prediction.rq <- function(model, data = find_data(model, parent.frame()), at = NULL, calculate_se = TRUE, ...) { # extract predicted value at input value data <- data if (missing(data) || is.null(data)) { pred <- data.frame(fitted = predict(model, ...), se.fitted = NA_real_) } else { # setup data if (is.null(at)) { out <- data } else { out <- build_datalist(data, at = at, as.data.frame = TRUE) at_specification <- attr(out, "at_specification") } # calculate predictions tmp <- predict(model, newdata = out, ...) # cbind back together pred <- make_data_frame(out, fitted = tmp, se.fitted = rep(NA_real_, nrow(out))) } # variance(s) of average predictions vc <- NA_real_ # output structure(pred, class = c("prediction", "data.frame"), at = if (is.null(at)) at else at_specification, type = NA_character_, call = if ("call" %in% names(model)) model[["call"]] else NULL, model_class = class(model), row.names = seq_len(nrow(pred)), vcov = vc, jacobian = NULL, weighted = FALSE) } prediction/R/prediction_gee.R0000644000176200001440000000126413501406664015726 0ustar liggesusers#' @rdname prediction #' @export prediction.gee <- function(model, calculate_se = FALSE, ...) { pred <- make_data_frame(fitted = predict(model, ...)) pred[["se.fitted"]] <- NA_real_ # variance(s) of average predictions vc <- NA_real_ # output structure(pred, class = c("prediction", "data.frame"), at = NULL, type = NA_character_, call = if ("call" %in% names(model)) model[["call"]] else NULL, model_class = class(model), row.names = seq_len(nrow(pred)), vcov = vc, jacobian = NULL, weighted = FALSE) } prediction/R/utils.R0000644000176200001440000000037213066747142014112 0ustar liggesusers#' @importFrom utils head #' @export head.prediction <- function(x, ...) { head(`class<-`(x, "data.frame"), ...) } #' @importFrom utils tail #' @export tail.prediction <- function(x, ...) { tail(`class<-`(x, "data.frame"), ...) } prediction/R/seq_range.R0000644000176200001440000000120513066747142014712 0ustar liggesusers#' @title Create a sequence over the range of a vector #' @description Define a sequence of evenly spaced values from the minimum to the maximum of a vector #' @param x A numeric vector #' @param n An integer specifying the length of sequence (i.e., number of points across the range of \code{x}) #' @return A vector of length \code{n}. #' @examples #' identical(range(1:5), seq_range(1:5, n = 2)) #' seq_range(1:5, n = 3) #' #' @seealso \code{\link{mean_or_mode}}, \code{\link{build_datalist}} #' @export seq_range <- function(x, n = 2) { seq(min(x, na.rm = TRUE), max(x, na.rm = TRUE), length.out = n) } prediction/R/prediction_multinom.R0000644000176200001440000000453413501406664017035 0ustar liggesusers#' @rdname prediction #' @export prediction.multinom <- function(model, data = find_data(model, parent.frame()), at = NULL, type = NULL, calculate_se = FALSE, category, ...) { if (!is.null(type)) { warning(sprintf("'type' is ignored for models of class '%s'", class(model))) } # extract predicted values data <- data if (missing(data) || is.null(data)) { pred <- make_data_frame(fitted.class = predict(model, type = "class", ...)) probs <- make_data_frame(predict(model, type = "probs", ...)) names(probs) <- paste0("Pr(", names(probs), ")") pred <- make_data_frame(pred, probs) } else { # setup data if (is.null(at)) { out <- data } else { out <- build_datalist(data, at = at, as.data.frame = TRUE) at_specification <- attr(out, "at_specification") } # calculate predictions tmp <- predict(model, newdata = out, type = "class", ...) tmp_probs <- make_data_frame(predict(model, newdata = out, type = "probs", ...)) names(tmp_probs) <- paste0("Pr(", names(tmp_probs), ")") # cbind back together pred <- make_data_frame(out, fitted.class = tmp, tmp_probs) rm(tmp, tmp_probs) } # handle category argument if (missing(category)) { w <- grep("^Pr\\(", names(pred))[1L] category <- names(pred)[w] pred[["fitted"]] <- pred[[w]] } else { w <- which(names(pred) == paste0("Pr(", category, ")")) if (!length(w)) { stop(sprintf("category %s not found", category)) } pred[["fitted"]] <- pred[[ w[1L] ]] } pred[["se.fitted"]] <- NA_real_ # variance(s) of average predictions vc <- NA_real_ # output structure(pred, class = c("prediction", "data.frame"), at = if (is.null(at)) at else at_specification, type = NA_character_, call = if ("call" %in% names(model)) model[["call"]] else NULL, model_class = class(model), row.names = seq_len(nrow(pred)), vcov = vc, jacobian = NULL, category = category, weighted = FALSE) } prediction/R/prediction_speedlm.R0000644000176200001440000000246213501406664016620 0ustar liggesusers#' @rdname prediction #' @export prediction.speedlm <- function(model, data = find_data(model, parent.frame()), at = NULL, calculate_se = FALSE, ...) { # extract predicted values data <- data if (missing(data) || is.null(data)) { pred <- predict(model, ...) pred <- make_data_frame(fitted = pred, se.fitted = rep(NA_real_, length(pred))) } else { # setup data data <- build_datalist(data, at = at, as.data.frame = TRUE) at_specification <- attr(data, "at_specification") # calculate predictions tmp <- predict(model, newdata = data, ...) # cbind back together pred <- make_data_frame(data, fitted = tmp, se.fitted = rep(NA_real_, nrow(data))) } # variance(s) of average predictions vc <- NA_real_ # output structure(pred, class = c("prediction", "data.frame"), at = if (is.null(at)) at else at_specification, type = "response", call = if ("call" %in% names(model)) model[["call"]] else NULL, model_class = class(model), row.names = seq_len(nrow(pred)), vcov = vc, jacobian = NULL, weighted = FALSE) } prediction/R/prediction_hetglm.R0000644000176200001440000000277513501406664016456 0ustar liggesusers#' @rdname prediction #' @export prediction.hetglm <- function(model, data = find_data(model, parent.frame()), at = NULL, type = c("response", "link", "scale"), calculate_se = FALSE, ...) { type <- match.arg(type) # extract predicted values data <- data if (missing(data) || is.null(data)) { pred <- make_data_frame(fitted = predict(model, type = type, ...)) } else { # setup data if (is.null(at)) { out <- data } else { out <- build_datalist(data, at = at, as.data.frame = TRUE) at_specification <- attr(out, "at_specification") } # calculate predictions tmp <- predict(model, newdata = out, type = type, ...) # cbind back together pred <- make_data_frame(out, fitted = tmp, se.fitted = rep(NA_real_, length(tmp))) } # variance(s) of average predictions vc <- NA_real_ # output structure(pred, class = c("prediction", "data.frame"), at = if (is.null(at)) at else at_specification, type = type, call = if ("call" %in% names(model)) model[["call"]] else NULL, model_class = class(model), row.names = seq_len(nrow(pred)), vcov = vc, jacobian = NULL, weighted = FALSE) } prediction/R/prediction_selection.R0000644000176200001440000000272713501406664017160 0ustar liggesusers#' @rdname prediction #' @export prediction.selection <- function(model, data = find_data(model, parent.frame()), at = NULL, type = "response", calculate_se = FALSE, ...) { # extract predicted value at input value data <- data if (missing(data) || is.null(data)) { pred <- make_data_frame(fitted = predict(model, type = type, ...), se.fitted = NA_real_) } else { # setup data if (is.null(at)) { out <- data } else { out <- build_datalist(data, at = at, as.data.frame = TRUE) at_specification <- attr(out, "at_specification") } # calculate predictions tmp <- predict(model, newdata = out, type = type, ...) # cbind back together pred <- make_data_frame(out, fitted = tmp, se.fitted = rep(NA_real_, length(tmp))) } # variance(s) of average predictions vc <- NA_real_ # output structure(pred, class = c("prediction", "data.frame"), at = if (is.null(at)) at else at_specification, type = type, call = if ("call" %in% names(model)) model[["call"]] else NULL, model_class = class(model), row.names = seq_len(nrow(pred)), vcov = vc, jacobian = NULL, weighted = FALSE) } prediction/R/prediction_lqs.R0000644000176200001440000000257713501406664015775 0ustar liggesusers#' @rdname prediction #' @export prediction.lqs <- function(model, data = find_data(model), at = NULL, calculate_se = FALSE, ...) { # extract predicted values data <- data if (missing(data) || is.null(data)) { pred <- make_data_frame(fitted = predict(model, ...), se.fitted = NA_real_) } else { # setup data if (is.null(at)) { out <- data } else { out <- build_datalist(data, at = at, as.data.frame = TRUE) at_specification <- attr(out, "at_specification") } # calculate predictions tmp <- predict(model, newdata = out, ...) # cbind back together pred <- make_data_frame(out, fitted = tmp, se.fitted = rep(NA_real_, nrow(out))) } # variance(s) of average predictions vc <- NA_real_ # output structure(pred, class = c("prediction", "data.frame"), at = if (is.null(at)) at else at_specification, type = NA_character_, call = if ("call" %in% names(model)) model[["call"]] else NULL, model_class = class(model), row.names = seq_len(nrow(pred)), vcov = vc, jacobian = NULL, weighted = FALSE) } prediction/R/prediction_earth.R0000644000176200001440000000453213501406664016272 0ustar liggesusers#' @rdname prediction #' @export prediction.earth <- function(model, data = find_data(model, parent.frame()), at = NULL, type = c("response", "link"), calculate_se = TRUE, category, ...) { type <- match.arg(type) # extract predicted values data <- data if (missing(data) || is.null(data)) { pred <- make_data_frame(fitted.class = predict(model, type = "class", ...)[,1L]) probs <- make_data_frame(predict(model, type = type, ...)) names(probs) <- paste0("Pr(", names(probs), ")") pred <- make_data_frame(pred, probs) } else { # setup data if (is.null(at)) { out <- data } else { out <- build_datalist(data, at = at, as.data.frame = TRUE) at_specification <- attr(out, "at_specification") } # calculate predictions tmp <- predict(model, newdata = out, type = "class", ...) colnames(tmp) <- "fitted.class" tmp_probs <- make_data_frame(predict(model, newdata = out, type = type, ...)) names(tmp_probs) <- paste0("Pr(", names(tmp_probs), ")") # cbind back together pred <- make_data_frame(out, tmp, tmp_probs) pred[["se.fitted"]] <- NA_real_ } # handle category argument if (missing(category)) { w <- grep("^Pr\\(", names(pred))[1L] category <- names(pred)[w] pred[["fitted"]] <- pred[[w]] } else { w <- which(names(pred) == paste0("Pr(", category, ")")) if (!length(w)) { stop(sprintf("category %s not found", category)) } pred[["fitted"]] <- pred[[ w[1L] ]] } # variance(s) of average predictions vc <- NA_real_ # output structure(pred, class = c("prediction", "data.frame"), at = if (is.null(at)) at else at_specification, type = NA_character_, call = if ("call" %in% names(model)) model[["call"]] else NULL, model_class = class(model), row.names = seq_len(nrow(pred)), vcov = vc, jacobian = NULL, category = category, weighted = FALSE) } prediction/R/prediction_hurdle.R0000644000176200001440000000267213501406664016455 0ustar liggesusers#' @rdname prediction #' @export prediction.hurdle <- function(model, data = find_data(model, parent.frame()), at = NULL, type = c("response", "count", "prob", "zero"), calculate_se = FALSE, ...) { type <- match.arg(type) # extract predicted values data <- data if (missing(data) || is.null(data)) { pred <- predict(model, type = type, ...) pred <- make_data_frame(fitted = pred[["fit"]]) } else { # setup data if (is.null(at)) { out <- data } else { out <- build_datalist(data, at = at, as.data.frame = TRUE) at_specification <- attr(out, "at_specification") } # calculate predictions pred <- predict(model, newdata = out, type = type, ...) pred <- make_data_frame(out, fitted = pred, se.fitted = rep(NA_real_, nrow(out))) } # variance(s) of average predictions vc <- NA_real_ # output structure(pred, class = c("prediction", "data.frame"), at = if (is.null(at)) at else at_specification, type = type, call = if ("call" %in% names(model)) model[["call"]] else NULL, model_class = class(model), row.names = seq_len(nrow(pred)), vcov = vc, jacobian = NULL, weighted = FALSE) } prediction/R/prediction_survreg.R0000644000176200001440000000303113501406664016655 0ustar liggesusers#' @rdname prediction #' @export prediction.survreg <- function(model, data = find_data(model, parent.frame()), at = NULL, type = c("response", "lp", "quantile", "uquantile"), calculate_se = TRUE, ...) { type <- match.arg(type) # extract predicted values data <- data if (missing(data) || is.null(data)) { pred <- predict(model, type = type, se.fit = TRUE, ...) pred <- make_data_frame(fitted = pred[["fit"]], se.fitted = pred[["se.fit"]]) } else { # setup data if (is.null(at)) { out <- data } else { out <- build_datalist(data, at = at, as.data.frame = TRUE) at_specification <- attr(out, "at_specification") } # calculate predictions tmp <- predict(model, newdata = out, type = type, se.fit = TRUE, ...) # cbind back together pred <- make_data_frame(out, fitted = tmp[["fit"]], se.fitted = tmp[["se.fit"]]) } # variance(s) of average predictions vc <- NA_real_ # output structure(pred, class = c("prediction", "data.frame"), at = if (is.null(at)) at else at_specification, type = type, call = if ("call" %in% names(model)) model[["call"]] else NULL, model_class = class(model), row.names = seq_len(nrow(pred)), vcov = vc, jacobian = NULL, weighted = FALSE) } prediction/R/prediction_vglm.R0000644000176200001440000000461113501406664016132 0ustar liggesusers# @rdname prediction # @export prediction.vglm <- function(model, data = find_data(model, parent.frame()), at = NULL, type = c("response", "link"), calculate_se = TRUE, category, ...) { type <- match.arg(type) # extract predicted values data <- data arg <- list(...) if (missing(data) || is.null(data)) { if ("se.fit" %in% names(arg)) { tmp <- predict(model, type = type, ...) pred <- make_data_frame(tmp[["fitted.values"]], se.fitted = tmp[["se.fit"]]) } else { pred <- make_data_frame(predict(model, type = type, se.fit = FALSE, ...)) } } else { # setup data if (is.null(at)) { out <- data } else { out <- build_datalist(data, at = at, as.data.frame = TRUE) at_specification <- attr(out, "at_specification") } # calculate predictions if ("se.fit" %in% names(arg)) { tmp <- predict(model, newdata = out, type = type, ...) # cbind back together pred <- make_data_frame(out, tmp[["fitted.values"]], se.fitted = tmp[["se.fit"]]) } else { tmp <- predict(model, newdata = out, type = type, ...) # cbind back together pred <- make_data_frame(out, tmp[["fitted.values"]], se.fitted = rep(NA_real_, nrow(out))) } rm(tmp) } # handle category argument if (missing(category)) { category <- names(pred)[!names(pred) %in% names(data)][1L] pred[["fitted"]] <- pred[[category]] } else { w <- grep(category, names(pred)) if (!length(w)) { stop(sprintf("category %s not found", category)) } pred[["fitted"]] <- pred[[ w[1L] ]] } # variance(s) of average predictions vc <- NA_real_ # output structure(pred, class = c("prediction", "data.frame"), at = if (is.null(at)) at else at_specification, type = type, call = if ("call" %in% names(model)) model[["call"]] else NULL, model_class = class(model), row.names = seq_len(nrow(pred)), vcov = vc, jacobian = NULL, category = category, weighted = FALSE) } prediction/R/prediction_naiveBayes.R0000644000176200001440000000410113501406664017245 0ustar liggesusers# @rdname prediction # @export prediction.naiveBayes <- function(model, data = find_data(model, parent.frame()), at = NULL, type = NULL, calculate_se = FALSE, category, ...) { # extract predicted values data <- data if (missing(data) || is.null(data)) { warning(sprintf("'data' is ignored for models of class '%s'", class(model))) } if (!is.null(type)) { warning(sprintf("'type' is ignored for models of class '%s'", class(model))) } # setup data if (is.null(at)) { out <- data } else { out <- build_datalist(data, at = at, as.data.frame = TRUE) at_specification <- attr(out, "at_specification") } # calculate predictions pred <- predict(model, newdata = out, type = "class", ...) probs <- make_data_frame(predict(model, newdata = out, type = "raw", ...)) names(probs) <- paste0("Pr(", names(probs), ")") # cbind back together pred <- make_data_frame(out, probs, fitted.class = pred, se.fitted = rep(NA_real_, nrow(out))) # handle category argument if (missing(category)) { w <- grep("^Pr\\(", names(pred))[1L] category <- names(pred)[w] pred[["fitted"]] <- pred[[w]] } else { w <- which(names(pred) == paste0("Pr(", category, ")")) if (!length(w)) { stop(sprintf("category %s not found", category)) } pred[["fitted"]] <- pred[[ w[1L] ]] } # variance(s) of average predictions vc <- NA_real_ # output structure(pred, class = c("prediction", "data.frame"), at = if (is.null(at)) at else at_specification, type = NA_character_, call = if ("call" %in% names(model)) model[["call"]] else NULL, model_class = class(model), row.names = seq_len(nrow(pred)), vcov = vc, jacobian = NULL, category = category, weighted = FALSE) } prediction/R/prediction_nls.R0000644000176200001440000000260713501406664015764 0ustar liggesusers#' @rdname prediction #' @export prediction.nls <- function(model, data = find_data(model, parent.frame()), at = NULL, calculate_se = FALSE, ...) { # extract predicted values data <- data if (missing(data) || is.null(data)) { pred <- make_data_frame(fitted = predict(model, ...), se.fitted = NA_real_) } else { # setup data if (is.null(at)) { out <- data } else { out <- build_datalist(data, at = at, as.data.frame = TRUE) at_specification <- attr(out, "at_specification") } # calculate predictions tmp <- predict(model, newdata = out, ...) # cbind back together pred <- make_data_frame(out, fitted = tmp, se.fitted = rep(NA_real_, length(tmp))) } # variance(s) of average predictions vc <- NA_real_ # output structure(pred, class = c("prediction", "data.frame"), at = if (is.null(at)) at else at_specification, type = NA_character_, call = if ("call" %in% names(model)) model[["call"]] else NULL, model_class = class(model), row.names = seq_len(nrow(pred)), vcov = vc, jacobian = NULL, weighted = FALSE) } prediction/R/prediction_ivreg.R0000644000176200001440000000252313501406664016301 0ustar liggesusers#' @rdname prediction #' @export prediction.ivreg <- function(model, data = find_data(model, parent.frame()), at = NULL, calculate_se = FALSE, ...) { # extract predicted values data <- data if (missing(data) || is.null(data)) { pred <- make_data_frame(fitted = predict(model, ...), se.fitted = NA_real_) } else { # setup data if (is.null(at)) { out <- data } else { out <- build_datalist(data, at = at, as.data.frame = TRUE) at_specification <- attr(out, "at_specification") } # calculate predictions tmp <- predict(model, newdata = out, ...) # cbind back together pred <- make_data_frame(out, fitted = tmp, se.fitted = rep(NA_real_, nrow(out))) } # variance(s) of average predictions vc <- NA_real_ # output structure(pred, class = c("prediction", "data.frame"), at = if (is.null(at)) at else at_specification, type = NA_character_, call = if ("call" %in% names(model)) model[["call"]] else NULL, model_class = class(model), row.names = seq_len(nrow(pred)), vcov = vc, jacobian = NULL, weighted = FALSE) } prediction/R/prediction_zeroinfl.R0000644000176200001440000000011513075430055017005 0ustar liggesusers#' @rdname prediction #' @export prediction.zeroinfl <- prediction.hurdle prediction/R/prediction_qda.R0000644000176200001440000000413013501406664015726 0ustar liggesusers# @rdname prediction # @export prediction.qda <- function(model, data = find_data(model, parent.frame()), at = NULL, calculate_se = FALSE, category, ...) { # extract predicted values data <- data if (missing(data) || is.null(data)) { pred <- predict(model, ...) colnames(pred[["posterior"]]) <- paste0("Pr(", colnames(pred[["posterior"]]), ")") pred <- make_data_frame(fitted.class = pred[["class"]], pred[["posterior"]]) } else { # setup data if (is.null(at)) { out <- data } else { out <- build_datalist(data, at = at, as.data.frame = TRUE) at_specification <- attr(out, "at_specification") } # calculate predictions tmp <- predict(model, newdata = out, ...) colnames(tmp[["posterior"]]) <- paste0("Pr(", colnames(tmp[["posterior"]]), ")") # cbind back together pred <- make_data_frame(out, fitted.class = tmp[["class"]], tmp[["posterior"]], se.fitted = rep(NA_real_, nrow (out))) } # handle category argument if (missing(category)) { w <- grep("^Pr\\(", names(pred))[1L] category <- names(pred)[w] pred[["fitted"]] <- pred[[w]] } else { w <- which(names(pred) == paste0("Pr(", category, ")")) if (!length(w)) { stop(sprintf("category %s not found", category)) } pred[["fitted"]] <- pred[[ w[1L] ]] } # variance(s) of average predictions vc <- NA_real_ # output structure(pred, class = c("prediction", "data.frame"), at = if (is.null(at)) at else at_specification, type = NA_character_, call = if ("call" %in% names(model)) model[["call"]] else NULL, model_class = class(model), row.names = seq_len(nrow(pred)), vcov = vc, jacobian = NULL, category = category, weighted = FALSE) } prediction/R/prediction_mnlogit.R0000644000176200001440000000432313501406664016636 0ustar liggesusers# @rdname prediction # @export prediction.mnlogit <- function(model, data = find_data(model, parent.frame()), at = NULL, calculate_se = FALSE, category, ...) { # extract predicted values data <- data if (missing(data) || is.null(data)) { pred <- make_data_frame(fitted.class = predict(model, probability = FALSE, ...)) probs <- make_data_frame(predict(model, probability = TRUE, ...)) names(probs) <- paste0("Pr(", names(probs), ")") pred <- make_data_frame(pred, probs) } else { # setup data if (is.null(at)) { out <- data } else { out <- build_datalist(data, at = at, as.data.frame = TRUE) at_specification <- attr(out, "at_specification") } # calculate predictions tmp <- predict(model, newdata = out, probability = FALSE, ...) tmp_probs <- make_data_frame(predict(model, newdata = out, probability = TRUE, ...)) names(tmp_probs) <- paste0("Pr(", names(tmp_probs), ")") # cbind back together pred <- make_data_frame(out, fitted.class = tmp, tmp_probs) rm(tmp, tmp_probs) } # handle category argument if (missing(category)) { w <- grep("^Pr\\(", names(pred))[1L] category <- names(pred)[w] pred[["fitted"]] <- pred[[w]] } else { w <- which(names(pred) == paste0("Pr(", category, ")")) if (!length(w)) { stop(sprintf("category %s not found", category)) } pred[["fitted"]] <- pred[[ w[1L] ]] } pred[["se.fitted"]] <- NA_real_ # variance(s) of average predictions vc <- NA_real_ # output structure(pred, class = c("prediction", "data.frame"), at = if (is.null(at)) at else at_specification, type = NA_character_, call = if ("call" %in% names(model)) model[["call"]] else NULL, model_class = class(model), row.names = seq_len(nrow(pred)), vcov = vc, jacobian = NULL, category = category, weighted = FALSE) }prediction/R/prediction_crch.R0000644000176200001440000000274313501406664016110 0ustar liggesusers#' @rdname prediction #' @export prediction.crch <- function(model, data = find_data(model), at = NULL, type = c("response", "location", "scale", "quantile"), calculate_se = FALSE, ...) { type <- match.arg(type) # extract predicted values data <- data if (missing(data) || is.null(data)) { pred <- make_data_frame(fitted = predict(model, type = type, ...), se.fitted = NA_real_) } else { # setup data if (is.null(at)) { out <- data } else { out <- build_datalist(data, at = at, as.data.frame = TRUE) at_specification <- attr(out, "at_specification") } # calculate predictions tmp <- predict(model, newdata = out, type = type, ...) # cbind back together pred <- make_data_frame(out, fitted = tmp, se.fitted = rep(NA_real_, length(tmp))) } # variance(s) of average predictions vc <- NA_real_ # output structure(pred, class = c("prediction", "data.frame"), at = if (is.null(at)) at else at_specification, type = type, call = if ("call" %in% names(model)) model[["call"]] else NULL, model_class = class(model), row.names = seq_len(nrow(pred)), vcov = vc, jacobian = NULL, weighted = FALSE) } prediction/R/prediction_glmnet.R0000644000176200001440000000302013501406664016444 0ustar liggesusers#' @rdname prediction #' @param lambda For models of class \dQuote{glmnet}, a value of the penalty parameter at which predictions are required. #' @export prediction.glmnet <- function( model, data, lambda = model[["lambda"]][1L], at = NULL, type = c("response", "link"), calculate_se = FALSE, ... ) { # glmnet models only operate with a matrix interface type <- match.arg(type) # extract predicted values data <- data if (missing(data) || is.null(data)) { warning(sprintf("'data' is required for models of class '%s'", class(model))) } else { # setup data out <- build_datalist(data, at = at, as.data.frame = TRUE) at_specification <- attr(out, "at_specification") # calculate predictions tmp <- predict(model, newx = out, type = type, s = lambda, ...) # cbind back together pred <- make_data_frame(out, fitted = tmp[, 1L, drop = TRUE], se.fitted = rep(NA_real_, nrow(out))) } # variance(s) of average predictions vc <- NA_real_ # output structure(pred, class = c("prediction", "data.frame"), at = if (is.null(at)) at else at_specification, type = type, call = if ("call" %in% names(model)) model[["call"]] else NULL, model_class = class(model), row.names = seq_len(nrow(pred)), vcov = vc, jacobian = NULL, weighted = FALSE) } prediction/R/prediction_mlogit.R0000644000176200001440000000352013501406664016456 0ustar liggesusers# @rdname prediction # @export prediction.mlogit <- function(model, data = find_data(model, parent.frame()), at = NULL, calculate_se = FALSE, category, ...) { # extract predicted values data <- data if (missing(data) || is.null(data)) { warning(sprintf("'data' is ignored for models of class '%s'", class(model))) } # setup data if (is.null(at)) { out <- data } else { out <- build_datalist(data, at = at, as.data.frame = TRUE) at_specification <- attr(out, "at_specification") } # calculate predictions tmp <- make_data_frame(predict(model, newdata = out, ...)) names(tmp) <- paste0("Pr(", seq_len(ncol(tmp)), ")") # cbind back together pred <- make_data_frame(out, tmp) rm(tmp) # handle category argument if (missing(category)) { w <- grep("^Pr\\(", names(pred))[1L] category <- names(pred)[w] pred[["fitted"]] <- pred[[w]] } else { w <- which(names(pred) == paste0("Pr(", category, ")")) if (!length(w)) { stop(sprintf("category %s not found", category)) } pred[["fitted"]] <- pred[[ w[1L] ]] } pred[["se.fitted"]] <- NA_real_ # variance(s) of average predictions vc <- NA_real_ # output structure(pred, class = c("prediction", "data.frame"), at = if (is.null(at)) at else at_specification, type = NA_character_, call = if ("call" %in% names(model)) model[["call"]] else NULL, model_class = class(model), row.names = seq_len(nrow(pred)), vcov = vc, jacobian = NULL, category = category, weighted = FALSE) } prediction/R/prediction_polr.R0000644000176200001440000000011313066747142016137 0ustar liggesusers#' @rdname prediction #' @export prediction.polr <- prediction.multinom prediction/R/prediction_loess.R0000644000176200001440000000270113501406664016310 0ustar liggesusers#' @rdname prediction #' @export prediction.loess <- function(model, data = find_data(model, parent.frame()), at = NULL, type = "response", calculate_se = TRUE, ...) { type <- match.arg(type) # extract predicted values data <- data if (missing(data) || is.null(data)) { pred <- predict(model, type = type, se = TRUE, ...) pred <- make_data_frame(fitted = pred[["fit"]], se.fitted = pred[["se.fit"]]) } else { # setup data if (is.null(at)) { out <- data } else { out <- build_datalist(data, at = at, as.data.frame = TRUE) at_specification <- attr(out, "at_specification") } # calculate predictions tmp <- predict(model, newdata = out, type = type, se = TRUE, ...) # cbind back together pred <- make_data_frame(out, fitted = tmp[["fit"]], se.fitted = tmp[["se.fit"]]) } # variance(s) of average predictions J <- NULL vc <- NA_real_ # output structure(pred, class = c("prediction", "data.frame"), at = if (is.null(at)) at else at_specification, type = type, call = if ("call" %in% names(model)) model[["call"]] else NULL, model_class = class(model), row.names = seq_len(nrow(pred)), vcov = vc, jacobian = J, weighted = FALSE) } prediction/R/prediction_glmx.R0000644000176200001440000000300213501406664016125 0ustar liggesusers#' @rdname prediction #' @export prediction.glmx <- function(model, data = find_data(model, parent.frame()), at = NULL, type = c("response", "link"), calculate_se = FALSE, ...) { type <- match.arg(type) # extract predicted values data <- data if (missing(data) || is.null(data)) { pred <- make_data_frame(fitted = predict(model, newdata = data, type = type, ...)) } else { # setup data if (is.null(at)) { out <- data } else { out <- build_datalist(data, at = at, as.data.frame = TRUE) at_specification <- attr(out, "at_specification") } # calculate predictions tmp <- predict(model, newdata = out, type = type, ...) # cbind back together pred <- make_data_frame(out, fitted = tmp, se.fitted = rep(NA_real_, length(tmp))) } # variance(s) of average predictions vc <- NA_real_ # output structure(pred, class = c("prediction", "data.frame"), at = if (is.null(at)) at else at_specification, type = type, call = if ("call" %in% names(model)) model[["call"]] else NULL, model_class = class(model), row.names = seq_len(nrow(pred)), vcov = vc, jacobian = NULL, weighted = FALSE) } prediction/R/prediction_biglm.R0000644000176200001440000000327513501406664016264 0ustar liggesusers#' @rdname prediction #' @export prediction.biglm <- function(model, data = find_data(model, parent.frame()), at = NULL, type = "response", calculate_se = TRUE, ...) { type <- match.arg(type) # extract predicted values data <- data if (missing(data) || is.null(data)) { stop("prediction() for objects of class 'biglm' only work when 'data' is specified") } else { # reduce memory profile model[["model"]] <- NULL # setup data data <- build_datalist(data, at = at, as.data.frame = TRUE) at_specification <- attr(data, "at_specification") # calculate predictions if (isTRUE(calculate_se)) { tmp <- predict(model, newdata = data, se.fit = TRUE, ...) # cbind back together pred <- make_data_frame(data, fitted = tmp[["fit"]], se.fitted = tmp[["se.fit"]]) } else { tmp <- predict(model, newdata = data, se.fit = FALSE, ...) # cbind back together pred <- make_data_frame(data, fitted = tmp, se.fitted = rep(NA_real_, nrow(data))) } } # variance(s) of average predictions vc <- NA_real_ # output structure(pred, class = c("prediction", "data.frame"), at = if (is.null(at)) at else at_specification, type = type, call = if ("call" %in% names(model)) model[["call"]] else NULL, model_class = class(model), row.names = seq_len(nrow(pred)), vcov = vc, jacobian = NULL, weighted = FALSE) } prediction/R/prediction_bruto.R0000644000176200001440000000267613501406664016331 0ustar liggesusers#' @rdname prediction #' @export prediction.bruto <- function(model, data = NULL, at = NULL, type = "fitted", calculate_se = FALSE, ...) { type <- match.arg(type) # extract predicted values data <- data if (missing(data) || is.null(data)) { pred <- predict(model, type = type, ...) pred <- make_data_frame(fitted = pred[,1L], se.fitted = rep(NA_real_, length(pred))) } else { # setup data data <- build_datalist(data, at = at, as.data.frame = TRUE) at_specification <- attr(data, "at_specification") # calculate predictions if (!is.matrix(data)) { data <- as.matrix(data) } tmp <- predict(model, newdata = data, type = type, ...) # cbind back together pred <- make_data_frame(data, fitted = tmp[,1L], se.fitted = rep(NA_real_, nrow(data))) } # variance(s) of average predictions vc <- NA_real_ # output structure(pred, class = c("prediction", "data.frame"), at = if (is.null(at)) at else at_specification, type = type, call = if ("call" %in% names(model)) model[["call"]] else NULL, model_class = class(model), row.names = seq_len(nrow(pred)), vcov = vc, jacobian = NULL, weighted = FALSE) } prediction/R/prediction_merMod.R0000644000176200001440000000271513501406664016413 0ustar liggesusers#' @rdname prediction #' @param re.form An argument passed forward to \code{\link[lme4]{predict.merMod}}. #' @export prediction.merMod <- function(model, data = find_data(model), at = NULL, type = c("response", "link"), re.form = NULL, calculate_se = FALSE, ...) { type <- match.arg(type) # extract predicted values data <- data if (missing(data) || is.null(data)) { pred <- make_data_frame(fitted = predict(model, type = type, re.form = re.form, ...)) } else { # setup data if (is.null(at)) { out <- data } else { out <- build_datalist(data, at = at, as.data.frame = TRUE) at_specification <- attr(out, "at_specification") } # calculate predictions tmp <- predict(model, newdata = out, type = type, re.form = re.form, ...) pred <- make_data_frame(out, fitted = tmp, se.fitted = rep(NA_real_, nrow(out))) } # variance(s) of average predictions vc <- NA_real_ # output structure(pred, class = c("prediction", "data.frame"), at = if (is.null(at)) at else at_specification, type = type, call = if ("call" %in% names(model)) model[["call"]] else NULL, model_class = class(model), row.names = seq_len(nrow(pred)), vcov = vc, jacobian = NULL, weighted = FALSE) } prediction/R/prediction_gls.R0000644000176200001440000000273513501406664015757 0ustar liggesusers#' @rdname prediction #' @export prediction.gls <- function(model, data = find_data(model), at = NULL, calculate_se = FALSE, ...) { # extract predicted values data <- data if (missing(data) || is.null(data)) { pred <- make_data_frame(fitted = predict(model, type = "class", ...), se.fitted = NA_real_) } else { # setup data if (is.null(at)) { out <- data } else { out <- build_datalist(data, at = at, as.data.frame = TRUE) at_specification <- attr(out, "at_specification") } # calculate predictions tmp <- predict(model, newdata = out, type = "class", ...) # cbind back together pred <- make_data_frame(out, fitted = tmp, se.fitted = rep(NA_real_, length(tmp))) } # variance(s) of average predictions vc <- NA_real_ # output structure(pred, class = c("prediction", "data.frame"), at = if (is.null(at)) at else at_specification, type = NA_character_, call = if ("call" %in% names(model)) model[["call"]] else NULL, model_class = class(model), row.names = seq_len(nrow(pred)), vcov = vc, jacobian = NULL, weighted = FALSE) } prediction/R/prediction_kqr.R0000644000176200001440000000232713501406664015764 0ustar liggesusers#' @rdname prediction #' @export prediction.kqr <- function(model, data, at = NULL, calculate_se = FALSE, ...) { requireNamespace("kernlab") # extract predicted values if (missing(data) || is.null(data)) { pred <- make_data_frame(fitted = kernlab::predict(object = model, ...)[,1L]) } else { # setup data if (is.null(at)) { out <- data } else { out <- build_datalist(data, at = at, as.data.frame = TRUE) at_specification <- attr(out, "at_specification") } pred <- make_data_frame(fitted = kernlab::predict(model, newdata = data,...)[,1L]) } pred[["se.fitted"]] <- NA_real_ # variance(s) of average predictions vc <- NA_real_ # output structure(pred, class = c("prediction", "data.frame"), at = if (is.null(at)) at else at_specification, type = NA_character_, call = if ("call" %in% names(model)) model[["call"]] else NULL, model_class = class(model), row.names = seq_len(nrow(pred)), vcov = vc, jacobian = NULL, weighted = FALSE) } prediction/R/prediction_Arima.R0000644000176200001440000000170613501406664016220 0ustar liggesusers#' @rdname prediction #' @export prediction.Arima <- function(model, calculate_se = TRUE,...) { # extract predicted values if (isTRUE(calculate_se)) { tmp <- predict(object = model, se.fit = TRUE, ...) pred <- make_data_frame(fitted = tmp[[1L]], se.fitted = tmp[[2L]]) } else { tmp <- predict(object = model, se.fit = FALSE, ...) pred <- make_data_frame(fitted = tmp, se.fitted = rep(NA_real_, length(tmp))) } # variance(s) of average predictions vc <- NA_real_ # output structure(pred, class = c("prediction", "data.frame"), at = NULL, type = NA_character_, call = if ("call" %in% names(model)) model[["call"]] else NULL, model_class = class(model), row.names = seq_len(nrow(pred)), vcov = vc, jacobian = NULL, weighted = FALSE) } prediction/R/make_data_frame.R0000644000176200001440000000033313331141256016014 0ustar liggesusers# internal function that overrides the defaults of `data.frame()` make_data_frame <- function(...) { data.frame(..., check.rows = FALSE, check.names = FALSE, fix.empty.names = FALSE, stringsAsFactors = FALSE) } prediction/R/prediction_mca.R0000644000176200001440000000222213501406664015721 0ustar liggesusers#' @rdname prediction #' @export prediction.mca <- function(model, data = find_data(model), at = NULL, calculate_se = FALSE, ...) { # extract predicted values # setup data if (is.null(at)) { out <- data } else { out <- build_datalist(data, at = at, as.data.frame = TRUE) at_specification <- attr(out, "at_specification") } # calculate predictions tmp <- predict(model, newdata = out, ...) # cbind back together pred <- make_data_frame(out, tmp) pred[["fitted"]] <- NA_real_ pred[["se.fitted"]] <- NA_real_ # variance(s) of average predictions vc <- NA_real_ # output structure(pred, class = c("prediction", "data.frame"), at = if (is.null(at)) at else at_specification, type = NA_character_, call = if ("call" %in% names(model)) model[["call"]] else NULL, model_class = class(model), row.names = seq_len(nrow(pred)), vcov = vc, jacobian = NULL, weighted = FALSE) } prediction/R/prediction_arima0.R0000644000176200001440000000010713066747141016336 0ustar liggesusers#' @rdname prediction #' @export prediction.arima0 <- prediction.ar prediction/R/prediction_tree.R0000644000176200001440000000511313501406664016122 0ustar liggesusers# @rdname prediction # @export prediction.tree <- function(model, data = find_data(model, parent.frame()), at = NULL, type = NULL, calculate_se = FALSE, category, ...) { if (!is.null(type)) { warning(sprintf("'type' is ignored for models of class '%s'", class(model))) } # extract predicted values data <- data if (missing(data) || is.null(data)) { if (is.factor(model[["y"]])) { pred <- make_data_frame(fitted.class = predict(model, type = "class", ...)) probs <- make_data_frame(predict(model, type = "vector", ...)) names(probs) <- paste0("Pr(", names(probs), ")") } else { pred <- make_data_frame(fitted = predict(model, type = "vector"), fitted.class = predict(model, type = "class", ...)) } pred <- make_data_frame(pred, probs) } else { # setup data if (is.null(at)) { out <- data } else { out <- build_datalist(data, at = at, as.data.frame = TRUE) at_specification <- attr(out, "at_specification") } # calculate predictions tmp <- predict(model, newdata = out, type = "class", ...) tmp_probs <- make_data_frame(predict(model, newdata = out, type = "probs", ...)) names(tmp_probs) <- paste0("Pr(", names(tmp_probs), ")") # cbind back together pred <- make_data_frame(out, fitted.class = tmp, tmp_probs) rm(tmp, tmp_probs) } # handle category argument if (missing(category)) { w <- grep("^Pr\\(", names(pred))[1L] category <- names(pred)[w] pred[["fitted"]] <- pred[[w]] } else { w <- which(names(pred) == paste0("Pr(", category, ")")) if (!length(w)) { stop(sprintf("category %s not found", category)) } pred[["fitted"]] <- pred[[ w[1L] ]] } pred[["se.fitted"]] <- NA_real_ # variance(s) of average predictions vc <- NA_real_ # output structure(pred, class = c("prediction", "data.frame"), at = if (is.null(at)) at else at_specification, type = NA_character_, call = if ("call" %in% names(model)) model[["call"]] else NULL, model_class = class(model), row.names = seq_len(nrow(pred)), vcov = vc, jacobian = NULL, category = category, weighted = FALSE) } prediction/R/prediction_speedglm.R0000644000176200001440000000275313501406664016772 0ustar liggesusers#' @rdname prediction #' @export prediction.speedglm <- function(model, data = find_data(model, parent.frame()), at = NULL, type = c("response", "link"), calculate_se = FALSE, ...) { type <- match.arg(type) # extract predicted values data <- data if (missing(data) || is.null(data)) { pred <- predict(model, type = type, ...) pred <- make_data_frame(fitted = pred, se.fitted = rep(NA_real_, length(pred))) } else { # reduce memory profile model[["model"]] <- NULL # setup data out <- build_datalist(data, at = at, as.data.frame = TRUE) at_specification <- attr(out, "at_specification") # calculate predictions tmp <- predict(model, newdata = out, type = type, se.fit = FALSE, ...) # cbind back together pred <- make_data_frame(out, fitted = tmp, se.fitted = rep(NA_real_, nrow(out))) } # variance(s) of average predictions vc <- NA_real_ # output structure(pred, class = c("prediction", "data.frame"), at = if (is.null(at)) at else at_specification, type = type, call = if ("call" %in% names(model)) model[["call"]] else NULL, model_class = class(model), row.names = seq_len(nrow(pred)), vcov = vc, jacobian = NULL, weighted = FALSE) } prediction/R/margex.R0000644000176200001440000000561713501406664014237 0ustar liggesusers#' @rdname margex #' @docType data #' @title Artificial data for margins, copied from Stata #' @description The dataset is identical to the one provided by Stata and available from \code{webuse::webuse("margex")} with categorical variables explicitly encoded as factors. #' @format A data frame with 3000 observations on the following 11 variables. #' \describe{ #' \item{\samp{y}}{A numeric vector} #' \item{\samp{outcome}}{A binary numeric vector with values (0,1)} #' \item{\samp{sex}}{A factor with two levels} #' \item{\samp{group}}{A factor with three levels} #' \item{\samp{age}}{A numeric vector} #' \item{\samp{distance}}{A numeric vector} #' \item{\samp{ycn}}{A numeric vector} #' \item{\samp{yc}}{A numeric vector} #' \item{\samp{treatment}}{A factor with two levels} #' \item{\samp{agegroup}}{A factor with three levels} #' \item{\samp{arm}}{A factor with three levels} #' } #' @source \url{http://www.stata-press.com/data/r14/margex.dta} #' @examples #' \donttest{ #' #' # Examples from Stata's help files #' # Also available from: webuse::webuse("margex") #' data("margex") #' #' # A simple case after regress #' # . regress y i.sex i.group #' # . margins sex #' m1 <- lm(y ~ factor(sex) + factor(group), data = margex) #' prediction(m1, at = list(sex = c("male", "female"))) #' #' # A simple case after logistic #' # . logistic outcome i.sex i.group #' # . margins sex #' m2 <- glm(outcome ~ sex + group, binomial(), data = margex) #' prediction(m2, at = list(sex = c("male", "female"))) #' #' # Average response versus response at average #' # . margins sex #' prediction(m2, at = list(sex = c("male", "female"))) #' # . margins sex, atmeans #' ## TODO #' #' # Multiple margins from one margins command #' # . margins sex group #' prediction(m2, at = list(sex = c("male", "female"))) #' prediction(m2, at = list(group = c("1", "2", "3"))) #' #' # Margins with interaction terms #' # . logistic outcome i.sex i.group sex#group #' # . margins sex group #' m3 <- glm(outcome ~ sex * group, binomial(), data = margex) #' prediction(m3, at = list(sex = c("male", "female"))) #' prediction(m3, at = list(group = c("1", "2", "3"))) #' #' # Margins with continuous variables #' # . logistic outcome i.sex i.group sex#group age #' # . margins sex group #' m4 <- glm(outcome ~ sex * group + age, binomial(), data = margex) #' prediction(m4, at = list(sex = c("male", "female"))) #' prediction(m4, at = list(group = c("1", "2", "3"))) #' #' # Margins of continuous variables #' # . margins, at(age=40) #' prediction(m4, at = list(age = 40)) #' # . margins, at(age=(30 35 40 45 50)) #' prediction(m4, at = list(age = c(30, 35, 40, 45, 50))) #' #' # Margins of interactions #' # . margins sex#group #' prediction(m4, at = list(sex = c("male", "female"), group = c("1", "2", "3"))) #' #' } #' @seealso \code{\link{prediction}} "margex" prediction/R/prediction_polyreg.R0000644000176200001440000000270013501406664016643 0ustar liggesusers#' @rdname prediction #' @export prediction.polyreg <- function(model, data = NULL, at = NULL, type = "fitted", calculate_se = FALSE, ...) { type <- match.arg(type) # extract predicted values data <- data if (missing(data) || is.null(data)) { pred <- predict(model, type = type, ...) pred <- make_data_frame(fitted = pred[,1L], se.fitted = rep(NA_real_, length(pred))) } else { # setup data data <- build_datalist(data, at = at, as.data.frame = TRUE) at_specification <- attr(data, "at_specification") # calculate predictions if (!is.matrix(data)) { data <- as.matrix(data) } tmp <- predict(model, newdata = data, type = type, ...) # cbind back together pred <- make_data_frame(data, fitted = tmp[,1L], se.fitted = rep(NA_real_, nrow(data))) } # variance(s) of average predictions vc <- NA_real_ # output structure(pred, class = c("prediction", "data.frame"), at = if (is.null(at)) at else at_specification, type = type, call = if ("call" %in% names(model)) model[["call"]] else NULL, model_class = class(model), row.names = seq_len(nrow(pred)), vcov = vc, jacobian = NULL, weighted = FALSE) } prediction/R/prediction_svm.R0000644000176200001440000000640113501406664015771 0ustar liggesusers#' @rdname prediction #' @export prediction.svm <- function(model, data = NULL, at = NULL, calculate_se = TRUE, category, ...) { # extract predicted value data <- data anyp <- grep("prob.+", names(model)) if (length(anyp) && !is.null(model[[ anyp[1L] ]])) { probability <- TRUE } else { probability <- FALSE } if (missing(data) || is.null(data)) { tmp <- predict(model, decision.values = TRUE, probability = probability, ...) pred <- data.frame(fitted.class = tmp) attributes(pred[["fitted.class"]]) <- NULL if (!is.null(attributes(tmp)[["probabilities"]])) { probs <- data.frame(attributes(tmp)[["probabilities"]]) names(probs) <- paste0("Pr(", names(probs), ")") pred <- make_data_frame(pred, probs) } if (!is.null(attributes(tmp)[["decision.values"]])) { dvs <- data.frame(attributes(tmp)[["decision.values"]]) names(dvs) <- paste0("dv(", names(dvs), ")") pred <- make_data_frame(pred, dvs) } } else { if (is.null(at)) { out <- data } else { out <- build_datalist(data, at = at, as.data.frame = TRUE) at_specification <- attr(out, "at_specification") } tmp <- predict(model, newdata = out, decision.values = TRUE, probability = probability, ...) pred <- make_data_frame(out, fitted.class = tmp) attributes(pred[["fitted.class"]]) <- NULL if (!is.null(attributes(tmp)[["probabilities"]])) { probs <- data.frame(attributes(tmp)[["probabilities"]]) names(probs) <- paste0("Pr(", names(probs), ")") pred <- make_data_frame(pred, probs) } if (!is.null(attributes(tmp)[["decision.values"]])) { dvs <- data.frame(attributes(tmp)[["decision.values"]]) names(dvs) <- paste0("dv(", names(dvs), ")") pred <- make_data_frame(pred, dvs) } } # handle category argument if (missing(category)) { w <- grep("^Pr\\(", names(pred))[1L] if (is.na(w)) { pred[["fitted"]] <- NA_real_ category <- NULL } else { category <- names(pred)[w] pred[["fitted"]] <- pred[[w]] } } else { w <- which(names(pred) == paste0("Pr(", category, ")")) if (!length(w)) { stop(sprintf("category %s not found", category)) } pred[["fitted"]] <- pred[[ w[1L] ]] } pred[["se.fitted"]] <- NA_real_ # obs-x-(ncol(data)+2+nlevels(outcome)) data.frame of predictions # variance(s) of average predictions vc <- NA_real_ # output structure(pred, class = c("prediction", "data.frame"), at = if (is.null(at)) at else at_specification, type = NA_character_, call = if ("call" %in% names(model)) model[["call"]] else NULL, model_class = class(model), row.names = seq_len(nrow(pred)), vcov = vc, jacobian = NULL, category = category, weighted = FALSE) } prediction/R/prediction_mars.R0000644000176200001440000000270613501406664016132 0ustar liggesusers#' @rdname prediction #' @export prediction.mars <- function(model, data = NULL, at = NULL, type = "fitted", calculate_se = FALSE, ...) { type <- match.arg(type) # extract predicted values data <- data if (missing(data) || is.null(data)) { pred <- predict(model, type = type, ...) pred <- make_data_frame(fitted = pred[,1L], se.fitted = rep(NA_real_, length(pred))) } else { # setup data data <- build_datalist(data, at = at, as.data.frame = TRUE) at_specification <- attr(data, "at_specification") # calculate predictions if (!is.matrix(data)) { data <- as.matrix(data) } tmp <- predict(model, newdata = data, type = type, ...) # cbind back together pred <- make_data_frame(data, fitted = tmp[,1L], se.fitted = rep(NA_real_, nrow(data))) } # variance(s) of average predictions vc <- NA_real_ # output structure(pred, class = c("prediction", "data.frame"), at = if (is.null(at)) at else at_specification, type = NA_character_, call = if ("call" %in% names(model)) model[["call"]] else NULL, model_class = class(model), row.names = seq_len(nrow(pred)), vcov = vc, jacobian = NULL, weighted = FALSE) } prediction/R/prediction_bigFastLm.R0000644000176200001440000000232613501406664017036 0ustar liggesusers# @rdname prediction # @export prediction.bigLm <- function(model, data = NULL, calculate_se = FALSE, ...) { # extract predicted values data <- data if (missing(data) || is.null(data)) { pred <- predict(model, ...) pred <- make_data_frame(fitted = pred, se.fitted = rep(NA_real_, length(pred))) } else { # setup data #data <- build_datalist(data, at = at, as.data.frame = TRUE) #at_specification <- attr(data, "at_specification") # calculate predictions tmp <- predict(model, newdata = data, ...) # cbind back together pred <- make_data_frame(data, fitted = tmp, se.fitted = rep(NA_real_, nrow(data))) } # variance(s) of average predictions vc <- NA_real_ # output structure(pred, class = c("prediction", "data.frame"), at = NULL, type = "response", call = if ("call" %in% names(model)) model[["call"]] else NULL, model_class = class(model), row.names = seq_len(nrow(pred)), vcov = vc, jacobian = NULL, weighted = FALSE) }prediction/R/prediction_lda.R0000644000176200001440000000422713501406664015730 0ustar liggesusers# @rdname prediction # @export prediction.lda <- function(model, data = find_data(model, parent.frame()), at = NULL, calculate_se = FALSE, category, ...) { # extract predicted values data <- data if (missing(data) || is.null(data)) { pred <- predict(model, ...) colnames(pred[["posterior"]]) <- paste0("Pr(", colnames(pred[["posterior"]]), ")") pred <- make_data_frame(class = pred[["class"]], pred[["x"]], pred[["posterior"]]) } else { # setup data if (is.null(at)) { out <- data } else { out <- build_datalist(data, at = at, as.data.frame = TRUE) at_specification <- attr(out, "at_specification") } # calculate predictions tmp <- predict(model, newdata = out, ...) colnames(tmp[["posterior"]]) <- paste0("Pr(", colnames(tmp[["posterior"]]), ")") # cbind back together pred <- make_data_frame(out, make_data_frame(tmp[["x"]]), class = tmp[["class"]], tmp[["posterior"]]) pred[["se.fitted"]] <- NA_real_ } # handle category argument if (missing(category)) { w <- grep("^Pr\\(", names(pred))[1L] category <- names(pred)[w] pred[["fitted"]] <- pred[[w]] } else { w <- which(names(pred) == paste0("Pr(", category, ")")) if (!length(w)) { stop(sprintf("category %s not found", category)) } pred[["fitted"]] <- pred[[ w[1L] ]] } # variance(s) of average predictions vc <- NA_real_ # output structure(pred, class = c("prediction", "data.frame"), at = if (is.null(at)) at else at_specification, type = NA_character_, call = if ("call" %in% names(model)) model[["call"]] else NULL, model_class = class(model), row.names = seq_len(nrow(pred)), vcov = vc, jacobian = NULL, category = category, weighted = FALSE) } prediction/R/print.R0000644000176200001440000000667613501406664014116 0ustar liggesusers#' @export print.prediction <- function(x, digits = 4, ...) { # gather metadata f <- x[["fitted"]] fc <- x[["fitted.class"]] ## at at <- attributes(x)[["at"]] at_names <- setdiff(names(attr(x, "at")), "index") ## weights is_weighted <- attr(x, "weighted") if (isTRUE(is_weighted)) { wts <- x[["_weights"]] } # calculate overall predictions ## if no 'at_specification', simply calculate overall average/mode and print if (is.null(at)) { # object is a single replication with no 'at' specification if ("fitted.class" %in% names(x) || is.list(fc)) { # factor outcome m <- sort(table(x[["fitted.class"]]), decreasing = TRUE)[1L] message( sprintf("Data frame with %d %s%swith modal prediction (of %d %s):", length(fc), ngettext(length(fc), "prediction", "predictions"), if (!is.null(attr(x, "call"))) sprintf(" from\n %s\n", paste0(deparse(attr(x, "call")), collapse = "\n")) else "", nlevels(factor(fc)), ngettext(nlevels(f), "level", "levels"), shQuote(names(m)) ) ) } else { # numeric outcome message( sprintf("Data frame with %d %s%swith average prediction: %s", length(f), ngettext(length(fc), "prediction", "predictions"), if (!is.null(attr(x, "call"))) sprintf(" from\n %s\n", paste0(deparse(attr(x, "call")), collapse = "\n")) else "", sprintf(paste0("%0.", digits, "f"), mean(f, na.rm = TRUE)) ) ) } } else { # otherwise, object has an 'at' specification, reflecting multiple requested predictions # convert 'at_specification' into data frame xby <- x[ , setdiff(names(at), "index"), drop = FALSE] if ("fitted.class" %in% names(x) || is.list(fc)) { # factor outcome out <- aggregate(x[["fitted.class"]], xby, FUN = function(set) names(sort(table(set), decreasing = TRUE))[1L]) message( sprintf("Data frame with %d %s%swith modal %s (of %d %s):", nrow(x), ngettext(nrow(x), "prediction", "predictions"), if (!is.null(attr(x, "call"))) sprintf(" from\n %s\n", paste0(deparse(attr(x, "call")), collapse = "\n")) else "", ngettext(nrow(out), "prediction", "predictions"), nlevels(factor(fc)), ngettext(nlevels(fc), "level", "levels") ) ) } else { # numeric outcome out <- aggregate(x[["fitted"]], xby, FUN = mean, na.rm = TRUE) message( sprintf("Data frame with %d %s%swith average %s:", nrow(x), ngettext(nrow(x), "prediction", "predictions"), if (!is.null(attr(x, "call"))) sprintf(" from\n %s\n", paste0(deparse(attr(x, "call")), collapse = "\n")) else "", ngettext(nrow(out), "prediction", "predictions") ) ) } print(out, digits = digits, row.names = FALSE, ...) } # return invisibly invisible(x) } prediction/R/prediction_glimQL.R0000644000176200001440000000376413501406664016362 0ustar liggesusers#' @rdname prediction #' @export prediction.glimQL <- function(model, data = find_data(model, parent.frame()), at = NULL, type = c("response", "link"), calculate_se = TRUE, ...) { requireNamespace("aod") type <- match.arg(type) # extract predicted values data <- data if (missing(data) || is.null(data)) { if (isTRUE(calculate_se)) { pred <- aod::predict(model, type = type, se.fit = TRUE, ...) pred <- make_data_frame(fitted = pred[["fit"]], se.fitted = pred[["se.fit"]]) } else { pred <- aod::predict(model, type = type, se.fit = FALSE, ...) pred <- make_data_frame(fitted = pred, se.fitted = rep(NA_real_, length(pred))) } } else { # setup data data <- build_datalist(data, at = at, as.data.frame = TRUE) at_specification <- attr(data, "at_specification") # calculate predictions if (isTRUE(calculate_se)) { tmp <- aod::predict(model, newdata = data, type = type, se.fit = TRUE, ...) # cbind back together pred <- make_data_frame(data, fitted = tmp[["fit"]], se.fitted = tmp[["se.fit"]]) } else { tmp <- aod::predict(model, newdata = data, type = type, se.fit = FALSE, ...) # cbind back together pred <- make_data_frame(data, fitted = tmp, se.fitted = rep(NA_real_, nrow(data))) } } # variance(s) of average predictions vc <- NA_real_ # output structure(pred, class = c("prediction", "data.frame"), at = if (is.null(at)) at else at_specification, type = type, call = if ("call" %in% names(model)) model[["call"]] else NULL, model_class = class(model), row.names = seq_len(nrow(pred)), vcov = vc, jacobian = NULL, weighted = FALSE) } prediction/R/prediction_lme.R0000644000176200001440000000247613501406664015751 0ustar liggesusers#' @rdname prediction #' @export prediction.lme <- function(model, data = find_data(model), at = NULL, calculate_se = FALSE, ...) { # extract predicted values data <- data if (missing(data) || is.null(data)) { pred <- make_data_frame(fitted = predict(model, ...)) } else { # setup data if (is.null(at)) { out <- data } else { out <- build_datalist(data, at = at, as.data.frame = TRUE) at_specification <- attr(out, "at_specification") } # calculate predictions tmp <- predict(model, newdata = out, ...) # cbind back together pred <- make_data_frame(out, fitted = tmp, se.fitted = rep(NA_real_, nrow(out))) } # variance(s) of average predictions vc <- NA_real_ # output structure(pred, class = c("prediction", "data.frame"), at = if (is.null(at)) at else at_specification, type = NA_character_, call = if ("call" %in% names(model)) model[["call"]] else NULL, model_class = class(model), row.names = seq_len(nrow(pred)), vcov = vc, jacobian = NULL, weighted = FALSE) } prediction/R/prediction_clm.R0000644000176200001440000000671013501406664015742 0ustar liggesusers#' @rdname prediction #' @export prediction.clm <- function(model, data = find_data(model, parent.frame()), at = NULL, type = NULL, calculate_se = TRUE, category, ...) { if (!is.null(type)) { warning(sprintf("'type' is ignored for models of class '%s'", class(model))) } # extract predicted values data <- data if (missing(data) || is.null(data)) { pred <- make_data_frame(fitted.class = predict(model, type = "class", se.fit = FALSE, ...)[["fit"]]) if (isTRUE(calculate_se)) { problist <- predict(model, newdata = data, type = "prob", se.fit = TRUE, ...) probs <- make_data_frame(problist[["fit"]]) probs.se <- make_data_frame(problist[["se.fit"]]) names(probs) <- paste0("Pr(", seq_len(ncol(probs)), ")") names(probs.se) <- paste0("se.Pr(", seq_len(ncol(probs)), ")") pred <- make_data_frame(pred, probs, probs.se) } else { problist <- predict(model, newdata = data, type = "prob", se.fit = FALSE, ...) probs <- make_data_frame(problist[["fit"]]) names(probs) <- paste0("Pr(", seq_len(ncol(probs)), ")") pred <- make_data_frame(pred, probs) } } else { # setup data if (is.null(at)) { out <- data } else { out <- build_datalist(data, at = at, as.data.frame = TRUE) at_specification <- attr(out, "at_specification") } # calculate predictions pred <- predict(model, newdata = out, type = "class", se.fit = FALSE, ...)[["fit"]] if (isTRUE(calculate_se)) { problist <- predict(model, newdata = out, type = "prob", se.fit = TRUE, ...) probs <- make_data_frame(problist[["fit"]]) probs.se <- make_data_frame(problist[["se.fit"]]) names(probs) <- paste0("Pr(", seq_len(ncol(probs)), ")") names(probs.se) <- paste0("se.Pr(", seq_len(ncol(probs)), ")") pred <- make_data_frame(out, fitted.class = pred, probs, probs.se) } else { problist <- predict(model, newdata = out, type = "prob", se.fit = FALSE, ...) probs <- make_data_frame(problist[["fit"]]) names(probs) <- paste0("Pr(", seq_len(ncol(probs)), ")") pred <- make_data_frame(out, fitted.class = pred, probs) } } # handle category argument if (missing(category)) { w <- grep("^Pr\\(", names(pred))[1L] category <- names(pred)[w] pred[["fitted"]] <- pred[[w]] } else { w <- which(names(pred) == paste0("Pr(", category, ")")) if (!length(w)) { stop(sprintf("category %s not found", category)) } pred[["fitted"]] <- pred[[ w[1L] ]] } pred[["se.fitted"]] <- NA_real_ # variance(s) of average predictions vc <- NA_real_ # output structure(pred, class = c("prediction", "data.frame"), at = if (is.null(at)) at else at_specification, type = NA_character_, call = if ("call" %in% names(model)) model[["call"]] else NULL, model_class = class(model), row.names = seq_len(nrow(pred)), vcov = vc, jacobian = NULL, category = category, weighted = FALSE) } prediction/R/mean_or_mode.R0000644000176200001440000000342013501406664015366 0ustar liggesusers#' @rdname mean_or_mode #' @title Class-dependent variable aggregation #' @description Summarize a vector/variable into a single number, either a mean (median) for numeric vectors or the mode for categorical (character, factor, ordered, or logical) vectors. Useful for aggregation. #' @param x A vector. #' @return A numeric or factor vector of length 1. #' @examples #' require("datasets") #' # mean for numerics #' mean_or_mode(iris) #' mean_or_mode(iris[["Sepal.Length"]]) #' mean_or_mode(iris[["Species"]]) #' #' # median for numerics #' median_or_mode(iris) #' #' @seealso \code{\link{prediction}}, \code{\link{build_datalist}}, \code{\link{seq_range}} #' @import stats #' @export mean_or_mode <- function(x) { UseMethod("mean_or_mode") } #' @rdname mean_or_mode #' @export mean_or_mode.default <- function(x) { if (!is.factor(x)) { x <- as.factor(x) } factor(names(sort(table(x), decreasing = TRUE))[1L], levels = levels(x)) } #' @rdname mean_or_mode #' @export mean_or_mode.numeric <- function(x) { mean(x, na.rm = TRUE) } #' @rdname mean_or_mode #' @export mean_or_mode.data.frame <- function(x) { setNames(lapply(x, mean_or_mode), names(x)) } #' @rdname mean_or_mode #' @export median_or_mode <- function(x) { UseMethod("median_or_mode") } #' @rdname mean_or_mode #' @export median_or_mode.default <- function(x) { if (!is.factor(x)) { x <- as.factor(x) } factor(names(sort(table(x), decreasing = TRUE))[1L], levels = levels(x)) } #' @rdname mean_or_mode #' @export median_or_mode.numeric <- function(x) { median(x, na.rm = TRUE) } #' @rdname mean_or_mode #' @export median_or_mode.data.frame <- function(x) { setNames(lapply(x, median_or_mode), names(x)) } prediction/R/prediction_knnreg.R0000644000176200001440000000223513501406664016451 0ustar liggesusers#' @rdname prediction #' @export prediction.knnreg <- function(model, data, at = NULL, calculate_se = FALSE, ...) { # extract predicted values if (missing(data) || is.null(data)) { pred <- make_data_frame(fitted = predict(object = model, ...)[,1L]) } else { # setup data if (is.null(at)) { out <- data } else { out <- build_datalist(data, at = at, as.data.frame = TRUE) at_specification <- attr(out, "at_specification") } pred <- make_data_frame(fitted = predict(model, newdata = data, ...)) } pred[["se.fitted"]] <- NA_real_ # variance(s) of average predictions vc <- NA_real_ # output structure(pred, class = c("prediction", "data.frame"), at = if (is.null(at)) at else at_specification, type = NA_character_, call = if ("call" %in% names(model)) model[["call"]] else NULL, model_class = class(model), row.names = seq_len(nrow(pred)), vcov = vc, jacobian = NULL, weighted = FALSE) } prediction/R/prediction.R0000644000176200001440000002355013501406664015110 0ustar liggesusers#' @rdname prediction #' @name prediction-package #' @title Extract Predictions from a Model Object #' @description Extract predicted values via \code{\link[stats]{predict}} from a model object, conditional on data, and return a data frame. #' @param model A model object, perhaps returned by \code{\link[stats]{lm}} or \code{\link[stats]{glm}}. #' @param data A data.frame over which to calculate marginal effects. If missing, \code{\link{find_data}} is used to specify the data frame. #' @param at A list of one or more named vectors, specifically values at which to calculate the predictions. These are used to modify the value of \code{data} (see \code{\link{build_datalist}} for details on use). #' @param type A character string indicating the type of marginal effects to estimate. Mostly relevant for non-linear models, where the reasonable options are \dQuote{response} (the default) or \dQuote{link} (i.e., on the scale of the linear predictor in a GLM). For models of class \dQuote{polr} (from \code{\link[MASS]{polr}}), possible values are \dQuote{class} or \dQuote{probs}; both are returned. #' @param vcov A matrix containing the variance-covariance matrix for estimated model coefficients, or a function to perform the estimation with \code{model} as its only argument. #' @param calculate_se A logical indicating whether to calculate standard errors for observation-specific predictions and average predictions (if possible). The output will always contain a \dQuote{calculate_se} column regardless of this value; this only controls the calculation of standard errors. Setting it to \code{FALSE} may improve speed. #' @param category For multi-level or multi-category outcome models (e.g., ordered probit, multinomial logit, etc.), a value specifying which of the outcome levels should be used for the \code{"fitted"} column. If missing, some default is chosen automatically. #' @param \dots Additional arguments passed to \code{\link[stats]{predict}} methods. #' @details This function is simply a wrapper around \code{\link[stats]{predict}} that returns a data frame containing the value of \code{data} and the predicted values with respect to all variables specified in \code{data}. #' #' Methods are currently implemented for the following object classes: #' \itemize{ #' \item \dQuote{lm}, see \code{\link[stats]{lm}} #' \item \dQuote{glm}, see \code{\link[stats]{glm}}, \code{\link[MASS]{glm.nb}}, \code{\link[glmx]{glmx}}, \code{\link[glmx]{hetglm}}, \code{\link[brglm]{brglm}} #' \item \dQuote{ar}, see \code{\link[stats]{ar}} #' \item \dQuote{Arima}, see \code{\link[stats]{arima}} #' \item \dQuote{arima0}, see \code{\link[stats]{arima0}} #' \item \dQuote{bigglm}, see \code{\link[biglm]{bigglm}} (including \dQuote{ffdf}-backed models provided by \code{\link[ffbase]{bigglm.ffdf}}) #' \item \dQuote{betareg}, see \code{\link[betareg]{betareg}} #' \item \dQuote{bruto}, see \code{\link[mda]{bruto}} #' \item \dQuote{clm}, see \code{\link[ordinal]{clm}} #' \item \dQuote{coxph}, see \code{\link[survival]{coxph}} #' \item \dQuote{crch}, see \code{\link[crch]{crch}} #' \item \dQuote{earth}, see \code{\link[earth]{earth}} #' \item \dQuote{fda}, see \code{\link[mda]{fda}} #' \item \dQuote{Gam}, see \code{\link[gam]{gam}} #' \item \dQuote{gausspr}, see \code{\link[kernlab]{gausspr}} #' \item \dQuote{gee}, see \code{\link[gee]{gee}} #' \item \dQuote{glmnet}, see \code{\link[glmnet]{glmnet}} #' \item \dQuote{gls}, see \code{\link[nlme]{gls}} #' \item \dQuote{glimML}, see \code{\link[aod]{betabin}}, \code{\link[aod]{negbin}} #' \item \dQuote{glimQL}, see \code{\link[aod]{quasibin}}, \code{\link[aod]{quasipois}} #' \item \dQuote{hurdle}, see \code{\link[pscl]{hurdle}} #' \item \dQuote{hxlr}, see \code{\link[crch]{hxlr}} #' \item \dQuote{ivreg}, see \code{\link[AER]{ivreg}} #' \item \dQuote{knnreg}, see \code{\link[caret]{knnreg}} #' \item \dQuote{kqr}, see \code{\link[kernlab]{kqr}} #' \item \dQuote{ksvm}, see \code{\link[kernlab]{ksvm}} #' \item \dQuote{lda}, see \code{\link[MASS]{lda}} #' \item \dQuote{lme}, see \code{\link[nlme]{lme}} #' \item \dQuote{loess}, see \code{\link[stats]{loess}} #' \item \dQuote{lqs}, see \code{\link[MASS]{lqs}} #' \item \dQuote{mars}, see \code{\link[mda]{mars}} #' \item \dQuote{mca}, see \code{\link[MASS]{mca}} #' \item \dQuote{mclogit}, see \code{\link[mclogit]{mclogit}} #' \item \dQuote{mda}, see \code{\link[mda]{mda}} #' \item \dQuote{merMod}, see \code{\link[lme4]{lmer}}, \code{\link[lme4]{glmer}} #' \item \dQuote{mnp}, see \code{\link[MNP]{mnp}} #' \item \dQuote{naiveBayes}, see \code{\link[e1071]{naiveBayes}} #' \item \dQuote{nlme}, see \code{\link[nlme]{nlme}} #' \item \dQuote{nls}, see \code{\link[stats]{nls}} #' \item \dQuote{nnet}, see \code{\link[nnet]{nnet}} #' \item \dQuote{plm}, see \code{\link[plm]{plm}} #' \item \dQuote{polr}, see \code{\link[MASS]{polr}} #' \item \dQuote{polyreg}, see \code{\link[mda]{polyreg}} #' \item \dQuote{ppr}, see \code{\link[stats]{ppr}} #' \item \dQuote{princomp}, see \code{\link[stats]{princomp}} #' \item \dQuote{qda}, see \code{\link[MASS]{qda}} #' \item \dQuote{rlm}, see \code{\link[MASS]{rlm}} #' \item \dQuote{rpart}, see \code{\link[rpart]{rpart}} #' \item \dQuote{rq}, see \code{\link[quantreg]{rq}} #' \item \dQuote{selection}, see \code{\link[sampleSelection]{selection}} #' \item \dQuote{speedglm}, see \code{\link[speedglm]{speedglm}} #' \item \dQuote{speedlm}, see \code{\link[speedglm]{speedlm}} #' \item \dQuote{survreg}, see \code{\link[survival]{survreg}} #' \item \dQuote{svm}, see \code{\link[e1071]{svm}} #' \item \dQuote{svyglm}, see \code{\link[survey]{svyglm}} #' \item \dQuote{tobit}, see \code{\link[AER]{tobit}} #' \item \dQuote{train}, see \code{\link[caret]{train}} #' \item \dQuote{truncreg}, see \code{\link[truncreg]{truncreg}} #' \item \dQuote{zeroinfl}, see \code{\link[pscl]{zeroinfl}} #' } #' #' Where implemented, \code{prediction} also returns average predictions (and the variances thereof). Variances are implemented using the delta method, as described in \url{http://indiana.edu/~jslsoc/stata/ci_computations/spost_deltaci.pdf}. #' #' @return A data frame with class \dQuote{prediction} that has a number of rows equal to number of rows in \code{data}, or a multiple thereof, if \code{!is.null(at)}. The return value contains \code{data} (possibly modified by \code{at} using \code{\link{build_datalist}}), plus a column containing fitted/predicted values (\code{"fitted"}) and a column containing the standard errors thereof (\code{"calculate_se"}). Additional columns may be reported depending on the object class. The data frame also carries attributes used by \code{print} and \code{summary}, which will be lost during subsetting. #' @examples #' require("datasets") #' x <- lm(Petal.Width ~ Sepal.Length * Sepal.Width * Species, data = iris) #' # prediction for every case #' prediction(x) #' #' # prediction for first case #' prediction(x, iris[1,]) #' #' # basic use of 'at' argument #' summary(prediction(x, at = list(Species = c("setosa", "virginica")))) #' #' # basic use of 'at' argument #' prediction(x, at = list(Sepal.Length = seq_range(iris$Sepal.Length, 5))) #' #' # prediction at means/modes of input variables #' prediction(x, at = lapply(iris, mean_or_mode)) #' #' # prediction with multi-category outcome #' \dontrun{ #' library("mlogit") #' data("Fishing", package = "mlogit") #' Fish <- mlogit.data(Fishing, varying = c(2:9), shape = "wide", choice = "mode") #' mod <- mlogit(mode ~ price + catch, data = Fish) #' prediction(mod) #' prediction(mod, category = 3) #' } #' #' @keywords models #' @seealso \code{\link{find_data}}, \code{\link{build_datalist}}, \code{\link{mean_or_mode}}, \code{\link{seq_range}} #' @import stats #' @export prediction <- function(model, ...) { UseMethod("prediction") } #' @rdname prediction #' @export prediction.default <- function(model, data = find_data(model, parent.frame()), at = NULL, type = "response", vcov = stats::vcov(model), calculate_se = TRUE, ...) { # extract predicted values data <- data if (missing(data) || is.null(data)) { if (isTRUE(calculate_se)) { pred <- predict(model, type = type, se.fit = TRUE, ...) pred <- make_data_frame(fitted = pred[["fit"]], se.fitted = pred[["se.fit"]]) } else { pred <- predict(model, type = type, se.fit = FALSE, ...) pred <- make_data_frame(fitted = pred, se.fitted = rep(NA_real_, length(pred))) } } else { # setup data if (!is.null(at)) { data <- build_datalist(data, at = at, as.data.frame = TRUE) at_specification <- attr(data, "at_specification") } # calculate predictions if (isTRUE(calculate_se)) { tmp <- predict(model, newdata = data, type = type, se.fit = TRUE, ...) # cbind back together pred <- make_data_frame(data, fitted = tmp[["fit"]], se.fitted = tmp[["se.fit"]]) } else { tmp <- predict(model, newdata = data, type = type, se.fit = FALSE, ...) # cbind back together pred <- make_data_frame(data, fitted = tmp, se.fitted = rep(NA_real_, nrow(data))) } } # variance(s) of average predictions J <- NULL vc <- NA_real_ # output structure(pred, class = c("prediction", "data.frame"), at = if (is.null(at)) at else at_specification, type = type, call = if ("call" %in% names(model)) model[["call"]] else NULL, model_class = class(model), row.names = seq_len(nrow(pred)), vcov = vc, jacobian = J, weighted = FALSE) } prediction/R/prediction_princomp.R0000644000176200001440000000254013501406664017013 0ustar liggesusers#' @rdname prediction #' @export prediction.princomp <- function(model, data = find_data(model, parent.frame()), at = NULL, calculate_se = FALSE, ...) { # extract predicted values data <- data if (missing(data) || is.null(data)) { pred <- make_data_frame(predict(model, ...)) } else { # setup data if (is.null(at)) { out <- data } else { out <- build_datalist(data, at = at, as.data.frame = TRUE) at_specification <- attr(out, "at_specification") } # calculate predictions tmp <- predict(model, newdata = out, ...) # cbind back together pred <- make_data_frame(out, tmp, fitted = rep(NA_real_, nrow(out)), se.fitted = rep(NA_real_, nrow(out))) } # variance(s) of average predictions vc <- NA_real_ # output structure(pred, class = c("prediction", "data.frame"), at = if (is.null(at)) at else at_specification, type = NA_character_, call = if ("call" %in% names(model)) model[["call"]] else NULL, model_class = class(model), row.names = seq_len(nrow(pred)), vcov = vc, jacobian = NULL, weighted = FALSE) } prediction/R/build_datalist.R0000644000176200001440000001306513331141552015725 0ustar liggesusers#' @title Build list of data.frames #' @description Construct a list of data.frames based upon an input data.frame and a list of one or more \code{at} values #' @param data A data.frame containing the original data. #' @param at A list of one or more named vectors of values, which will be used to specify values of variables in \code{data}. All possible combinations are generated. Alternatively, this can be a data frame of combination levels if only a subset of combinations are desired. See examples. #' @param as.data.frame A logical indicating whether to return a single stacked data frame rather than a list of data frames #' @param \dots Ignored. #' @return A list of data.frames, unless \code{as.data.frame = TRUE} in which case a single, stacked data frame is returned. #' @author Thomas J. Leeper #' @examples #' # basic examples #' require("datasets") #' build_datalist(head(mtcars), at = list(cyl = c(4, 6))) #' #' str(build_datalist(head(mtcars), at = list(cyl = c(4,6), wt = c(2.75,3,3.25))), 1) #' #' str(build_datalist(head(mtcars), at = data.frame(cyl = c(4,4), wt = c(2.75,3)))) #' #' @keywords data manip #' @seealso \code{\link{find_data}}, \code{\link{mean_or_mode}}, \code{\link{seq_range}} #' @importFrom data.table rbindlist #' @export build_datalist <- function(data, at = NULL, as.data.frame = FALSE, ...){ # check for `at` specification and `as.data.frame` arguments if (!is.null(at) && length(at) > 0) { # check `at` specification against data check_at(data, at) # setup list of data.frames based on at data_out <- set_data_to_at(data, at = at) at_specification <- cbind(index = seq_len(nrow(data_out[["at"]])), data_out[["at"]]) data_out <- data_out[["data"]] if (isTRUE(as.data.frame)) { data_out <- data.table::rbindlist(data_out) } } else if (isTRUE(as.data.frame)) { # if `at` empty and `as.data.frame = TRUE`, simply return original data data_out <- data at_specification <- NULL } else { # if `at` empty, simply setup data.frame and return data_out <- list(data) at_specification <- NULL } return(structure(data_out, at_specification = at_specification)) } check_at <- function(data, at) { # check names of `at` check_at_names(names(data), at) # check factor levels specified in `at` check_factor_levels(data, at) # check values of numeric values are interpolations check_values(data, at) } check_factor_levels <- function(data, at) { # function to check whether factor levels in `at` are reasonable levels <- lapply(data, function(v) { if (is.factor(v)) { levels(v) } else if (is.character(v)) { levels(factor(v)) } else { NULL } }) levels <- levels[!sapply(levels, is.null)] at <- at[names(at) %in% names(levels)] for (i in seq_along(at)) { atvals <- as.character(at[[i]]) x <- atvals %in% levels[[names(at)[i]]] if (!all(x)) { stop(paste0("Illegal factor levels for variable '", names(at)[i], "': ", paste0(shQuote(atvals[!x]), collapse = ", ")), call. = FALSE) } } invisible(NULL) } check_values <- function(data, at) { # drop variables not in `at` dat <- data[, names(at), drop = FALSE] # drop non-numeric variables from `dat` and `at` not_numeric <- !sapply(dat, class) %in% c("character", "factor", "ordered", "logical") at <- at[names(at) %in% names(dat)[not_numeric]] dat <- dat[, not_numeric, drop = FALSE] if (length(dat) > 0 & length(at) > 0) { # calculate variable ranges limits <- do.call(rbind, lapply(dat, range, na.rm = TRUE)) rownames(limits) <- names(dat) # check ranges for (i in seq_along(at)) { out <- (at[[i]] < limits[names(at)[i],1]) | (at[[i]] > limits[names(at)[i],2]) if (any( out ) ) { datarange <- paste0("outside observed data range (", limits[names(at)[i],1], ",", limits[names(at)[i],2], ")!") warning(ngettext(sum(out), paste0("A 'at' value for '", names(at)[i], "' is ", datarange), paste0("Some 'at' values for '", names(at)[i], "' are ", datarange))) } } } } check_at_names <- function(namevec, at) { if (is.null(namevec)) { return() } if (is.null(names(at)) || any(names(at) == "")) { stop("'at' contains unnamed list elements") } b <- !names(at) %in% namevec if (any(b)) { e <- ngettext(sum(b), "Unrecognized variable name in 'at': ", "Unrecognized variable names in 'at': ") stop(paste0(e, paste0("(", which(b), ") ", gsub("", "", names(at)[b]), collapse = ", "))) } } # data.frame builder, given specified `at` values ## returns the `at` combination as a data frame set_data_to_at <- function(data, at = NULL) { # expand `at` combinations if (inherits(at, "data.frame")) { expanded <- at } else { expanded <- expand.grid(at, KEEP.OUT.ATTRS = FALSE) } e <- split(expanded, unique(expanded)) data_out <- lapply(e, function(atvals) { dat <- data dat <- `[<-`(dat, , names(atvals), value = atvals) structure(dat, at = as.list(atvals)) }) return(list(data = data_out, at = expanded)) } prediction/R/prediction_ar.R0000644000176200001440000000330313501406664015564 0ustar liggesusers#' @rdname prediction #' @export prediction.ar <- function(model, data, at = NULL, calculate_se = TRUE,...) { # extract predicted values if (missing(data) || is.null(data)) { if (isTRUE(calculate_se)) { tmp <- predict(object = model, se.fit = TRUE, ...) pred <- make_data_frame(fitted = tmp[[1L]], se.fitted = tmp[[2L]]) } else { tmp <- predict(object = model, se.fit = FALSE, ...) pred <- make_data_frame(fitted = tmp, se.fitted = rep(NA_real_, length(tmp))) } } else { # setup data if (is.null(at)) { data <- data } else { data <- build_datalist(data, at = at, as.data.frame = TRUE) at_specification <- attr(data, "at_specification") } if (isTRUE(calculate_se)) { tmp <- predict(model, newdata = data, se.fit = TRUE, ...) pred <- make_data_frame(fitted = tmp[[1L]], se.fitted = tmp[[2L]]) } else { tmp <- predict(model, newdata = data, se.fit = FALSE, ...) pred <- make_data_frame(fitted = tmp, se.fitted = rep(NA_real_, length(tmp))) } } # variance(s) of average predictions vc <- NA_real_ # output structure(pred, class = c("prediction", "data.frame"), at = if (is.null(at)) at else at_specification, type = NA_character_, call = if ("call" %in% names(model)) model[["call"]] else NULL, model_class = class(model), row.names = seq_len(nrow(pred)), vcov = vc, jacobian = NULL, weighted = FALSE) } prediction/R/prediction_gam.R0000644000176200001440000000374013501406664015733 0ustar liggesusers#' @rdname prediction #' @export prediction.Gam <- function(model, data = find_data(model, parent.frame()), at = NULL, type = c("response", "link", "terms"), calculate_se = TRUE, ...) { type <- match.arg(type) # extract predicted value data <- data if (missing(data) || is.null(data)) { if (isTRUE(calculate_se)) { pred <- predict(model, type = type, se.fit = TRUE, ...) pred <- make_data_frame(fitted = pred[["fit"]], se.fitted = pred[["se.fit"]][,1L]) } else { pred <- predict(model, type = type, se.fit = FALSE, ...) pred <- make_data_frame(fitted = pred, se.fitted = rep(NA_real_, length(pred))) } } else { # setup data if (is.null(at)) { out <- data } else { out <- build_datalist(data, at = at, as.data.frame = TRUE) at_specification <- attr(out, "at_specification") } # calculate predictions if (isTRUE(calculate_se)) { pred <- predict(model, newdata = out, type = type, se.fit = FALSE, ...) pred <- make_data_frame(out, fitted = pred, se.fitted = rep(NA_real_, length(pred))) } else { pred <- predict(model, newdata = out, type = type, se.fit = FALSE, ...) pred <- make_data_frame(out, fitted = pred, se.fitted = rep(NA_real_, length(pred))) } } # variance(s) of average predictions vc <- NA_real_ # output structure(pred, class = c("prediction", "data.frame"), at = if (is.null(at)) at else at_specification, type = type, call = if ("call" %in% names(model)) model[["call"]] else NULL, model_class = class(model), row.names = seq_len(nrow(pred)), vcov = vc, jacobian = NULL, weighted = FALSE) } prediction/R/find_data.R0000644000176200001440000001041713501406664014657 0ustar liggesusers#' @rdname find_data #' @title Extract data from a model object #' @description Attempt to reconstruct the data used to create a model object #' @param model The model object. #' @param \dots Additional arguments passed to methods. #' @param env An environment in which to look for the \code{data} argument to the modelling call. #' @details This is a convenience function and, as such, carries no guarantees. To behave well, it typically requires that a model object be specified using a formula interface and an explicit \code{data} argument. Models that can be specified using variables from the \code{.GlobalEnv} or with a non-formula interface (e.g., a matrix of data) will tend to generate errors. \code{find_data} is an S3 generic so it is possible to expand it with new methods. #' @return A data frame containing the original data used in a modelling call, modified according to the original model's `subset` and `na.action` arguments, if appropriate. #' @examples #' require("datasets") #' x <- lm(mpg ~ cyl * hp + wt, data = head(mtcars)) #' find_data(x) #' #' @seealso \code{\link{prediction}}, \code{\link{build_datalist}}, \code{\link{mean_or_mode}}, \code{\link{seq_range}} #' @export find_data <- function(model, ...) { UseMethod("find_data") } #' @rdname find_data #' @importFrom stats terms #' @export find_data.default <- function(model, env = parent.frame(), ...) { form <- try(terms(model), silent = TRUE) if (inherits(form, "try-error") && is.null(model[["call"]])) { stop("'find_data()' requires a formula call") } else { if (!is.null(model[["call"]][["data"]])) { dat <- eval(model[["call"]][["data"]], env) if (inherits(dat, "try-error")) { dat <- get_all_vars(model, data = model[["call"]][["data"]]) } } else { dat <- get_all_vars(model, data = env) } # handle subset if (!is.null(model[["call"]][["subset"]])) { subs <- try(eval(model[["call"]][["subset"]], dat), silent = TRUE) if (inherits(subs, "try-error")) { subs <- try(eval(model[["call"]][["subset"]], env), silent = TRUE) if (inherits(subs, "try-error")) { subs <- TRUE warning("'find_data()' cannot locate variable(s) used in 'subset'") } } dat <- dat[subs, , drop = FALSE] } # handle na.action if (!is.null(model[["na.action"]])) { dat <- dat[-model[["na.action"]], , drop = FALSE] } } if (is.null(dat)) { stop("'find_data()' requires a formula call") } dat } #' @rdname find_data #' @export find_data.data.frame <- function(model, ...) { model } #' @rdname find_data #' @export find_data.crch <- find_data.default #' @rdname find_data #' @export find_data.glimML <- function(model, ...) { requireNamespace("methods", quietly = TRUE) methods::slot(model, "data") } find_data.glimQL <- function(model, env = parent.frame(), ...) { requireNamespace("methods", quietly = TRUE) methods::slot(model, "fm")$data } #' @rdname find_data #' @export find_data.glm <- find_data.default #' @rdname find_data #' @export find_data.hxlr <- find_data.default #' @rdname find_data #' @export find_data.lm <- find_data.default #' @rdname find_data #' @export find_data.mca <- function(model, env = parent.frame(), ...) { eval(model[["call"]][["df"]], envir = env) } #' @rdname find_data #' @importFrom stats model.frame #' @export find_data.merMod <- function(model, env = parent.frame(), ...) { model.frame(model) } #' @rdname find_data #' @export find_data.svyglm <- function(model, ...) { data <- model[["data"]] data } #' @rdname find_data #' @export find_data.train <- function(model, ...) { model[["trainingData"]] } #' @rdname find_data #' @export find_data.vgam <- function(model, env = parent.frame(), ...) { if (!requireNamespace("methods")) { stop("'find_data.vgam()' requires the 'methods' package") } dat <- methods::slot(model, "misc")[["dataname"]] get(dat, envir = env) } #' @rdname find_data #' @export find_data.vglm <- find_data.vgam prediction/R/prediction_mclogit.R0000644000176200001440000000011513501406664016616 0ustar liggesusers#' @rdname prediction #' @export prediction.mclogit <- prediction.default prediction/R/prediction_fda.R0000644000176200001440000000454013501406664015720 0ustar liggesusers#' @rdname prediction #' @export prediction.fda <- function(model, data = find_data(model, parent.frame()), at = NULL, type = NULL, calculate_se = FALSE, category, ...) { if (!is.null(type)) { warning(sprintf("'type' is ignored for models of class '%s'", class(model))) } # extract predicted values data <- data if (missing(data) || is.null(data)) { pred <- make_data_frame(fitted.class = predict(model, type = "class", ...)) probs <- make_data_frame(predict(model, type = "posterior", ...)) names(probs) <- paste0("Pr(", names(probs), ")") pred <- make_data_frame(pred, probs) } else { # setup data if (is.null(at)) { out <- data } else { out <- build_datalist(data, at = at, as.data.frame = TRUE) at_specification <- attr(out, "at_specification") } # calculate predictions tmp <- predict(model, newdata = out, type = "class", ...) tmp_probs <- make_data_frame(predict(model, newdata = out, type = "posterior", ...)) names(tmp_probs) <- paste0("Pr(", names(tmp_probs), ")") # cbind back together pred <- make_data_frame(out, fitted.class = tmp, se.fitted = rep(NA_real_, nrow(out)), tmp_probs) rm(tmp, tmp_probs) } # handle category argument if (missing(category)) { w <- grep("^Pr\\(", names(pred))[1L] category <- names(pred)[w] pred[["fitted"]] <- pred[[w]] } else { w <- which(names(pred) == paste0("Pr(", category, ")")) if (!length(w)) { stop(sprintf("category %s not found", category)) } pred[["fitted"]] <- pred[[ w[1L] ]] } # variance(s) of average predictions vc <- NA_real_ # output structure(pred, class = c("prediction", "data.frame"), at = if (is.null(at)) at else at_specification, type = NA_character_, call = if ("call" %in% names(model)) model[["call"]] else NULL, model_class = class(model), row.names = seq_len(nrow(pred)), vcov = vc, jacobian = NULL, category = category, weighted = FALSE) } prediction/R/prediction_rpart.R0000644000176200001440000000452713501406664016323 0ustar liggesusers#' @rdname prediction #' @export prediction.rpart <- function(model, data = find_data(model, parent.frame()), at = NULL, type = NULL, calculate_se = FALSE, category, ...) { if (!is.null(type)) { warning(sprintf("'type' is ignored for models of class '%s'", class(model))) } # extract predicted values data <- data if (missing(data) || is.null(data)) { pred <- make_data_frame(fitted.class = predict(model, type = "class", ...)) probs <- make_data_frame(predict(model, type = "prob", ...)) names(probs) <- paste0("Pr(", names(probs), ")") pred <- make_data_frame(pred, probs) } else { # setup data if (is.null(at)) { out <- data } else { out <- build_datalist(data, at = at, as.data.frame = TRUE) at_specification <- attr(out, "at_specification") } # calculate predictions tmp <- predict(model, newdata = out, type = "class", ...) tmp_probs <- make_data_frame(predict(model, newdata = out, type = "prob", ...)) names(tmp_probs) <- paste0("Pr(", names(tmp_probs), ")") # cbind back together pred <- make_data_frame(out, fitted.class = tmp, tmp_probs) rm(tmp, tmp_probs) } # handle category argument if (missing(category)) { w <- grep("^Pr\\(", names(pred))[1L] category <- names(pred)[w] pred[["fitted"]] <- pred[[w]] } else { w <- which(names(pred) == paste0("Pr(", category, ")")) if (!length(w)) { stop(sprintf("category %s not found", category)) } pred[["fitted"]] <- pred[[ w[1L] ]] } pred[["se.fitted"]] <- NA_real_ # variance(s) of average predictions vc <- NA_real_ # output structure(pred, class = c("prediction", "data.frame"), at = if (is.null(at)) at else at_specification, type = NA_character_, call = if ("call" %in% names(model)) model[["call"]] else NULL, model_class = class(model), row.names = seq_len(nrow(pred)), vcov = vc, jacobian = NULL, category = category, weighted = FALSE) } prediction/R/prediction_nnet.R0000644000176200001440000000452513501406664016135 0ustar liggesusers#' @rdname prediction #' @export prediction.nnet <- function(model, data = find_data(model, parent.frame()), at = NULL, type = NULL, calculate_se = FALSE, category, ...) { if (!is.null(type)) { warning(sprintf("'type' is ignored for models of class '%s'", class(model))) } # extract predicted values data <- data if (missing(data) || is.null(data)) { pred <- make_data_frame(fitted.class = predict(model, type = "class", ...)) probs <- make_data_frame(predict(model, type = "raw", ...)) names(probs) <- paste0("Pr(", names(probs), ")") pred <- make_data_frame(pred, probs) } else { # setup data if (is.null(at)) { out <- data } else { out <- build_datalist(data, at = at, as.data.frame = TRUE) at_specification <- attr(out, "at_specification") } # calculate predictions tmp <- predict(model, newdata = out, type = "class", ...) tmp_probs <- make_data_frame(predict(model, newdata = out, type = "raw", ...)) names(tmp_probs) <- paste0("Pr(", names(tmp_probs), ")") # cbind back together pred <- make_data_frame(out, fitted.class = tmp, se.fitted = rep(NA_real_, nrow(out)), tmp_probs) rm(tmp, tmp_probs) } # handle category argument if (missing(category)) { w <- grep("^Pr\\(", names(pred))[1L] category <- names(pred)[w] pred[["fitted"]] <- pred[[w]] } else { w <- which(names(pred) == paste0("Pr(", category, ")")) if (!length(w)) { stop(sprintf("category %s not found", category)) } pred[["fitted"]] <- pred[[ w[1L] ]] } # variance(s) of average predictions vc <- NA_real_ # output structure(pred, class = c("prediction", "data.frame"), at = if (is.null(at)) at else at_specification, type = NA_character_, call = if ("call" %in% names(model)) model[["call"]] else NULL, model_class = class(model), row.names = seq_len(nrow(pred)), vcov = vc, jacobian = NULL, category = category, weighted = FALSE) } prediction/R/summary.R0000644000176200001440000000427413501406664014447 0ustar liggesusers#' @import stats #' @export summary.prediction <- function(object, level = 0.95, ...) { # summary method # gather metadata f <- object[["fitted"]] fc <- object[["fitted.class"]] vc <- attributes(object)[["vcov"]] if (is.null(vc)) { vc <- NA_real_ } # convert 'at_specification' into data frame at <- attributes(object)[["at"]] # aggregate average predictions from data if (is.null(at)) { objectby <- list(rep(1L, nrow(object))) out <- aggregate(object[["fitted"]], objectby, FUN = mean, na.rm = TRUE) out[["Group.1"]] <- NULL } else { objectby <- object[ , setdiff(names(at), "index"), drop = FALSE] out <- aggregate(object[["fitted"]], objectby, FUN = mean, na.rm = TRUE) } # extract calculated variance from object out[["SE"]] <- sqrt(vc) # cleanup output names(out)[names(out) == "x"] <- "Prediction" at_names <- names(out)[!names(out) %in% c("Prediction", "SE")] at_names <- if (length(at_names)) paste0("at(", at_names, ")") else NULL names(out)[!names(out) %in% c("Prediction", "SE")] <- at_names # add z and p out[["z"]] <- out[,"Prediction"]/out[,"SE"] out[["p"]] <- 2 * pnorm(abs(out[,"z"]), lower.tail = FALSE) # add CI a <- (1 - level)/2 a <- c(a, 1 - a) fac <- qnorm(a) ci <- array(NA_real_, dim = c(nrow(out), 2L)) ci[] <- out[["Prediction"]] + out[["SE"]] %o% fac colnames(ci) <- c("lower", "upper") out <- cbind(out, ci) # return structure(out[, c(at_names, "Prediction", "SE", "z", "p", "lower", "upper"), drop = FALSE], class = c("summary.prediction", "data.frame")) } #' @export print.summary.prediction <- function(x, digits = 4, ...) { print(`class<-`(x, "data.frame"), digits = digits, row.names = FALSE, ...) } #' @rdname prediction #' @param level A numeric value specifying the confidence level for calculating p-values and confidence intervals. #' @export prediction_summary <- function(model, ..., level = 0.95) { predictions <- prediction(model, ...) summary(predictions, level = 0.95) } prediction/R/prediction_ppr.R0000644000176200001440000000260313501406664015765 0ustar liggesusers#' @rdname prediction #' @export prediction.ppr <- function(model, data = find_data(model, parent.frame()), at = NULL, calculate_se = FALSE, ...) { # extract predicted values data <- data if (missing(data) || is.null(data)) { pred <- make_data_frame(fitted = predict(model, ...), se.fitted = NA_real_) } else { # setup data if (is.null(at)) { out <- data } else { out <- build_datalist(data, at = at, as.data.frame = TRUE) at_specification <- attr(out, "at_specification") } # calculate predictions tmp <- predict(model, newdata = out, ...) # cbind back together pred <- make_data_frame(out, fitted = tmp, se.fitted = rep(NA_real_, nrow(out))) } # variance(s) of average predictions vc <- NA_real_ # output structure(pred, class = c("prediction", "data.frame"), at = if (is.null(at)) at else at_specification, type = NA_character_, call = if ("call" %in% names(model)) model[["call"]] else NULL, model_class = class(model), row.names = seq_len(nrow(pred)), vcov = vc, jacobian = NULL, weighted = FALSE) } prediction/R/prediction_hxlr.R0000644000176200001440000000275713501406664016153 0ustar liggesusers#' @rdname prediction #' @export prediction.hxlr <- function(model, data = find_data(model), at = NULL, type = c("class", "probability", "cumprob", "location", "scale"), calculate_se = FALSE, ...) { type <- match.arg(type) # extract predicted values data <- data if (missing(data) || is.null(data)) { pred <- make_data_frame(fitted = predict(model, type = type, ...), se.fitted = NA_real_) } else { # setup data if (is.null(at)) { out <- data } else { out <- build_datalist(data, at = at, as.data.frame = TRUE) at_specification <- attr(out, "at_specification") } # calculate predictions tmp <- predict(model, newdata = out, type = "class", ...) # cbind back together pred <- make_data_frame(out, fitted = tmp, se.fitted = rep(NA_real_, nrow(out))) } # variance(s) of average predictions vc <- NA_real_ # output structure(pred, class = c("prediction", "data.frame"), at = if (is.null(at)) at else at_specification, type = type, call = if ("call" %in% names(model)) model[["call"]] else NULL, model_class = class(model), row.names = seq_len(nrow(pred)), vcov = vc, jacobian = NULL, weighted = FALSE) } prediction/R/prediction_svyglm.R0000644000176200001440000000304713501406664016510 0ustar liggesusers#' @rdname prediction #' @export prediction.svyglm <- function(model, data = find_data(model, parent.frame()), at = NULL, type = c("response", "link"), calculate_se = TRUE, ...) { type <- match.arg(type) # extract predicted values data <- data if (missing(data) || is.null(data)) { pred <- predict(model, type = type, se.fit = TRUE, ...) pred <- data.frame(fitted = unclass(pred), se.fitted = sqrt(unname(attributes(pred)[["var"]]))) } else { # setup data if (is.null(at)) { out <- data } else { out <- build_datalist(data, at = at, as.data.frame = TRUE) at_specification <- attr(out, "at_specification") } # calculate predictions tmp <- predict(model, newdata = out, type = type, se.fit = TRUE, ...) pred <- make_data_frame(out, fitted = unclass(tmp), se.fitted = sqrt(unname(attributes(tmp)[["var"]]))) } # variance(s) of average predictions vc <- NA_real_ # output structure(pred, class = c("prediction", "data.frame"), at = if (is.null(at)) at else at_specification, type = type, call = if ("call" %in% names(model)) model[["call"]] else NULL, model_class = class(model), row.names = seq_len(nrow(pred)), vcov = vc, jacobian = NULL, weighted = TRUE) } prediction/R/prediction_mnp.R0000644000176200001440000000535513501406664015765 0ustar liggesusers#' @rdname prediction #' @export prediction.mnp <- function(model, data = find_data(model, parent.frame()), at = NULL, type = NULL, calculate_se = FALSE, category, ...) { if (!is.null(type)) { warning(sprintf("'type' is ignored for models of class '%s'", class(model))) } # extract predicted values data <- data if (missing(data) || is.null(data)) { probs <- make_data_frame(predict(model, type = "prob", ...)[["p"]]) names(probs) <- paste0("Pr(", names(probs), ")") tmp <- predict(model, type = "choice", ...)[["y"]] d <- dim(tmp) if (length(d) == 3) { stop("'prediction.mnp' only works when 'n.draws = 1'") } probs[["fitted.class"]] <- lapply(seq_len(d[1L]), function(i) tmp[i,]) pred <- probs rm(probs, tmp) } else { # setup data if (is.null(at)) { out <- data } else { out <- build_datalist(data, at = at, as.data.frame = TRUE) at_specification <- attr(out, "at_specification") } # calculate predictions tmp_probs <- make_data_frame(predict(model, newdata = out, type = "prob", ...)[["p"]]) names(tmp_probs) <- paste0("Pr(", names(tmp_probs), ")") tmp <- predict(model, newdata = out, type = "choice", ...)[["y"]] d <- dim(tmp) if (length(d) == 3) { stop("'prediction.mnp' only works when 'n.draws = 1'") } tmp_probs[["fitted.class"]] <- lapply(seq_len(d[1L]), function(i) tmp[i,]) # cbind back together pred <- make_data_frame(out, tmp_probs) rm(tmp, tmp_probs) } # handle category argument if (missing(category)) { w <- grep("^Pr\\(", names(pred))[1L] category <- names(pred)[w] pred[["fitted"]] <- pred[[w]] } else { w <- which(names(pred) == paste0("Pr(", category, ")")) if (!length(w)) { stop(sprintf("category %s not found", category)) } pred[["fitted"]] <- pred[[ w[1L] ]] } pred[["se.fitted"]] <- NA_real_ # variance(s) of average predictions vc <- NA_real_ # output structure(pred, class = c("prediction", "data.frame"), at = if (is.null(at)) at else at_specification, type = NA_character_, call = if ("call" %in% names(model)) model[["call"]] else NULL, model_class = class(model), row.names = seq_len(nrow(pred)), vcov = vc, jacobian = NULL, category = category, weighted = FALSE) } prediction/R/prediction_truncreg.R0000644000176200001440000000223213501406664017013 0ustar liggesusers#' @rdname prediction #' @export prediction.truncreg <- function(model, data, at = NULL, calculate_se = FALSE, ...) { # extract predicted values if (missing(data) || is.null(data)) { pred <- make_data_frame(fitted = predict(object = model, ...)) } else { # setup data if (is.null(at)) { out <- data } else { out <- build_datalist(data, at = at, as.data.frame = TRUE) at_specification <- attr(out, "at_specification") } pred <- make_data_frame(fitted = predict(model, newdata = data, ...)) } pred[["se.fitted"]] <- NA_real_ # variance(s) of average predictions vc <- NA_real_ # output structure(pred, class = c("prediction", "data.frame"), at = if (is.null(at)) at else at_specification, type = NA_character_, call = if ("call" %in% names(model)) model[["call"]] else NULL, model_class = class(model), row.names = seq_len(nrow(pred)), vcov = vc, jacobian = NULL, weighted = FALSE) } prediction/R/prediction_bigglm.R0000644000176200001440000000333013501406664016423 0ustar liggesusers# @rdname prediction # @export prediction.bigglm <- function(model, data = find_data(model, parent.frame()), at = NULL, type = "response", calculate_se = TRUE, ...) { type <- match.arg(type) # extract predicted values data <- data if (missing(data) || is.null(data)) { stop("prediction() for objects of class 'bigglm' only work when 'data' is specified") } else { # reduce memory profile model[["model"]] <- NULL # setup data data <- build_datalist(data, at = at, as.data.frame = TRUE) at_specification <- attr(data, "at_specification") # calculate predictions if (isTRUE(calculate_se)) { tmp <- predict(model, newdata = data, type = type, se.fit = TRUE, ...) # cbind back together pred <- make_data_frame(data, fitted = tmp[["fit"]], se.fitted = tmp[["se.fit"]]) } else { tmp <- predict(model, newdata = data, type = type, se.fit = FALSE, ...) # cbind back together pred <- make_data_frame(data, fitted = tmp, se.fitted = rep(NA_real_, nrow(data))) } } # variance(s) of average predictions vc <- NA_real_ # output structure(pred, class = c("prediction", "data.frame"), at = if (is.null(at)) at else at_specification, type = type, call = if ("call" %in% names(model)) model[["call"]] else NULL, model_class = class(model), row.names = seq_len(nrow(pred)), vcov = vc, jaccobian = NULL, weighted = FALSE) } prediction/R/prediction_lm.R0000644000176200001440000000675213501406664015605 0ustar liggesusers#' @rdname prediction #' @export prediction.lm <- function(model, data = find_data(model, parent.frame()), at = NULL, type = "response", vcov = stats::vcov(model), calculate_se = TRUE, ...) { type <- match.arg(type) # extract predicted values data <- data if (missing(data) || is.null(data)) { if (isTRUE(calculate_se)) { pred <- predict(model, type = type, se.fit = TRUE, ...) pred <- make_data_frame(fitted = pred[["fit"]], se.fitted = pred[["se.fit"]]) } else { pred <- predict(model, type = type, se.fit = FALSE, ...) pred <- make_data_frame(fitted = pred, se.fitted = rep(NA_real_, length(pred))) } } else { # reduce memory profile model[["model"]] <- NULL # setup data datalist <- build_datalist(data, at = at, as.data.frame = TRUE) at_specification <- attr(datalist, "at_specification") # calculate predictions if (isTRUE(calculate_se)) { tmp <- predict(model, newdata = datalist, type = type, se.fit = TRUE, ...) # cbind back together pred <- make_data_frame(datalist, fitted = tmp[["fit"]], se.fitted = tmp[["se.fit"]]) } else { tmp <- predict(model, newdata = datalist, type = type, se.fit = FALSE, ...) # cbind back together pred <- make_data_frame(datalist, fitted = tmp, se.fitted = rep(NA_real_, nrow(datalist))) } } # variance(s) of average predictions if (isTRUE(calculate_se)) { # handle case where SEs are calculated J <- NULL model_terms <- delete.response(terms(model)) if (is.null(at)) { # no 'at_specification', so calculate variance of overall average prediction model_frame <- model.frame(model_terms, data, na.action = na.pass, xlev = model$xlevels) model_mat <- model.matrix(model_terms, model_frame, contrasts.arg = model$contrasts) means_for_prediction <- colMeans(model_mat) vc <- (means_for_prediction %*% vcov %*% means_for_prediction)[1L, 1L, drop = TRUE] } else { # with 'at_specification', calculate variance of all counterfactual predictions datalist <- build_datalist(data, at = at, as.data.frame = FALSE) vc <- unlist(lapply(datalist, function(one) { model_frame <- model.frame(model_terms, one, na.action = na.pass, xlev = model$xlevels) model_mat <- model.matrix(model_terms, model_frame, contrasts.arg = model$contrasts) means_for_prediction <- colMeans(model_mat) means_for_prediction %*% vcov %*% means_for_prediction })) } } else { # handle case where SEs are *not* calculated J <- NULL if (length(at)) { vc <- rep(NA_real_, nrow(at_specification)) } else { vc <- NA_real_ } } # output structure(pred, class = c("prediction", "data.frame"), at = if (is.null(at)) at else at_specification, type = type, call = if ("call" %in% names(model)) model[["call"]] else NULL, model_class = class(model), row.names = seq_len(nrow(pred)), vcov = vc, jacobian = J, weighted = FALSE) } prediction/R/prediction_train.R0000644000176200001440000000257113501406664016305 0ustar liggesusers#' @rdname prediction #' @export prediction.train <- function(model, data = find_data(model), at = NULL, type = c("raw", "prob"), ...) { type <- match.arg(type) # extract predicted values data <- data if (missing(data) || is.null(data)) { pred <- predict(model, type = type, se.fit = FALSE, ...) pred <- make_data_frame(fitted = pred, se.fitted = rep(NA_real_, length(pred))) } else { # setup data data <- build_datalist(data, at = at, as.data.frame = TRUE) at_specification <- attr(data, "at_specification") # calculate predictions tmp <- predict(model, newdata = data, type = type, se.fit = FALSE, ...) # cbind back together pred <- make_data_frame(data, fitted = tmp, se.fitted = rep(NA_real_, nrow(data))) } # variance(s) of average predictions vc <- NA_real_ # output structure(pred, class = c("prediction", "data.frame"), at = if (is.null(at)) at else at_specification, type = type, call = if ("call" %in% names(model)) model[["call"]] else NULL, model_class = class(model), row.names = seq_len(nrow(pred)), vcov = vc, jacobian = NULL, weighted = FALSE) } prediction/R/prediction_glimML.R0000644000176200001440000000376413501406664016356 0ustar liggesusers#' @rdname prediction #' @export prediction.glimML <- function(model, data = find_data(model, parent.frame()), at = NULL, type = c("response", "link"), calculate_se = TRUE, ...) { requireNamespace("aod") type <- match.arg(type) # extract predicted values data <- data if (missing(data) || is.null(data)) { if (isTRUE(calculate_se)) { pred <- aod::predict(model, type = type, se.fit = TRUE, ...) pred <- make_data_frame(fitted = pred[["fit"]], se.fitted = pred[["se.fit"]]) } else { pred <- aod::predict(model, type = type, se.fit = FALSE, ...) pred <- make_data_frame(fitted = pred, se.fitted = rep(NA_real_, length(pred))) } } else { # setup data data <- build_datalist(data, at = at, as.data.frame = TRUE) at_specification <- attr(data, "at_specification") # calculate predictions if (isTRUE(calculate_se)) { tmp <- aod::predict(model, newdata = data, type = type, se.fit = TRUE, ...) # cbind back together pred <- make_data_frame(data, fitted = tmp[["fit"]], se.fitted = tmp[["se.fit"]]) } else { tmp <- aod::predict(model, newdata = data, type = type, se.fit = FALSE, ...) # cbind back together pred <- make_data_frame(data, fitted = tmp, se.fitted = rep(NA_real_, nrow(data))) } } # variance(s) of average predictions vc <- NA_real_ # output structure(pred, class = c("prediction", "data.frame"), at = if (is.null(at)) at else at_specification, type = type, call = if ("call" %in% names(model)) model[["call"]] else NULL, model_class = class(model), row.names = seq_len(nrow(pred)), vcov = vc, jacobian = NULL, weighted = FALSE) } prediction/R/prediction_betareg.R0000644000176200001440000000312513501406664016575 0ustar liggesusers#' @rdname prediction #' @export prediction.betareg <- function(model, data = find_data(model, parent.frame()), at = NULL, type = c("response", "link", "precision", "variance", "quantile"), calculate_se = FALSE, ...) { type <- match.arg(type) # extract predicted value data <- data if (missing(data) || is.null(data)) { pred <- make_data_frame(fitted = predict(model, type = type, ...), se.fitted = NA_real_) } else { # reduce memory profile model[["model"]] <- NULL # setup data if (is.null(at)) { out <- data } else { out <- build_datalist(data, at = at, as.data.frame = TRUE) at_specification <- attr(out, "at_specification") } # calculate predictions pred <- predict(model, newdata = out, type = type, ...) # cbind back together pred <- make_data_frame(out, fitted = pred, se.fitted = rep(NA_real_, length(pred))) } # variance(s) of average predictions vc <- NA_real_ # output structure(pred, class = c("prediction", "data.frame"), at = if (is.null(at)) at else at_specification, type = type, call = if ("call" %in% names(model)) model[["call"]] else NULL, model_class = class(model), row.names = seq_len(nrow(pred)), vcov = vc, jacobian = NULL, weighted = FALSE) } prediction/R/prediction_vgam.R0000644000176200001440000000374413501406664016125 0ustar liggesusers# @rdname prediction # @export prediction.vgam <- function(model, data = find_data(model, parent.frame()), at = NULL, type = c("response", "link"), calculate_se = FALSE, category, ...) { type <- match.arg(type) # extract predicted values data <- data if (missing(data) || is.null(data)) { pred <- make_data_frame(predict(model, type = type, se.fit = FALSE, ...)) } else { # setup data if (is.null(at)) { out <- data } else { out <- build_datalist(data, at = at, as.data.frame = TRUE) at_specification <- attr(out, "at_specification") } # calculate predictions tmp <- predict(model, newdata = out, type = type, se.fit = FALSE, ...) if (!is.null(dim(tmp))) { tmp <- as.matrix(tmp, ncol = 1) } # cbind back together pred <- make_data_frame(out, fitted = make_data_frame(tmp), se.fitted = rep(NA_real_, nrow(out))) } # handle category argument if (missing(category)) { category <- names(pred)[!names(pred) %in% names(data)][1L] pred[["fitted"]] <- pred[[category]] } else { w <- grep(category, names(pred)) if (!length(w)) { stop(sprintf("category %s not found", category)) } pred[["fitted"]] <- pred[[ w[1L] ]] } # variance(s) of average predictions vc <- NA_real_ # output structure(pred, class = c("prediction", "data.frame"), at = if (is.null(at)) at else at_specification, type = type, call = if ("call" %in% names(model)) model[["call"]] else NULL, model_class = class(model), row.names = seq_len(nrow(pred)), vcov = vc, jacobian = NULL, category = category, weighted = FALSE) } prediction/R/prediction_glm.R0000644000176200001440000001011213501755364015741 0ustar liggesusers#' @rdname prediction #' @export prediction.glm <- function(model, data = find_data(model, parent.frame()), at = NULL, type = c("response", "link"), vcov = stats::vcov(model), calculate_se = TRUE, ...) { type <- match.arg(type) # extract predicted values data <- data if (missing(data) || is.null(data)) { if (isTRUE(calculate_se)) { pred <- predict(model, type = type, se.fit = TRUE, ...) pred <- make_data_frame(fitted = pred[["fit"]], se.fitted = pred[["se.fit"]]) } else { pred <- predict(model, type = type, se.fit = FALSE, ...) pred <- make_data_frame(fitted = pred, se.fitted = rep(NA_real_, length(pred))) } } else { # reduce memory profile model[["model"]] <- NULL # setup data out <- build_datalist(data, at = at, as.data.frame = TRUE) at_specification <- attr(out, "at_specification") # calculate predictions if (isTRUE(calculate_se)) { tmp <- predict(model, newdata = out, type = type, se.fit = TRUE, ...) # cbind back together pred <- make_data_frame(out, fitted = tmp[["fit"]], se.fitted = tmp[["se.fit"]]) } else { tmp <- predict(model, newdata = out, type = type, se.fit = FALSE, ...) # cbind back together pred <- make_data_frame(out, fitted = tmp, se.fitted = rep(NA_real_, nrow(out))) } } # variance(s) of average predictions if (isTRUE(calculate_se)) { # handle case where SEs are calculated model_terms <- delete.response(terms(model)) if (is.null(at)) { # no 'at_specification', so calculate variance of overall average prediction model_frame <- model.frame(model_terms, data, na.action = na.pass, xlev = model$xlevels) model_mat <- model.matrix(model_terms, model_frame, contrasts.arg = model$contrasts) if (type == "link") { means_for_prediction <- colMeans(model_mat) } else if (type == "response") { predictions_link <- predict(model, newdata = data, type = "link", se.fit = FALSE, ...) means_for_prediction <- colMeans(model$family$mu.eta(predictions_link) * model_mat) } J <- matrix(means_for_prediction, nrow = 1L) } else { # with 'at_specification', calculate variance of all counterfactual predictions datalist <- build_datalist(data, at = at, as.data.frame = FALSE) jacobian_list <- lapply(datalist, function(one) { model_frame <- model.frame(model_terms, one, na.action = na.pass, xlev = model$xlevels) model_mat <- model.matrix(model_terms, model_frame, contrasts.arg = model$contrasts) if (type == "link") { means_for_prediction <- colMeans(model_mat) } else if (type == "response") { predictions_link <- predict(model, newdata = one, type = "link", se.fit = FALSE, ...) means_for_prediction <- colMeans(model$family$mu.eta(predictions_link) * model_mat) } means_for_prediction }) J <- do.call("rbind", jacobian_list) } vc <- diag(J %*% vcov %*% t(J)) } else { # handle case where SEs are *not* calculated J <- NULL if (length(at)) { vc <- rep(NA_real_, nrow(at_specification)) } else { vc <- NA_real_ } } # output structure(pred, class = c("prediction", "data.frame"), at = if (is.null(at)) at else at_specification, type = type, call = if ("call" %in% names(model)) model[["call"]] else NULL, model_class = class(model), row.names = seq_len(nrow(pred)), vcov = vc, jacobian = J, weighted = FALSE) } prediction/R/prediction_ksvm.R0000644000176200001440000000011213076135226016135 0ustar liggesusers#' @rdname prediction #' @export prediction.ksvm <- prediction.gausspr prediction/R/prediction_rlm.R0000644000176200001440000000011113066225250015742 0ustar liggesusers#' @rdname prediction #' @export prediction.rlm <- prediction.default prediction/R/prediction_plm.R0000644000176200001440000000250713501406664015757 0ustar liggesusers#' @rdname prediction #' @export prediction.plm <- function(model, data = find_data(model, parent.frame()), at = NULL, calculate_se = FALSE, ...) { # extract predicted values data <- data if (missing(data) || is.null(data)) { pred <- make_data_frame(fitted = predict(model, ...)) } else { # setup data if (is.null(at)) { out <- data } else { out <- build_datalist(data, at = at, as.data.frame = TRUE) at_specification <- attr(out, "at_specification") } # calculate predictions tmp <- predict(model, newdata = out, ...) # cbind back together pred <- make_data_frame(out, fitted = tmp, se.fitted = rep(NA_real_, nrow(out))) } # variance(s) of average predictions vc <- NA_real_ # output structure(pred, class = c("prediction", "data.frame"), at = if (is.null(at)) at else at_specification, type = NA_character_, call = if ("call" %in% names(model)) model[["call"]] else NULL, model_class = class(model), row.names = seq_len(nrow(pred)), vcov = vc, jacobian = NULL, weighted = FALSE) } prediction/R/prediction_gausspr.R0000644000176200001440000000461613501406664016656 0ustar liggesusers#' @rdname prediction #' @export prediction.gausspr <- function(model, data, at = NULL, type = NULL, calculate_se = TRUE, category, ...) { requireNamespace("kernlab") if (!is.null(type)) { warning(sprintf("'type' is ignored for models of class '%s'", class(model))) } # extract predicted values data <- data if (missing(data) || is.null(data)) { pred <- make_data_frame(fitted.class = kernlab::predict(model, type = "response", ...)) probs <- make_data_frame(kernlab::predict(model, type = "probabilities", ...)) names(probs) <- paste0("Pr(", names(probs), ")") pred <- cbind(pred, probs) } else { # setup data if (is.null(at)) { out <- data } else { out <- build_datalist(data, at = at, as.data.frame = TRUE) at_specification <- attr(out, "at_specification") } # calculate predictions tmp <- kernlab::predict(model, newdata = out, type = "response", ...) tmp_probs <- make_data_frame(kernlab::predict(model, newdata = out, type = "probabilities", ...)) names(tmp_probs) <- paste0("Pr(", names(tmp_probs), ")") # cbind back together pred <- make_data_frame(out, fitted.class = tmp, tmp_probs) rm(tmp, tmp_probs) } # handle category argument if (missing(category)) { w <- grep("^Pr\\(", names(pred))[1L] category <- names(pred)[w] pred[["fitted"]] <- pred[[w]] } else { w <- which(names(pred) == paste0("Pr(", category, ")")) if (!length(w)) { stop(sprintf("category %s not found", category)) } pred[["fitted"]] <- pred[[ w[1L] ]] } pred[["se.fitted"]] <- NA_real_ # variance(s) of average predictions vc <- NA_real_ # output structure(pred, class = c("prediction", "data.frame"), at = if (is.null(at)) at else at_specification, type = NA_character_, call = if ("call" %in% names(model)) model[["call"]] else NULL, model_class = class(model), row.names = seq_len(nrow(pred)), vcov = vc, jacobian = NULL, category = category, weighted = FALSE) } prediction/README.md0000644000176200001440000001703113501406664013700 0ustar liggesusers--- title: "Tidy, Type-Safe 'prediction()' Methods" output: github_document --- The **prediction** and **margins** packages are a combined effort to port the functionality of Stata's (closed source) [`margins`](http://www.stata.com/help.cgi?margins) command to (open source) R. **prediction** is focused on one function - `prediction()` - that provides type-safe methods for generating predictions from fitted regression models. `prediction()` is an S3 generic, which always return a `"data.frame"` class object rather than the mix of vectors, lists, etc. that are returned by the `predict()` methods for various model types. It provides a key piece of underlying infrastructure for the **margins** package. Users interested in generating marginal (partial) effects, like those generated by Stata's `margins, dydx(*)` command, should consider using `margins()` from the sibling project, [**margins**](https://cran.r-project.org/package=margins). In addition to `prediction()`, this package provides a number of utility functions for generating useful predictions: - `find_data()`, an S3 generic with methods that find the data frame used to estimate a regression model. This is a wrapper around `get_all_vars()` that attempts to locate data as well as modify it according to `subset` and `na.action` arguments used in the original modelling call. - `mean_or_mode()` and `median_or_mode()`, which provide a convenient way to compute the data needed for predicted values *at means* (or *at medians*), respecting the differences between factor and numeric variables. - `seq_range()`, which generates a vector of *n* values based upon the range of values in a variable - `build_datalist()`, which generates a list of data frames from an input data frame and a specified set of replacement `at` values (mimicking the `atlist` option of Stata's `margins` command) ## Simple code examples A major downside of the `predict()` methods for common modelling classes is that the result is not type-safe. Consider the following simple example: ```r library("stats") library("datasets") x <- lm(mpg ~ cyl * hp + wt, data = mtcars) class(predict(x)) ``` ``` ## [1] "numeric" ``` ```r class(predict(x, se.fit = TRUE)) ``` ``` ## [1] "list" ``` **prediction** solves this issue by providing a wrapper around `predict()`, called `prediction()`, that always returns a tidy data frame with a very simple `print()` method: ```r library("prediction") (p <- prediction(x)) ``` ``` ## Data frame with 32 predictions from ## lm(formula = mpg ~ cyl * hp + wt, data = mtcars) ## with average prediction: 20.0906 ``` ```r class(p) ``` ``` ## [1] "prediction" "data.frame" ``` ```r head(p) ``` ``` ## mpg cyl disp hp drat wt qsec vs am gear carb fitted se.fitted ## 1 21.0 6 160 110 3.90 2.620 16.46 0 1 4 4 21.90488 0.6927034 ## 2 21.0 6 160 110 3.90 2.875 17.02 0 1 4 4 21.10933 0.6266557 ## 3 22.8 4 108 93 3.85 2.320 18.61 1 1 4 1 25.64753 0.6652076 ## 4 21.4 6 258 110 3.08 3.215 19.44 1 0 3 1 20.04859 0.6041400 ## 5 18.7 8 360 175 3.15 3.440 17.02 0 0 3 2 17.25445 0.7436172 ## 6 18.1 6 225 105 2.76 3.460 20.22 1 0 3 1 19.53360 0.6436862 ``` The output always contains the original data (i.e., either data found using the `find_data()` function or passed to the `data` argument to `prediction()`). This makes it much simpler to pass predictions to, e.g., further summary or plotting functions. Additionally the vast majority of methods allow the passing of an `at` argument, which can be used to obtain predicted values using modified version of `data` held to specific values: ```r prediction(x, at = list(hp = seq_range(mtcars$hp, 5))) ``` ``` ## Data frame with 160 predictions from ## lm(formula = mpg ~ cyl * hp + wt, data = mtcars) ## with average predictions: ``` ``` ## hp x ## 52.0 22.605 ## 122.8 19.328 ## 193.5 16.051 ## 264.2 12.774 ## 335.0 9.497 ``` This more or less serves as a direct R port of (the subset of functionality of) Stata's `margins` command that calculates predictive marginal means, etc. For calculation of marginal or partial effects, see the [**margins**](https://cran.r-project.org/package=margins) package. ## Supported model classes The currently supported model classes are: - "lm" from `stats::lm()` - "glm" from `stats::glm()`, `MASS::glm.nb()`, `glmx::glmx()`, `glmx::hetglm()`, `brglm::brglm()` - "ar" from `stats::ar()` - "Arima" from `stats::arima()` - "arima0" from `stats::arima0()` - "biglm" from `biglm::biglm()` (including `"ffdf"` backed models) - "betareg" from `betareg::betareg()` - "bruto" from `mda::bruto()` - "clm" from `ordinal::clm()` - "coxph" from `survival::coxph()` - "crch" from `crch::crch()` - "earth" from `earth::earth()` - "fda" from `mda::fda()` - "Gam" from `gam::gam()` - "gausspr" from `kernlab::gausspr()` - "gee" from `gee::gee()` - "glimML" from `aod::betabin()`, `aod::negbin()` - "glimQL" from `aod::quasibin()`, `aod::quasipois()` - "glmnet" from `glmnet::glmnet()` - "gls" from `nlme::gls()` - "hurdle" from `pscl::hurdle()` - "hxlr" from `crch::hxlr()` - "ivreg" from `AER::ivreg()` - "knnreg" from `caret::knnreg()` - "kqr" from `kernlab::kqr()` - "ksvm" from `kernlab::ksvm()` - "lda" from `MASS:lda()` - "lme" from `nlme::lme()` - "loess" from `stats::loess()` - "lqs" from `MASS::lqs()` - "mars" from `mda::mars()` - "mca" from `MASS::mca()` - "mclogit" from `mclogit::mclogit()` - "mda" from `mda::mda()` - "merMod" from `lme4::lmer()` and `lme4::glmer()` - "mnlogit" from `mnlogit::mnlogit()` - "mnp" from `MNP::mnp()` - "naiveBayes" from `e1071::naiveBayes()` - "nlme" from `nlme::nlme()` - "nls" from `stats::nls()` - "nnet" from `nnet::nnet()`, `nnet::multinom()` - "plm" from `plm::plm()` - "polr" from `MASS::polr()` - "ppr" from `stats::ppr()` - "princomp" from `stats::princomp()` - "qda" from `MASS:qda()` - "rlm" from `MASS::rlm()` - "rpart" from `rpart::rpart()` - "rq" from `quantreg::rq()` - "selection" from `sampleSelection::selection()` - "speedglm" from `speedglm::speedglm()` - "speedlm" from `speedglm::speedlm()` - "survreg" from `survival::survreg()` - "svm" from `e1071::svm()` - "svyglm" from `survey::svyglm()` - "tobit" from `AER::tobit()` - "train" from `caret::train()` - "truncreg" from `truncreg::truncreg()` - "zeroinfl" from `pscl::zeroinfl()` ## Requirements and Installation [![CRAN](https://www.r-pkg.org/badges/version/prediction)](https://cran.r-project.org/package=prediction) ![Downloads](https://cranlogs.r-pkg.org/badges/prediction) [![Build Status](https://travis-ci.org/leeper/prediction.svg?branch=master)](https://travis-ci.org/leeper/prediction) [![Build status](https://ci.appveyor.com/api/projects/status/a4tebeoa98cq07gy/branch/master?svg=true)](https://ci.appveyor.com/project/leeper/prediction/branch/master) [![codecov.io](https://codecov.io/github/leeper/prediction/coverage.svg?branch=master)](https://codecov.io/github/leeper/prediction?branch=master) [![Project Status: Active - The project has reached a stable, usable state and is being actively developed.](http://www.repostatus.org/badges/latest/active.svg)](http://www.repostatus.org/#active) The development version of this package can be installed directly from GitHub using `remotes`: ``` r if (!require("remotes")) { install.packages("remotes") } remotes::install_github("leeper/prediction") ``` prediction/MD50000644000176200001440000001207013501766223012727 0ustar liggesusersc99f5a95d4b090cc1384d2fda1fad003 *DESCRIPTION 875ed094f58c0c1b2c38c2aecc6e1e9f *LICENSE df5a4adb0d6171e3b33f46e1213c855d *NAMESPACE 0afdbf4c8a650275cc6ec65d9ccdba48 *NEWS.md f9d37a2a80f0f9d04696e92f6c2ab653 *R/build_datalist.R 105ced25ae286073487387409560b16d *R/find_data.R 143c5d8a66b917e3106ac135e2e98e76 *R/make_data_frame.R a8c2122556b46f3c342733d71da79d4f *R/margex.R da5660b8f426c6b9ae6ff27abc793080 *R/mean_or_mode.R 0a4e9994a07d4a9895c317c6ecd0c014 *R/prediction.R 7e5f4746fc400c4d92f4c5ad1c991e4e *R/prediction_Arima.R 629093292de8b2aa4f5389b6ef003d1c *R/prediction_ar.R 84c158331418816751d4649c9444c69a *R/prediction_arima0.R 39382b3ec5ff1a50306ffb299344dd39 *R/prediction_betareg.R 1bbb3b8a8ca6397b47fe68a929c34390 *R/prediction_bigFastLm.R bdae9856e4e7c2be3dda719ebc6c596b *R/prediction_bigglm.R fe73e08cea5a1883497ba0fe7751c566 *R/prediction_biglm.R ab2f4567280d8352e5348501fb73b063 *R/prediction_bruto.R f0d57fde58010db1f06c1ef19d74d19a *R/prediction_clm.R 3cc3f5dbcf789da1d7833373c0782b58 *R/prediction_coxph.R 953f95190d3d17dc0fdcf61a57078cd0 *R/prediction_crch.R be818010a8adc80cf4bf4a76340c0b0e *R/prediction_earth.R 8dbd4d4fdb863aca0207712389ab91a1 *R/prediction_fda.R 65c8fc9f11e573289e326cb7f4f4c302 *R/prediction_gam.R ae4f28d4062082125dc723688c25ab28 *R/prediction_gausspr.R 825925f51f2a49f98a1ef28280193053 *R/prediction_gee.R f2b475a93aa8d7070c8fcc146c709260 *R/prediction_glimML.R 75324ba15cddb60772707af35a042148 *R/prediction_glimQL.R fd6fc7a9ef1f039b9a93955926fa4210 *R/prediction_glm.R 5fe8c9ca754342e25dc8796f39be6245 *R/prediction_glmnet.R 14ab1ebce030f4ec871511e3849b4ce2 *R/prediction_glmx.R 65dceb496efa24276719b309f9df7048 *R/prediction_gls.R 80c7fa5777c4beb86cee8f21fd41f6b3 *R/prediction_hetglm.R 2e12e3004cd38e217a06b215ab3b710b *R/prediction_hurdle.R 1691620dd40b2f014b4a405d2a7e9a08 *R/prediction_hxlr.R cdc0ffdc6b67152073c421e9c8e42f88 *R/prediction_ivreg.R 5d61ae51b61869b687a4d0fc7f546440 *R/prediction_knnreg.R 6a67310a26234218eccc04cc3d0d2a4f *R/prediction_kqr.R d696ccbb0f3b555cfb63f48a44031ecb *R/prediction_ksvm.R 07b8f692f3ac4577fa22bffe16564cd0 *R/prediction_lda.R b66ad16941fe13c11965745705be8464 *R/prediction_lm.R 3fa5c205e7401c2364e949289ecbd271 *R/prediction_lme.R c1fc72eba423456ea73cbbf046f609a7 *R/prediction_loess.R 5bd17dac4240da89d0245ec0f835a237 *R/prediction_lqs.R c77c070e90ba7d7bd56ed00071385d2b *R/prediction_mars.R ea59d4e0fd6e20089f4b43a6a512e03f *R/prediction_mca.R 8a2bad4170b4c42bad5b9e98b2117793 *R/prediction_mclogit.R d8657ed9b8a2cd5291fb4613ca94a2ef *R/prediction_merMod.R edde9f770e2ba5588087e985b9669052 *R/prediction_mlogit.R 001bdc6520500b6f13fd5e34f785cd7d *R/prediction_mnlogit.R ff8633187787584629421ee8d58f2110 *R/prediction_mnp.R 9f78f9478b75f23b92d0b4f9be32a441 *R/prediction_multinom.R 06bf831fffc18259f8eba2da6b6c48e8 *R/prediction_naiveBayes.R b169c60d262482ab0c762624221dac4f *R/prediction_nls.R 5a85eca5711455d33629aefcefc537fa *R/prediction_nnet.R 81f4a705c6fe2ec4dd52abd8e7997c30 *R/prediction_plm.R 2b7792c52ea2ee8f0bd1f9f78127db97 *R/prediction_polr.R de4b32b3878ccae87f788c0d487c23e2 *R/prediction_polyreg.R c3f30d2c76007d1c9a960133317baaf6 *R/prediction_ppr.R a0bffc459d37c55d85b718e6342b5455 *R/prediction_princomp.R 3fdb66525fc695bc0f46c1ebcd5efcd4 *R/prediction_qda.R 9de548c4c1b300269b5e6a6ecc266876 *R/prediction_rlm.R b20136e41550d9afa7a92629628a6345 *R/prediction_rpart.R 5d318c73bcad0b86ad85bfb2db1e8871 *R/prediction_rq.R cb5e6b97b26079ee1a308e1133658e32 *R/prediction_selection.R c2fbbee642a19593ea43280f3b985f33 *R/prediction_speedglm.R cc8690e9ae2267734b790f1570ec55bf *R/prediction_speedlm.R bbdb365f0c1dbc609a5bc8745eb65308 *R/prediction_survreg.R 6cb453e5cdfd5752556019c6366971f3 *R/prediction_svm.R fbef2e67f7a1130a62341b4deda53b62 *R/prediction_svyglm.R 720d221abccc96ac7f8e55a9184b778c *R/prediction_train.R 4fbef4c0b5d2687c0eb9b5f70f6819db *R/prediction_tree.R 39de348f4883e8a8e15c4e82f4aba63a *R/prediction_truncreg.R 7f64b9941686dbaede4d9ef77c35deba *R/prediction_vgam.R f9ab3d7d2845cd4e52f7368aa496a703 *R/prediction_vglm.R 4cd5361420a13da52d83bc21d5317493 *R/prediction_zeroinfl.R 4258a0ed57e287660281e73ceef8c581 *R/print.R 10a7e116d64b42f5b75ab839193b737e *R/seq_range.R 7b87a3a1cdb74f3feb8082c6d4434183 *R/summary.R ca9ac657b19b846bd21d2a5488f1645e *R/utils.R f362b5a8c87e6dd25ff7142b34dc5726 *README.md e9d44d03f5420756e7ada891b94f7235 *data/margex.rda 3acbd06a9009c660ff9bdf5e418a6b90 *inst/CITATION 7d518cae27e112cc4240f7058a0584e2 *man/build_datalist.Rd 3619985ff0f3bd43fa6814b1a0874fe5 *man/figures/logo.png da41232f73d433a26fd62f613bf536a0 *man/figures/logo.svg c22772da367a524088f9519c925c50b3 *man/find_data.Rd 18ef9fa9c4858888586db3c989deb73c *man/margex.Rd 133a4501528cd3ade7a8cdb46dab023f *man/mean_or_mode.Rd 5ec0e0d0ea5ad7db678dbc82c64d0cef *man/prediction.Rd bc55730250606031ee18b095eb840f5e *man/seq_range.Rd 3654c24de1c773caa482666f764b7360 *tests/testthat-prediction.R 4d7c7d803b404c321305c266ea190fe4 *tests/testthat/tests-build_datalist.R 994b206daee44fcf020e9373badc56bd *tests/testthat/tests-core.R f3200112d3d96313ea4fdc638990ad46 *tests/testthat/tests-find_data.R 1ab11f55bb053062305f62a60ebe191a *tests/testthat/tests-methods.R prediction/DESCRIPTION0000644000176200001440000000424413501766223014131 0ustar liggesusersPackage: prediction Type: Package Title: Tidy, Type-Safe 'prediction()' Methods Description: A one-function package containing 'prediction()', a type-safe alternative to 'predict()' that always returns a data frame. The 'summary()' method provides a data frame with average predictions, possibly over counterfactual versions of the data (a la the 'margins' command in 'Stata'). Marginal effect estimation is provided by the related package, 'margins' . The package currently supports common model types (e.g., "lm", "glm") from the 'stats' package, as well as numerous other model classes from other add-on packages. See the README or main package documentation page for a complete listing. License: MIT + file LICENSE Version: 0.3.14 Date: 2019-06-16 Authors@R: c(person("Thomas J.", "Leeper", role = c("aut", "cre"), email = "thosjleeper@gmail.com", comment = c(ORCID = "0000-0003-4097-6326")), person("Carl", "Ganz", role = "ctb", email = "carlganz@ucla.edu"), person("Vincent", "Arel-Bundock", role = "ctb", email = "vincent.arel-bundock@umontreal.ca", comment = c(ORCID = "0000-0003-2042-7063")) ) URL: https://github.com/leeper/prediction BugReports: https://github.com/leeper/prediction/issues Depends: R (>= 3.5.0) Imports: utils, stats, data.table Suggests: datasets, methods, testthat Enhances: AER, aod, betareg, biglm, brglm, caret, crch, e1071, earth, ff, ffbase, gam (>= 1.15), gee, glmnet, glmx, kernlab, lme4, MASS, mclogit, mda, mlogit, MNP, nlme, nnet, ordinal, plm, pscl, quantreg, rpart, sampleSelection, speedglm, survey (>= 3.31-5), survival, truncreg, VGAM ByteCompile: true Encoding: UTF-8 RoxygenNote: 6.1.1 NeedsCompilation: no Packaged: 2019-06-17 18:36:42 UTC; THOMAS Author: Thomas J. Leeper [aut, cre] (), Carl Ganz [ctb], Vincent Arel-Bundock [ctb] () Maintainer: Thomas J. Leeper Repository: CRAN Date/Publication: 2019-06-17 19:40:03 UTC prediction/man/0000755000176200001440000000000013501406665013173 5ustar liggesusersprediction/man/figures/0000755000176200001440000000000013501406665014637 5ustar liggesusersprediction/man/figures/logo.png0000644000176200001440000002564613501406665016322 0ustar liggesusersPNG  IHDRU)sBIT|d pHYs N N+aotEXtSoftwarewww.inkscape.org< IDATxy|SU%i6Z"" Ό̨20 +n8n;oGYDDWYZ [tIMIKK^ZBBw{=\ w xPAH@"D0 T =0!i5Qt݇RMe`{ fEZ)#e씇E߹J^lR:%p(;"AxI2;E̅(l/NDzf!i_H X Զa PAaa? 1)>},HGY@4>wvÚ/!e/Cl?JO"5XnSp{ ?i8[ k p0d"悿 t!tRGy%랠b' D R.jsl3h`BEby qSGgNk#ccY5O r F:8ga &x)#d"ǹAS-J?%պ*F;gaS{<%@ioQ_@8 +xE'"ϹQ^0؀(crG{ B3Ѱ,x)#M&?} !]Z/bHUme -0XϙfX."IMyIԼ.eX'Wp@/Du9{C'wjvcY5 B0P۩ b 1HIO(aY]r%Ъ ٰN/aZ6(v ֭oJ*EVMtF+j>5x/Bo ^~`U "ˀ3кdX BC|:)%GW UGyb7Ȼqev :aG͕eH5јj@PjtXB"l@Ͱ-cJ9K24zuN}7`՚Б kR}|;j>ZIŎ+5:+†K@uuCnAFQw'4+W +3ByF; _랔^GS k&BτyGQOɺ];׀֥ k<0Lwl\_B"B\ڍ2,W\^AܥON͟}HAZuX+htVC2L4& 3Оf4,dbw ҝ0P~:=5 x p6G; (Zu))sSOay%b5M{򬏚wJQCDǵrha5D#`ԼJ)v鉹_sa]T53wqS F;{][AR\rN7DoȱͧW!5z#ʢU㩜U5O""f,Tt @+^U)Uw}@a[j5i6Ҷbz>@(Hњư5F~()6}_ 裺Y S)Ͱp5Byv;YԼ{(HHim0z&a/9e*y2:Wרd=Bֽ;W0/k ҁ8,bصπX)#%υ f_= bX8v(ӵ?9Ua %$Q(Ѩ1Beez,!C8SxWa'm$9|ϟoNEQPU7/.Tb %p>"94DܥOrғ*꿏%ϡ7񇍔},ffk41$XjswT[$Wjx=^\0&М[>?|אϽjPzmt/s<1NE⪛_Tu6Clo"ԻǬQ:`h?ŇT/v#HHH+Xql15ln=8]֤w3.Lea3 }tW3|>>*iᛈMw0+|n)H3!zQ1TȩxqC9}TWQuh%gz\+D QKzH NFy(i0=wK{㵴W;:y핿o޲>/X<`s{<4w634kIފnW4e@ӷ[? Q{XJvg_Q?|~{#*Ix߿Su[Ns6c,{|>Ǐ8fzNN>,~Q8Ncsߜ:̊aZ}܁fAۓ ٶm+FGX.t\{FEh+,(( 77\͂w@UU "0oLH d70?rKuWy#6eO,p@mm-1GP|Y%vaʢ`ڴiL8Eqp .ų˖m_mwbًW`yUrӽR"k)<Ç׷o_ 9tP;dXh/=&ӧs3vX d2f"""0[V]U/::. ^@nn."%{/a 2$O_WWǶ;ʇH m7G)v&]'qu;oVq\%Z/>3wC$ECu삘tV,t.ZBm)`ecղˣ0 aĘL>}s;>Ak 7^£!??=>>X}bccyw9VӅRg\*ڤ|H~}C*hwQ>5NVw/g6yuI!Ro)}v*~uzy7xcu~;!7n^AD&M|K_III~Z@t҅Y#8Wϰ^$\n-"222HJJ"(Kw Sp7Wo7NfͥGwcq[è ˂ٷsyu&9/iu9'']e8cǞ&9rWƶaYo_y+ Sk[zגBff&RJErU&=fؓ/੽}6:鎹<R}EY^hnpSWȓcio.Y\''zȯ2J^KdwRj)p 6LqLaer+V>~A< JrwoA!(cжIe8le8h$۠FFbWwR{ -z{/es?~)3ܟL:ZVOhgPŮ?]a9O)>ܟ r3ĕ:ߜ͏Śey%dm|S-..&\:IugD~MnQmqqq5U%MΟck9xR<Em7aoˮaxo$/7JCKE%RUm4[b d+<1#NGd-UsRYڹ];wxE|B'8(d9*56IR]cU} jӷC]GdlsUC蛺Ȇh;Ȼlj:!.AAosI6V@icID_D 59N6RPq8ZT΍Ewv8#<p:=קޞ8g!ۥ9Np'l+0x& f35l6ʼr7i$v[N9=~@yev6dF+K\r/^8M,V~NQF1E>nb̘1$&nxT.Çwtbl$KTqxټy3zwδ4~ _?eD߯#u qQ\r% 6YGMy|ZBЫW/Zνp:n1VxEӗISm^j\s`Ͼ9O^YZAX%dPi ,5{|ql⪙"T:I- gKq?8GTI>KιqK!|~U˅ _P b=#j5 6BB'K"Q^|l`3x}9!&Vvxu?Ϥu稵y dfFWar9r?uaMV<NL*ȯ1˺:RƂC]Q*ٯ6b5H A*[˶nHnQ#d|.Sc~p6ڦo ~`u oAi᭰Ue6qe,(ouAN 7(鱪DϿsfokJ|}z"trNuW -BI]H%E B{hϚ!R,CDR}BtIxRa>V"D1zN;j]9:ng" A#*?{y>Hm9gE>:Χ =AWhʹǔNя 4^|y-so[SnsXp\M^|{oK3uv!2{rg9һIwabQ^3ؽW]vW9)%Z^^{kۛ5^~+F{ыdoДQ<] KHSR￯-W\?~[S ~>s;iJ8ٽ{W;wMQAv壏Gegt$W\T\Yo.; slJ-^Gϔ^r!ބ<4[F ǟ0bpL-[ӽG&K["̴]ң c5tRRV}ofC}3C|{&!L{iU12|>7n?1chʽ=Z3Ͼd1?mc }[J>>ɭJqI58x_P${rB XA˖=V?鱂c C KS]{ ~~wUjaykT\Ԕp!i|^2KDff&IuלAiqO'9[EOrUV}di4yJǁ@-QgwdXv<%vJnnfTIMM՜ұԐ.%t2JKKkjДRRS[=铜Ra Hd̙r_3fh}kw=&o|Q/eXkodԩCi?~f佦x\|W}Ö]FUU~ڱϧ{>ɭ߸'6$`w2,][ak$IpՋƱJ;Q@mX$HAN 0J r:h =VQ?xs\\W7{iwrI]!X)jn{yzAo^XZI{Oa$NLeeTTXR±TӾci},BwrzyvKW{z.̙+@!{ IDATMEO<}Ҕ[c<8_C>jHj M6DjXɓ4Kcpy^:Ķ]zR3K3˞I$ؓ$#WS)Tt>ĽՆ7zr5 b$>>^3ALL{Edt5b6Gjʩ1=4C}!F/rư6뉼V +[a"]-hXAD0t1E A{ X ~C(BTؔ|㧭\FюsضsFidؾ}+#569ahٽDxwI=Dxݼq]l)RT3Rv9yΝ'bhM;3z3ٵ \NS1o_NM֖6&G2sƥri+<8|0_{ܒ,7z$ͽ-".0^qX$--=2s4rRJ5232};~'4r * #m\ =h4TpBMa[Ӱ̑W3@=4k۷xk#DSNUȖ>C9·{3 1$jrB f7/K  rZhlX) aI=V! +p:963Ѣϩ* 6ƨSS"ϹA3@uٶm\-[hظi\ue%6mnXftR*ʭٳUb)TUUy\R6"#toʭe>UUVx|$Wj)Д+:elGT\bR&G˟ݽG@nnE98nrх&3!4uB}'V ֽg}W+\yO$KL}'ZWMm|NJ}~xUBEby q>.\;_=G5XVUu+ vxKAKT%4R@:\ g;u)Z5@+R> 8y{P^C݌I]ӪtZcd3X)> -O'jb=>·qA3) _=:;@=^#؋l6B""`9YCљ RI&f,=7` ҹPm|I[BsI8UEW@( 8V*HCT~26 _o֜Trrc{JBhėtLjswQ~YS DR5j1I8!^Fʞ!]ʄ˗О g88+ )Q* Uah}k9  1iO7RuPu%럖j]q~5^ IFO-b. BFUŖ ˪y@\\6NWLX)2a2m)H(ϧdTvnt&b5Hi 0˟EDs"vʷEZW%/9f{dgcc;EI%M cHuuA@{D!T܎͟]8!R=od0{\> #5"eY2S@%^~)2z3^{ ީ:Q%" )gkKWQD=.a {q:5 NFeӀMO#6,)Ma0c)֫#6JxDw`:a5ׯ즠{ƕ|t ؋M֫dX \R?8[OFh: v,S(GGWGukLG4,pByV5nzWT+b YtTjI2zg{lH ^ꬲ( vէhռ ^9O_ Ю&٩ߋe|jeH-t{O"9l4?!.[VFɷKN\3X5L!T\+C#w#Ǟ N֧oKUXVљzq>7ubzeuj3y\n/g;)lXp{4K1k(8K(n֭o h:a5Bg r-":!:,RU[|kx`5ga5pQǡd;a1w֩ͮB#h4 0KI{t(E'yfL4%B9րGOj{E:\n`+NɆq."IMy]ݣXV͗uEB 僜an%Âc m?ڊXux ūLGr|7"jg,#$qPOd/9J N]xEbJw:\+PGY؊Y]"B{)5Gmn|OovKjCj s:AlNd WAՙeDĈkOkG5XV͗k@TX۾*w\Ք image/svg+xml prediction ^ prediction/man/prediction.Rd0000644000176200001440000004420413501406665015626 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/prediction.R, R/prediction_Arima.R, % R/prediction_ar.R, R/prediction_arima0.R, R/prediction_betareg.R, % R/prediction_biglm.R, R/prediction_bruto.R, R/prediction_clm.R, % R/prediction_coxph.R, R/prediction_crch.R, R/prediction_earth.R, % R/prediction_fda.R, R/prediction_gam.R, R/prediction_gausspr.R, % R/prediction_gee.R, R/prediction_glimML.R, R/prediction_glimQL.R, % R/prediction_glm.R, R/prediction_glmnet.R, R/prediction_glmx.R, % R/prediction_gls.R, R/prediction_hetglm.R, R/prediction_hurdle.R, % R/prediction_hxlr.R, R/prediction_ivreg.R, R/prediction_knnreg.R, % R/prediction_kqr.R, R/prediction_ksvm.R, R/prediction_lm.R, % R/prediction_lme.R, R/prediction_loess.R, R/prediction_lqs.R, % R/prediction_mars.R, R/prediction_mca.R, R/prediction_mclogit.R, % R/prediction_merMod.R, R/prediction_mnp.R, R/prediction_multinom.R, % R/prediction_nls.R, R/prediction_nnet.R, R/prediction_plm.R, % R/prediction_polr.R, R/prediction_polyreg.R, R/prediction_ppr.R, % R/prediction_princomp.R, R/prediction_rlm.R, R/prediction_rpart.R, % R/prediction_rq.R, R/prediction_selection.R, R/prediction_speedglm.R, % R/prediction_speedlm.R, R/prediction_survreg.R, R/prediction_svm.R, % R/prediction_svyglm.R, R/prediction_train.R, R/prediction_truncreg.R, % R/prediction_zeroinfl.R, R/summary.R \name{prediction-package} \alias{prediction-package} \alias{prediction} \alias{prediction.default} \alias{prediction.Arima} \alias{prediction.ar} \alias{prediction.arima0} \alias{prediction.betareg} \alias{prediction.biglm} \alias{prediction.bruto} \alias{prediction.clm} \alias{prediction.coxph} \alias{prediction.crch} \alias{prediction.earth} \alias{prediction.fda} \alias{prediction.Gam} \alias{prediction.gausspr} \alias{prediction.gee} \alias{prediction.glimML} \alias{prediction.glimQL} \alias{prediction.glm} \alias{prediction.glmnet} \alias{prediction.glmx} \alias{prediction.gls} \alias{prediction.hetglm} \alias{prediction.hurdle} \alias{prediction.hxlr} \alias{prediction.ivreg} \alias{prediction.knnreg} \alias{prediction.kqr} \alias{prediction.ksvm} \alias{prediction.lm} \alias{prediction.lme} \alias{prediction.loess} \alias{prediction.lqs} \alias{prediction.mars} \alias{prediction.mca} \alias{prediction.mclogit} \alias{prediction.merMod} \alias{prediction.mnp} \alias{prediction.multinom} \alias{prediction.nls} \alias{prediction.nnet} \alias{prediction.plm} \alias{prediction.polr} \alias{prediction.polyreg} \alias{prediction.ppr} \alias{prediction.princomp} \alias{prediction.rlm} \alias{prediction.rpart} \alias{prediction.rq} \alias{prediction.selection} \alias{prediction.speedglm} \alias{prediction.speedlm} \alias{prediction.survreg} \alias{prediction.svm} \alias{prediction.svyglm} \alias{prediction.train} \alias{prediction.truncreg} \alias{prediction.zeroinfl} \alias{prediction_summary} \title{Extract Predictions from a Model Object} \usage{ prediction(model, ...) \method{prediction}{default}(model, data = find_data(model, parent.frame()), at = NULL, type = "response", vcov = stats::vcov(model), calculate_se = TRUE, ...) \method{prediction}{Arima}(model, calculate_se = TRUE, ...) \method{prediction}{ar}(model, data, at = NULL, calculate_se = TRUE, ...) \method{prediction}{arima0}(model, data, at = NULL, calculate_se = TRUE, ...) \method{prediction}{betareg}(model, data = find_data(model, parent.frame()), at = NULL, type = c("response", "link", "precision", "variance", "quantile"), calculate_se = FALSE, ...) \method{prediction}{biglm}(model, data = find_data(model, parent.frame()), at = NULL, type = "response", calculate_se = TRUE, ...) \method{prediction}{bruto}(model, data = NULL, at = NULL, type = "fitted", calculate_se = FALSE, ...) \method{prediction}{clm}(model, data = find_data(model, parent.frame()), at = NULL, type = NULL, calculate_se = TRUE, category, ...) \method{prediction}{coxph}(model, data = find_data(model, parent.frame()), at = NULL, type = c("risk", "expected", "lp"), calculate_se = TRUE, ...) \method{prediction}{crch}(model, data = find_data(model), at = NULL, type = c("response", "location", "scale", "quantile"), calculate_se = FALSE, ...) \method{prediction}{earth}(model, data = find_data(model, parent.frame()), at = NULL, type = c("response", "link"), calculate_se = TRUE, category, ...) \method{prediction}{fda}(model, data = find_data(model, parent.frame()), at = NULL, type = NULL, calculate_se = FALSE, category, ...) \method{prediction}{Gam}(model, data = find_data(model, parent.frame()), at = NULL, type = c("response", "link", "terms"), calculate_se = TRUE, ...) \method{prediction}{gausspr}(model, data, at = NULL, type = NULL, calculate_se = TRUE, category, ...) \method{prediction}{gee}(model, calculate_se = FALSE, ...) \method{prediction}{glimML}(model, data = find_data(model, parent.frame()), at = NULL, type = c("response", "link"), calculate_se = TRUE, ...) \method{prediction}{glimQL}(model, data = find_data(model, parent.frame()), at = NULL, type = c("response", "link"), calculate_se = TRUE, ...) \method{prediction}{glm}(model, data = find_data(model, parent.frame()), at = NULL, type = c("response", "link"), vcov = stats::vcov(model), calculate_se = TRUE, ...) \method{prediction}{glmnet}(model, data, lambda = model[["lambda"]][1L], at = NULL, type = c("response", "link"), calculate_se = FALSE, ...) \method{prediction}{glmx}(model, data = find_data(model, parent.frame()), at = NULL, type = c("response", "link"), calculate_se = FALSE, ...) \method{prediction}{gls}(model, data = find_data(model), at = NULL, calculate_se = FALSE, ...) \method{prediction}{hetglm}(model, data = find_data(model, parent.frame()), at = NULL, type = c("response", "link", "scale"), calculate_se = FALSE, ...) \method{prediction}{hurdle}(model, data = find_data(model, parent.frame()), at = NULL, type = c("response", "count", "prob", "zero"), calculate_se = FALSE, ...) \method{prediction}{hxlr}(model, data = find_data(model), at = NULL, type = c("class", "probability", "cumprob", "location", "scale"), calculate_se = FALSE, ...) \method{prediction}{ivreg}(model, data = find_data(model, parent.frame()), at = NULL, calculate_se = FALSE, ...) \method{prediction}{knnreg}(model, data, at = NULL, calculate_se = FALSE, ...) \method{prediction}{kqr}(model, data, at = NULL, calculate_se = FALSE, ...) \method{prediction}{ksvm}(model, data, at = NULL, type = NULL, calculate_se = TRUE, category, ...) \method{prediction}{lm}(model, data = find_data(model, parent.frame()), at = NULL, type = "response", vcov = stats::vcov(model), calculate_se = TRUE, ...) \method{prediction}{lme}(model, data = find_data(model), at = NULL, calculate_se = FALSE, ...) \method{prediction}{loess}(model, data = find_data(model, parent.frame()), at = NULL, type = "response", calculate_se = TRUE, ...) \method{prediction}{lqs}(model, data = find_data(model), at = NULL, calculate_se = FALSE, ...) \method{prediction}{mars}(model, data = NULL, at = NULL, type = "fitted", calculate_se = FALSE, ...) \method{prediction}{mca}(model, data = find_data(model), at = NULL, calculate_se = FALSE, ...) \method{prediction}{mclogit}(model, data = find_data(model, parent.frame()), at = NULL, type = "response", vcov = stats::vcov(model), calculate_se = TRUE, ...) \method{prediction}{merMod}(model, data = find_data(model), at = NULL, type = c("response", "link"), re.form = NULL, calculate_se = FALSE, ...) \method{prediction}{mnp}(model, data = find_data(model, parent.frame()), at = NULL, type = NULL, calculate_se = FALSE, category, ...) \method{prediction}{multinom}(model, data = find_data(model, parent.frame()), at = NULL, type = NULL, calculate_se = FALSE, category, ...) \method{prediction}{nls}(model, data = find_data(model, parent.frame()), at = NULL, calculate_se = FALSE, ...) \method{prediction}{nnet}(model, data = find_data(model, parent.frame()), at = NULL, type = NULL, calculate_se = FALSE, category, ...) \method{prediction}{plm}(model, data = find_data(model, parent.frame()), at = NULL, calculate_se = FALSE, ...) \method{prediction}{polr}(model, data = find_data(model, parent.frame()), at = NULL, type = NULL, calculate_se = FALSE, category, ...) \method{prediction}{polyreg}(model, data = NULL, at = NULL, type = "fitted", calculate_se = FALSE, ...) \method{prediction}{ppr}(model, data = find_data(model, parent.frame()), at = NULL, calculate_se = FALSE, ...) \method{prediction}{princomp}(model, data = find_data(model, parent.frame()), at = NULL, calculate_se = FALSE, ...) \method{prediction}{rlm}(model, data = find_data(model, parent.frame()), at = NULL, type = "response", vcov = stats::vcov(model), calculate_se = TRUE, ...) \method{prediction}{rpart}(model, data = find_data(model, parent.frame()), at = NULL, type = NULL, calculate_se = FALSE, category, ...) \method{prediction}{rq}(model, data = find_data(model, parent.frame()), at = NULL, calculate_se = TRUE, ...) \method{prediction}{selection}(model, data = find_data(model, parent.frame()), at = NULL, type = "response", calculate_se = FALSE, ...) \method{prediction}{speedglm}(model, data = find_data(model, parent.frame()), at = NULL, type = c("response", "link"), calculate_se = FALSE, ...) \method{prediction}{speedlm}(model, data = find_data(model, parent.frame()), at = NULL, calculate_se = FALSE, ...) \method{prediction}{survreg}(model, data = find_data(model, parent.frame()), at = NULL, type = c("response", "lp", "quantile", "uquantile"), calculate_se = TRUE, ...) \method{prediction}{svm}(model, data = NULL, at = NULL, calculate_se = TRUE, category, ...) \method{prediction}{svyglm}(model, data = find_data(model, parent.frame()), at = NULL, type = c("response", "link"), calculate_se = TRUE, ...) \method{prediction}{train}(model, data = find_data(model), at = NULL, type = c("raw", "prob"), ...) \method{prediction}{truncreg}(model, data, at = NULL, calculate_se = FALSE, ...) \method{prediction}{zeroinfl}(model, data = find_data(model, parent.frame()), at = NULL, type = c("response", "count", "prob", "zero"), calculate_se = FALSE, ...) prediction_summary(model, ..., level = 0.95) } \arguments{ \item{model}{A model object, perhaps returned by \code{\link[stats]{lm}} or \code{\link[stats]{glm}}.} \item{\dots}{Additional arguments passed to \code{\link[stats]{predict}} methods.} \item{data}{A data.frame over which to calculate marginal effects. If missing, \code{\link{find_data}} is used to specify the data frame.} \item{at}{A list of one or more named vectors, specifically values at which to calculate the predictions. These are used to modify the value of \code{data} (see \code{\link{build_datalist}} for details on use).} \item{type}{A character string indicating the type of marginal effects to estimate. Mostly relevant for non-linear models, where the reasonable options are \dQuote{response} (the default) or \dQuote{link} (i.e., on the scale of the linear predictor in a GLM). For models of class \dQuote{polr} (from \code{\link[MASS]{polr}}), possible values are \dQuote{class} or \dQuote{probs}; both are returned.} \item{vcov}{A matrix containing the variance-covariance matrix for estimated model coefficients, or a function to perform the estimation with \code{model} as its only argument.} \item{calculate_se}{A logical indicating whether to calculate standard errors for observation-specific predictions and average predictions (if possible). The output will always contain a \dQuote{calculate_se} column regardless of this value; this only controls the calculation of standard errors. Setting it to \code{FALSE} may improve speed.} \item{category}{For multi-level or multi-category outcome models (e.g., ordered probit, multinomial logit, etc.), a value specifying which of the outcome levels should be used for the \code{"fitted"} column. If missing, some default is chosen automatically.} \item{lambda}{For models of class \dQuote{glmnet}, a value of the penalty parameter at which predictions are required.} \item{re.form}{An argument passed forward to \code{\link[lme4]{predict.merMod}}.} \item{level}{A numeric value specifying the confidence level for calculating p-values and confidence intervals.} } \value{ A data frame with class \dQuote{prediction} that has a number of rows equal to number of rows in \code{data}, or a multiple thereof, if \code{!is.null(at)}. The return value contains \code{data} (possibly modified by \code{at} using \code{\link{build_datalist}}), plus a column containing fitted/predicted values (\code{"fitted"}) and a column containing the standard errors thereof (\code{"calculate_se"}). Additional columns may be reported depending on the object class. The data frame also carries attributes used by \code{print} and \code{summary}, which will be lost during subsetting. } \description{ Extract predicted values via \code{\link[stats]{predict}} from a model object, conditional on data, and return a data frame. } \details{ This function is simply a wrapper around \code{\link[stats]{predict}} that returns a data frame containing the value of \code{data} and the predicted values with respect to all variables specified in \code{data}. Methods are currently implemented for the following object classes: \itemize{ \item \dQuote{lm}, see \code{\link[stats]{lm}} \item \dQuote{glm}, see \code{\link[stats]{glm}}, \code{\link[MASS]{glm.nb}}, \code{\link[glmx]{glmx}}, \code{\link[glmx]{hetglm}}, \code{\link[brglm]{brglm}} \item \dQuote{ar}, see \code{\link[stats]{ar}} \item \dQuote{Arima}, see \code{\link[stats]{arima}} \item \dQuote{arima0}, see \code{\link[stats]{arima0}} \item \dQuote{bigglm}, see \code{\link[biglm]{bigglm}} (including \dQuote{ffdf}-backed models provided by \code{\link[ffbase]{bigglm.ffdf}}) \item \dQuote{betareg}, see \code{\link[betareg]{betareg}} \item \dQuote{bruto}, see \code{\link[mda]{bruto}} \item \dQuote{clm}, see \code{\link[ordinal]{clm}} \item \dQuote{coxph}, see \code{\link[survival]{coxph}} \item \dQuote{crch}, see \code{\link[crch]{crch}} \item \dQuote{earth}, see \code{\link[earth]{earth}} \item \dQuote{fda}, see \code{\link[mda]{fda}} \item \dQuote{Gam}, see \code{\link[gam]{gam}} \item \dQuote{gausspr}, see \code{\link[kernlab]{gausspr}} \item \dQuote{gee}, see \code{\link[gee]{gee}} \item \dQuote{glmnet}, see \code{\link[glmnet]{glmnet}} \item \dQuote{gls}, see \code{\link[nlme]{gls}} \item \dQuote{glimML}, see \code{\link[aod]{betabin}}, \code{\link[aod]{negbin}} \item \dQuote{glimQL}, see \code{\link[aod]{quasibin}}, \code{\link[aod]{quasipois}} \item \dQuote{hurdle}, see \code{\link[pscl]{hurdle}} \item \dQuote{hxlr}, see \code{\link[crch]{hxlr}} \item \dQuote{ivreg}, see \code{\link[AER]{ivreg}} \item \dQuote{knnreg}, see \code{\link[caret]{knnreg}} \item \dQuote{kqr}, see \code{\link[kernlab]{kqr}} \item \dQuote{ksvm}, see \code{\link[kernlab]{ksvm}} \item \dQuote{lda}, see \code{\link[MASS]{lda}} \item \dQuote{lme}, see \code{\link[nlme]{lme}} \item \dQuote{loess}, see \code{\link[stats]{loess}} \item \dQuote{lqs}, see \code{\link[MASS]{lqs}} \item \dQuote{mars}, see \code{\link[mda]{mars}} \item \dQuote{mca}, see \code{\link[MASS]{mca}} \item \dQuote{mclogit}, see \code{\link[mclogit]{mclogit}} \item \dQuote{mda}, see \code{\link[mda]{mda}} \item \dQuote{merMod}, see \code{\link[lme4]{lmer}}, \code{\link[lme4]{glmer}} \item \dQuote{mnp}, see \code{\link[MNP]{mnp}} \item \dQuote{naiveBayes}, see \code{\link[e1071]{naiveBayes}} \item \dQuote{nlme}, see \code{\link[nlme]{nlme}} \item \dQuote{nls}, see \code{\link[stats]{nls}} \item \dQuote{nnet}, see \code{\link[nnet]{nnet}} \item \dQuote{plm}, see \code{\link[plm]{plm}} \item \dQuote{polr}, see \code{\link[MASS]{polr}} \item \dQuote{polyreg}, see \code{\link[mda]{polyreg}} \item \dQuote{ppr}, see \code{\link[stats]{ppr}} \item \dQuote{princomp}, see \code{\link[stats]{princomp}} \item \dQuote{qda}, see \code{\link[MASS]{qda}} \item \dQuote{rlm}, see \code{\link[MASS]{rlm}} \item \dQuote{rpart}, see \code{\link[rpart]{rpart}} \item \dQuote{rq}, see \code{\link[quantreg]{rq}} \item \dQuote{selection}, see \code{\link[sampleSelection]{selection}} \item \dQuote{speedglm}, see \code{\link[speedglm]{speedglm}} \item \dQuote{speedlm}, see \code{\link[speedglm]{speedlm}} \item \dQuote{survreg}, see \code{\link[survival]{survreg}} \item \dQuote{svm}, see \code{\link[e1071]{svm}} \item \dQuote{svyglm}, see \code{\link[survey]{svyglm}} \item \dQuote{tobit}, see \code{\link[AER]{tobit}} \item \dQuote{train}, see \code{\link[caret]{train}} \item \dQuote{truncreg}, see \code{\link[truncreg]{truncreg}} \item \dQuote{zeroinfl}, see \code{\link[pscl]{zeroinfl}} } Where implemented, \code{prediction} also returns average predictions (and the variances thereof). Variances are implemented using the delta method, as described in \url{http://indiana.edu/~jslsoc/stata/ci_computations/spost_deltaci.pdf}. } \examples{ require("datasets") x <- lm(Petal.Width ~ Sepal.Length * Sepal.Width * Species, data = iris) # prediction for every case prediction(x) # prediction for first case prediction(x, iris[1,]) # basic use of 'at' argument summary(prediction(x, at = list(Species = c("setosa", "virginica")))) # basic use of 'at' argument prediction(x, at = list(Sepal.Length = seq_range(iris$Sepal.Length, 5))) # prediction at means/modes of input variables prediction(x, at = lapply(iris, mean_or_mode)) # prediction with multi-category outcome \dontrun{ library("mlogit") data("Fishing", package = "mlogit") Fish <- mlogit.data(Fishing, varying = c(2:9), shape = "wide", choice = "mode") mod <- mlogit(mode ~ price + catch, data = Fish) prediction(mod) prediction(mod, category = 3) } } \seealso{ \code{\link{find_data}}, \code{\link{build_datalist}}, \code{\link{mean_or_mode}}, \code{\link{seq_range}} } \keyword{models} prediction/man/find_data.Rd0000644000176200001440000000455013331141552015367 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/find_data.R \name{find_data} \alias{find_data} \alias{find_data.default} \alias{find_data.data.frame} \alias{find_data.crch} \alias{find_data.glimML} \alias{find_data.glm} \alias{find_data.hxlr} \alias{find_data.lm} \alias{find_data.mca} \alias{find_data.merMod} \alias{find_data.svyglm} \alias{find_data.train} \alias{find_data.vgam} \alias{find_data.vglm} \title{Extract data from a model object} \usage{ find_data(model, ...) \method{find_data}{default}(model, env = parent.frame(), ...) \method{find_data}{data.frame}(model, ...) \method{find_data}{crch}(model, env = parent.frame(), ...) \method{find_data}{glimML}(model, ...) \method{find_data}{glm}(model, env = parent.frame(), ...) \method{find_data}{hxlr}(model, env = parent.frame(), ...) \method{find_data}{lm}(model, env = parent.frame(), ...) \method{find_data}{mca}(model, env = parent.frame(), ...) \method{find_data}{merMod}(model, env = parent.frame(), ...) \method{find_data}{svyglm}(model, ...) \method{find_data}{train}(model, ...) \method{find_data}{vgam}(model, env = parent.frame(), ...) \method{find_data}{vglm}(model, env = parent.frame(), ...) } \arguments{ \item{model}{The model object.} \item{\dots}{Additional arguments passed to methods.} \item{env}{An environment in which to look for the \code{data} argument to the modelling call.} } \value{ A data frame containing the original data used in a modelling call, modified according to the original model's `subset` and `na.action` arguments, if appropriate. } \description{ Attempt to reconstruct the data used to create a model object } \details{ This is a convenience function and, as such, carries no guarantees. To behave well, it typically requires that a model object be specified using a formula interface and an explicit \code{data} argument. Models that can be specified using variables from the \code{.GlobalEnv} or with a non-formula interface (e.g., a matrix of data) will tend to generate errors. \code{find_data} is an S3 generic so it is possible to expand it with new methods. } \examples{ require("datasets") x <- lm(mpg ~ cyl * hp + wt, data = head(mtcars)) find_data(x) } \seealso{ \code{\link{prediction}}, \code{\link{build_datalist}}, \code{\link{mean_or_mode}}, \code{\link{seq_range}} } prediction/man/seq_range.Rd0000644000176200001440000000124513066747142015434 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/seq_range.R \name{seq_range} \alias{seq_range} \title{Create a sequence over the range of a vector} \usage{ seq_range(x, n = 2) } \arguments{ \item{x}{A numeric vector} \item{n}{An integer specifying the length of sequence (i.e., number of points across the range of \code{x})} } \value{ A vector of length \code{n}. } \description{ Define a sequence of evenly spaced values from the minimum to the maximum of a vector } \examples{ identical(range(1:5), seq_range(1:5, n = 2)) seq_range(1:5, n = 3) } \seealso{ \code{\link{mean_or_mode}}, \code{\link{build_datalist}} } prediction/man/build_datalist.Rd0000644000176200001440000000266113331141552016443 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/build_datalist.R \name{build_datalist} \alias{build_datalist} \title{Build list of data.frames} \usage{ build_datalist(data, at = NULL, as.data.frame = FALSE, ...) } \arguments{ \item{data}{A data.frame containing the original data.} \item{at}{A list of one or more named vectors of values, which will be used to specify values of variables in \code{data}. All possible combinations are generated. Alternatively, this can be a data frame of combination levels if only a subset of combinations are desired. See examples.} \item{as.data.frame}{A logical indicating whether to return a single stacked data frame rather than a list of data frames} \item{\dots}{Ignored.} } \value{ A list of data.frames, unless \code{as.data.frame = TRUE} in which case a single, stacked data frame is returned. } \description{ Construct a list of data.frames based upon an input data.frame and a list of one or more \code{at} values } \examples{ # basic examples require("datasets") build_datalist(head(mtcars), at = list(cyl = c(4, 6))) str(build_datalist(head(mtcars), at = list(cyl = c(4,6), wt = c(2.75,3,3.25))), 1) str(build_datalist(head(mtcars), at = data.frame(cyl = c(4,4), wt = c(2.75,3)))) } \seealso{ \code{\link{find_data}}, \code{\link{mean_or_mode}}, \code{\link{seq_range}} } \author{ Thomas J. Leeper } \keyword{data} \keyword{manip} prediction/man/margex.Rd0000644000176200001440000000551213501406665014750 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/margex.R \docType{data} \name{margex} \alias{margex} \title{Artificial data for margins, copied from Stata} \format{A data frame with 3000 observations on the following 11 variables. \describe{ \item{\samp{y}}{A numeric vector} \item{\samp{outcome}}{A binary numeric vector with values (0,1)} \item{\samp{sex}}{A factor with two levels} \item{\samp{group}}{A factor with three levels} \item{\samp{age}}{A numeric vector} \item{\samp{distance}}{A numeric vector} \item{\samp{ycn}}{A numeric vector} \item{\samp{yc}}{A numeric vector} \item{\samp{treatment}}{A factor with two levels} \item{\samp{agegroup}}{A factor with three levels} \item{\samp{arm}}{A factor with three levels} }} \source{ \url{http://www.stata-press.com/data/r14/margex.dta} } \usage{ margex } \description{ The dataset is identical to the one provided by Stata and available from \code{webuse::webuse("margex")} with categorical variables explicitly encoded as factors. } \examples{ \donttest{ # Examples from Stata's help files # Also available from: webuse::webuse("margex") data("margex") # A simple case after regress # . regress y i.sex i.group # . margins sex m1 <- lm(y ~ factor(sex) + factor(group), data = margex) prediction(m1, at = list(sex = c("male", "female"))) # A simple case after logistic # . logistic outcome i.sex i.group # . margins sex m2 <- glm(outcome ~ sex + group, binomial(), data = margex) prediction(m2, at = list(sex = c("male", "female"))) # Average response versus response at average # . margins sex prediction(m2, at = list(sex = c("male", "female"))) # . margins sex, atmeans ## TODO # Multiple margins from one margins command # . margins sex group prediction(m2, at = list(sex = c("male", "female"))) prediction(m2, at = list(group = c("1", "2", "3"))) # Margins with interaction terms # . logistic outcome i.sex i.group sex#group # . margins sex group m3 <- glm(outcome ~ sex * group, binomial(), data = margex) prediction(m3, at = list(sex = c("male", "female"))) prediction(m3, at = list(group = c("1", "2", "3"))) # Margins with continuous variables # . logistic outcome i.sex i.group sex#group age # . margins sex group m4 <- glm(outcome ~ sex * group + age, binomial(), data = margex) prediction(m4, at = list(sex = c("male", "female"))) prediction(m4, at = list(group = c("1", "2", "3"))) # Margins of continuous variables # . margins, at(age=40) prediction(m4, at = list(age = 40)) # . margins, at(age=(30 35 40 45 50)) prediction(m4, at = list(age = c(30, 35, 40, 45, 50))) # Margins of interactions # . margins sex#group prediction(m4, at = list(sex = c("male", "female"), group = c("1", "2", "3"))) } } \seealso{ \code{\link{prediction}} } \keyword{datasets} prediction/man/mean_or_mode.Rd0000644000176200001440000000240013075625600016100 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/mean_or_mode.R \name{mean_or_mode} \alias{mean_or_mode} \alias{mean_or_mode.default} \alias{mean_or_mode.numeric} \alias{mean_or_mode.data.frame} \alias{median_or_mode} \alias{median_or_mode.default} \alias{median_or_mode.numeric} \alias{median_or_mode.data.frame} \title{Class-dependent variable aggregation} \usage{ mean_or_mode(x) \method{mean_or_mode}{default}(x) \method{mean_or_mode}{numeric}(x) \method{mean_or_mode}{data.frame}(x) median_or_mode(x) \method{median_or_mode}{default}(x) \method{median_or_mode}{numeric}(x) \method{median_or_mode}{data.frame}(x) } \arguments{ \item{x}{A vector.} } \value{ A numeric or factor vector of length 1. } \description{ Summarize a vector/variable into a single number, either a mean (median) for numeric vectors or the mode for categorical (character, factor, ordered, or logical) vectors. Useful for aggregation. } \examples{ require("datasets") # mean for numerics mean_or_mode(iris) mean_or_mode(iris[["Sepal.Length"]]) mean_or_mode(iris[["Species"]]) # median for numerics median_or_mode(iris) } \seealso{ \code{\link{prediction}}, \code{\link{build_datalist}}, \code{\link{seq_range}} } prediction/LICENSE0000644000176200001440000000006513331141552013416 0ustar liggesusersYEAR: 2016-2018 COPYRIGHT HOLDER: Thomas J. Leeper