prediction/0000755000176200001440000000000014632065442012420 5ustar liggesusersprediction/tests/0000755000176200001440000000000014607342136013562 5ustar liggesusersprediction/tests/testthat-prediction.R0000644000176200001440000000010314607342136017675 0ustar liggesuserslibrary("testthat") library("prediction") test_check("prediction") prediction/tests/testthat/0000755000176200001440000000000014632065441015421 5ustar liggesusersprediction/tests/testthat/tests-methods.R0000644000176200001440000007242614607342136020363 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, kpar = list(sigma = 10)) p <- prediction(m) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) test_that("Test prediction() for 'ksvm'", { data("promotergene", package = "kernlab") ind <- sample(1:dim(promotergene)[1],20) genetrain <- promotergene[-ind, ] genetest <- promotergene[ind, ] m <- kernlab::ksvm(Class~., data = genetrain, kernel = "rbfdot", kpar = list(sigma = 0.015), C = 70, cross = 4, prob.model = TRUE) p <- prediction(m, data = genetrain) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) } if (require("lme4", quietly = TRUE)) { test_that("Test prediction() for 'merMod'", { data("cbpp", package = "lme4") m <- lme4::glmer(cbind(incidence, size - incidence) ~ period + (1 |herd), cbpp, binomial) p <- prediction(m) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) } if (require("MASS", quietly = TRUE)) { test_that("Test prediction() for 'glm.nb'", { data("quine", package = "MASS") m <- MASS::glm.nb(Days ~ Sex/(Age + Eth*Lrn), data = quine) p <- prediction(m) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) test_that("Test prediction() for 'lda'", { data("iris3", package = "datasets") tr <- sample(1:50, 25) train <- rbind(iris3[tr,,1], iris3[tr,,2], iris3[tr,,3]) cl <- factor(c(rep("s",25), rep("c",25), rep("v",25))) m <- MASS::lda(train, cl) p <- prediction(m, data = train) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) test_that("Test prediction() for 'lqs'", { data("stackloss", package = "datasets") m <- MASS::lqs(stack.loss ~ ., data = stackloss, method = "S", nsamp = "exact") p <- prediction(m) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) test_that("Test prediction() for 'mca'", { data("farms", package = "MASS") m <- MASS::mca(farms, abbrev=TRUE) p <- prediction(m) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) test_that("Test prediction() for 'polr'", { data("housing", package = "MASS") m <- MASS::polr(Sat ~ Infl + Type + Cont, weights = Freq, data = housing) p <- prediction(m) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) test_that("Test prediction() for 'qda'", { data("iris3", package = "datasets") tr <- sample(1:50, 25) train <- rbind(iris3[tr,,1], iris3[tr,,2], iris3[tr,,3]) cl <- factor(c(rep("s",25), rep("c",25), rep("v",25))) m <- MASS::qda(train, cl) p <- prediction(m, data = train) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) test_that("Test prediction() for 'rlm'", { data("stackloss", package = "datasets") m <- MASS::rlm(stack.loss ~ ., stackloss) p <- prediction(m) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) } if (require("mclogit", quietly = TRUE)) { test_that("Test prediction() for 'mclogit'", { data("Transport", package = "mclogit") m <- mclogit::mclogit(cbind(resp,suburb)~distance+cost, data = Transport, trace = FALSE) p <- prediction(m) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) } if (require("mda", quietly = TRUE)) { test_that("Test prediction() for 'bruto'", { data("trees", package = "datasets") m <- bruto(trees[,-3], trees[3]) p <- prediction(m, data = NULL) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) test_that("Test prediction() for 'fda'", { data("iris", package = "datasets") m <- fda(Species ~ ., data = iris) p <- prediction(m) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted", "fitted.class") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) test_that("Test prediction() for 'mars'", { data("trees", package = "datasets") m <- mars(trees[,-3], trees[3]) p <- prediction(m, data = NULL) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) test_that("Test prediction() for 'mda'", { data("glass", package = "mda") m <- mda(Type ~ ., data = glass) p <- prediction(m) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) test_that("Test prediction() for 'polyreg'", { data("iris", package = "datasets") m <- polyreg(iris[,2:3], iris$Sepal.Length) p <- prediction(m, data = NULL) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) } #if (require("mnlogit", quietly = TRUE)) { # test_that("Test prediction() for 'mnlogit'", { # data("Fish", package = "mnlogit") # m <- mnlogit::mnlogit(mode ~ price | income | catch, Fish, ncores = 1) # p <- prediction(m) # expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") # expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") # }) #} if (require("MNP", quietly = TRUE)) { test_that("Test prediction() for 'mnp'", { data("japan", package = "MNP") m <- MNP::mnp(cbind(LDP, NFP, SKG, JCP) ~ gender + education + age, data = head(japan, 100), verbose = FALSE) p <- prediction(m) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) } if (require("nlme", quietly = TRUE)) { test_that("Test prediction() for 'gls'", { data("Ovary", package = "nlme") m <- nlme::gls(follicles ~ sin(2*pi*Time) + cos(2*pi*Time), Ovary, correlation = nlme::corAR1(form = ~ 1 | Mare), verbose = FALSE) p <- prediction(m) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) test_that("Test prediction() for 'lme'", { data("Orthodont", package = "nlme") m <- nlme::lme(distance ~ age, Orthodont, random = ~ age | Subject) p <- prediction(m) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) } if (require("nnet", quietly = TRUE)) { #test_that("Test prediction() for 'multinom'", { }) test_that("Test prediction() for 'nnet'", { data("iris3", package = "datasets") ird <- data.frame(rbind(iris3[,,1], iris3[,,2], iris3[,,3]), species = factor(c(rep("s",50), rep("c", 50), rep("v", 50)))) samp <- c(sample(1:50,25), sample(51:100,25), sample(101:150,25)) m <- nnet::nnet(species ~ ., data = ird, subset = samp, size = 2, rang = 0.1, decay = 5e-4, maxit = 200, trace = FALSE) p <- prediction(m) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) } if (require("ordinal", quietly = TRUE)) { test_that("Test prediction() for 'clm'", { data("wine", package = "ordinal") m <- ordinal::clm(rating ~ temp * contact, data = wine) p <- prediction(m) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) } if (require("plm", quietly = TRUE)) { test_that("Test prediction() for 'plm'", { data("Grunfeld", package = "plm") m <- plm::plm(inv ~ value + capital, data = Grunfeld, model = "pooling") p <- prediction(m) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) } if (require("pscl", quietly = TRUE)) { test_that("Test prediction() for 'hurdle'", { data("bioChemists", package = "pscl") m <- pscl::hurdle(art ~ ., data = bioChemists) p <- prediction(m) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) test_that("Test prediction() for 'zeroinfl'", { data("bioChemists", package = "pscl") m <- pscl::zeroinfl(art ~ ., data = bioChemists) p <- prediction(m) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) #test_that("Test prediction() for 'ideal'", { # expect_true(inherits(prediction(m), "prediction")) #}) } if (require("quantreg", quietly = TRUE)) { test_that("Test prediction() for 'rq'", { data("stackloss", package = "datasets") m <- quantreg::rq(stack.loss ~ stack.x, tau = .5, data = stackloss) p <- prediction(m) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) } if (require("rpart", quietly = TRUE)) { test_that("Test prediction() for 'rpart'", { data("kyphosis", package = "rpart") m <- rpart::rpart(Kyphosis ~ Age + Number + Start, data = kyphosis) p <- prediction(m) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) } if (require("sampleSelection", quietly = TRUE)) { test_that("Test prediction() for 'selection'", { data("Mroz87", package = "sampleSelection") Mroz87$kids <- (Mroz87$kids5 + Mroz87$kids618 > 0) m <- sampleSelection::heckit(lfp ~ age + I( age^2 ) + faminc + kids + educ, wage ~ exper + I( exper^2 ) + educ + city, Mroz87) p <- prediction(m) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) } if (require("speedglm", quietly = TRUE) ) { test_that("Test prediction() for 'speedglm()'", { n <- 1000 k <- 3 y <- rnorm(n) x <- round(matrix(rnorm(n * k), n, k), digits = 3) colnames(x) <- c("s1", "s2", "s3") da <- data.frame(y, x) m <- speedglm(y ~ s1 + s2 + s3, data = da) p <- prediction(m) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) test_that("Test prediction() for 'speedlm()'", { n <- 1000 k <- 3 y <- rnorm(n) x <- round(matrix(rnorm(n * k), n, k), digits = 3) colnames(x) <- c("s1", "s2", "s3") da <- data.frame(y, x) m <- speedlm(y ~ s1 + s2 + s3, data = da) p <- prediction(m) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) } if (require("stats", quietly = TRUE)) { test_that("Test prediction() for 'ar'", { data("sunspot.year", package = "datasets") m <- stats::ar(sunspot.year) p <- prediction(m, data = sunspot.year) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) test_that("Test prediction() for 'Arima'", { expect_true(inherits(prediction(stats::arima(lh, order = c(3,0,0)), n.ahead = 12), "prediction")) }) test_that("Test prediction() for 'arima0'", { m <- stats::arima0(lh, order = c(1,0,1)) expect_true(inherits(prediction(m, data = lh, n.ahead = 12), "prediction")) }) test_that("Test prediction() for 'loess'", { m <- stats::loess(dist ~ speed, cars) p <- prediction(m) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) test_that("Test prediction() for 'nls'", { m <- stats::nls(demand ~ SSasympOrig(Time, A, lrc), data = BOD) p <- prediction(m) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) test_that("Test prediction() for 'ppr'", { data("rock", package = "datasets") rock$area1 <- rock$area/10000 rock$peri1 <- rock$peri/10000 m <- stats::ppr(log(perm) ~ area1 + peri1 + shape, data = rock, nterms = 2, max.terms = 5) p <- prediction(m) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) test_that("Test prediction() for 'princomp'", { data("USArrests", package = "datasets") m <- stats::princomp(~ ., data = USArrests, cor = TRUE) p <- prediction(m) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) } if (require("survey", quietly = TRUE)) { test_that("Test prediction() for 'svyglm'", { data("api", package = "survey") dstrat <- survey::svydesign(id=~1,strata=~stype, weights=~pw, data=apistrat, fpc=~fpc) m <- survey::svyglm(api.stu~enroll, design=dstrat) p <- prediction(m) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) } if (require("survival", quietly = TRUE)) { test_that("Test prediction() for 'coxph'", { test1 <- list(time=c(4,3,1,1,2,2,3), status=c(1,1,1,0,1,1,0), x=c(0,2,1,1,1,0,0), sex=c(0,0,0,0,1,1,1)) m <- survival::coxph(survival::Surv(time, status) ~ x + survival::strata(sex), test1) p <- prediction(m) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) test_that("Test prediction() for 'survreg'", { data("ovarian", package = "survival") m <- survival::survreg(survival::Surv(futime, fustat) ~ ecog.ps + rx, ovarian, dist='weibull', scale=1) p <- prediction(m) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) } if (require("truncreg", quietly = TRUE)) { test_that("Test prediction() for 'truncreg'", { data("tobin", package = "survival") m <- truncreg::truncreg(durable ~ age + quant, data = tobin, subset = durable > 0) p <- prediction(m) expect_true(inherits(p, "prediction"), label = "'prediction' class is correct") expect_true(all(c("fitted", "se.fitted") %in% names(p)), label = "'fitted' and 'se.fitted' columns returned") }) } prediction/tests/testthat/tests-core.R0000644000176200001440000001625314607342136017644 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-build_datalist.R0000644000176200001440000000316114607342136021672 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("Test build_datalist() with data.table", { dt <- data.table::data.table(y=1:5, x=1:5) expect_true(inherits(build_datalist(dt, at = list(x = 2)), "list"), label = "build_datalist(at = NULL) works with data.table") }) test_that("Factors in build_datalist()", { mtcars$cyl <- factor(mtcars$cyl) e <- build_datalist(mtcars, at = list(cyl = 4)) expect_true(inherits(e, "list"), label = "build_datalist(at = factor()) works") expect_true(identical(levels(mtcars$cyl), levels(e[[1L]][["cyl"]])), label = "build_datalist(at = factor()) preserves factor levels") expect_error(build_datalist(mtcars, at = list(cyl = 7)), label = "build_datalist(at = ) errors on illegal factor level") mtcars$cyl <- as.character(mtcars$cyl) expect_true(inherits(build_datalist(mtcars, at = list(cyl = 4)), "list"), label = "build_datalist(at = ) works") }) prediction/tests/testthat/tests-find_data.R0000644000176200001440000001264514607342136020626 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) }) test_that("Test find_data.lm() with subsetted data", { skip_if_not_installed("survey") library("survey") data(api) dstrat <- svydesign(id=~1, strata=~stype, weights=~pw, data=apistrat, fpc=~fpc) m <- svyglm(growth ~ target, dstrat) f <- find_data(m, design = dstrat) expect_true(identical(nrow(f), length(predict(m))), label = "Survey design model has correct rows") expect_true(identical(nrow(prediction(m)), length(predict(m))), label = "Survey design model has correct rows") }) prediction/MD50000644000176200001440000001216214632065442012732 0ustar liggesuserseca7354eab5c9d8b2506d31ee9a9d8da *DESCRIPTION c0c910cebf84e2e580fb56854af9c866 *LICENSE 3dfa7578972698e1ab88ec5558ffcf0a *NAMESPACE 8c335e42cddf26ee0bc4c8e249c64dad *NEWS.md 390b6092f7c9a730f06b4789fa81bcda *R/build_datalist.R 700d90f51c082169b85b935dca6e802e *R/find_data.R 30767bc602aae687782c70849f9ba947 *R/make_data_frame.R 8a22ac90a2ae6f23f8a3f76e6f50576b *R/margex.R 072316fc344b7a465a4cb93fd0ec71e4 *R/mean_or_mode.R 813dbb6ca9c2f77290081a49581962b9 *R/prediction.R a6b31181d98221cde242bc567155eb94 *R/prediction_Arima.R 80af1c3a886c931f778dcb686f0161de *R/prediction_ar.R c8d381e509d09c6091c36ba0ea153ede *R/prediction_arima0.R bab3befcd9f46746af2371bf13821aa3 *R/prediction_betareg.R 6529020a2cb8f4f0f320be69162cb06b *R/prediction_bigFastLm.R 1cd79060f4bb40c68a26ed21c861adb6 *R/prediction_bigglm.R 96754c938cd6a9eae671be9072be3ce7 *R/prediction_biglm.R 31f85346b4b918b45a49ed06997de056 *R/prediction_bruto.R 89ab5de2f65ff1d5064d21024d58e7ba *R/prediction_clm.R 11d18b95ebadce8f4161d9a401d2722b *R/prediction_coxph.R 5a8f9f63c04fd6680982060ab166268d *R/prediction_crch.R ad776c2bea0e0f5e5fa455ca43a7e80e *R/prediction_earth.R f11bb5a0a58414a4818aa5bac8c783aa *R/prediction_fda.R adf86c1fb0ca72ac79add74f83f5c4a0 *R/prediction_gam.R dd0c1f9609cfc936cad97bdc5c406907 *R/prediction_gausspr.R deccd7b71fe2e25656a1ad02f8835c8d *R/prediction_gee.R ccfec97c9646b204ef2691b084913139 *R/prediction_glimML.R a8840c8346e5b048df8b0812a4930785 *R/prediction_glimQL.R 10b1b119d51ba65ee0233e55491f6725 *R/prediction_glm.R 7775da01a405a04529c0afa287157075 *R/prediction_glmnet.R 37de226e7a5629abb6e6a9e75b5aaab4 *R/prediction_glmx.R e77fcf053694dfb7a81f587a67c83827 *R/prediction_gls.R 90d5698dfbc09002c9d0c30833f05471 *R/prediction_hetglm.R 5585082dc6dbaa3e129a5397638e5371 *R/prediction_hurdle.R 991943c4bd9eee53cf37c4b7a6c0b2fc *R/prediction_hxlr.R 2c384e252de0d25fd9c569200dbe6cda *R/prediction_ivreg.R a17c61481431686b849c99ab99893be8 *R/prediction_knnreg.R 7bfe3d83b1021c00807d327c59dcaeea *R/prediction_kqr.R 9a863724ef1ca056aacb7436d81c9124 *R/prediction_ksvm.R 72ea7795dbfd6a7bd5b387afc57b92c5 *R/prediction_lda.R 1e8f8f844fb1413a4f40ee4172d1ad0a *R/prediction_lm.R 5dc119a2ba8fb973bd3f6c385768cf19 *R/prediction_lme.R 8feccdc62a01e148c180a9c69ad4cd95 *R/prediction_loess.R 88af0a4f62a2c51af5165e9e808dfc46 *R/prediction_lqs.R a9d3063871f6fd926540c029f0a6ccd9 *R/prediction_mars.R cf4ded256ff1e25dabb9cfe9f6b99d8c *R/prediction_mca.R a90150c75116e6b63da2e7499c615f29 *R/prediction_mclogit.R 913891285b341f0f03a0ccf556d47fdc *R/prediction_merMod.R a171068928e3eec010901ee458f26c6c *R/prediction_mlogit.R 899268d0da54a9ebfc33a82ce894041d *R/prediction_mnlogit.R de727459f7804695b84a38f1ef84a0e1 *R/prediction_mnp.R 5ab74f5e19c862866bf2466b77324caf *R/prediction_multinom.R 2e58cdf9759af9f0f9d5b792f5a61347 *R/prediction_naiveBayes.R f6b176b63c94eb0cfff106477495db82 *R/prediction_nls.R ba2f2abab2be561cb03ccb3a8fed3273 *R/prediction_nnet.R cb89aa7330b5b516992962882b145aa2 *R/prediction_plm.R bce7dae4684f53114c3e0d936474b221 *R/prediction_polr.R fbd79b0b2c970f801b6fa346581ed5ae *R/prediction_polyreg.R 8b13c7db2cd4e73fd6f68d59bb0d71ad *R/prediction_ppr.R 1ef11772af479175dc50d934afe425ad *R/prediction_princomp.R c1cc6fdf7953c91c71023a44da109246 *R/prediction_qda.R fe222d150e9816ab599a56c77b8bdc6c *R/prediction_rlm.R 6b911dccc61333dcaa55bf088a05c10f *R/prediction_rpart.R a2a78937b32099c3360227b5ceca9a1f *R/prediction_rq.R 40a71181bae97d1a44e9134c242ce14b *R/prediction_selection.R 45d86a29d9b26e54966a9d8aebe282ba *R/prediction_speedglm.R 5bf04f8dedd311d1b449d07c8cde0386 *R/prediction_speedlm.R d0ffcbb4e3395e3baddba346859dac78 *R/prediction_survreg.R ec629813aabd80942b9b010a51e7d7b9 *R/prediction_svm.R 61010fd6a87fef6a8a3fcd1c29a01bfd *R/prediction_svyglm.R a0a1705721daba4fbedb302d4fa36707 *R/prediction_train.R b333ff8aed7c849ce16457592dbafd14 *R/prediction_tree.R 7bc4bef0b89eb6b734c72605e710e635 *R/prediction_truncreg.R fe54b1c7416bccc96a796598231fc195 *R/prediction_vgam.R da3881ad25f0462963d1dcc96a5d2175 *R/prediction_vglm.R 95a6e664e4b2aaeb70f461504dda9316 *R/prediction_zeroinfl.R 8ac4479808c06191e483796f64cccb64 *R/print.R 0312092d774377cadc4bd38f20ad2eb0 *R/seq_range.R e31a824c30eb5eada60875043281608f *R/summary.R 47aa5d9cbf6a752ed7c02bd5a18a1551 *R/utils.R 5f08503f6b6a1331077bfdbd9660d997 *README.md b52aabe9a2757fc86742763db9dafc9b *build/partial.rdb e9d44d03f5420756e7ada891b94f7235 *data/margex.rda a496ec320e0c2ff022c1a2b9043a1c15 *man/build_datalist.Rd 3619985ff0f3bd43fa6814b1a0874fe5 *man/figures/logo.png 44c5c504514d38c971f16a205a5a7054 *man/figures/logo.svg bc2eda108e88d1855a3d1e0fe871b8d4 *man/find_data.Rd 1d3f004f1ba0c8ca3b8228a8ea965f18 *man/margex.Rd 8a822a00fd9384e1303af00fa28c615c *man/mean_or_mode.Rd 2c16930f4db1e7649295f182d7aabd5a *man/prediction.Rd 5551438bf627470fa5d3e542d8af3df3 *man/seq_range.Rd 4ca784d4e1e67f3f628c361bfa275a4b *po/R-prediction.pot ca2d97b6c15fa31226da1fb542c1acdf *tests/testthat-prediction.R 8bb933a56a3d24c91a75468de514816d *tests/testthat/tests-build_datalist.R 62afca42e34dae9b468b37da97fd886d *tests/testthat/tests-core.R 0fdf7f5d42a763dcc0790c44bb7202e2 *tests/testthat/tests-find_data.R f9620b867ec4e1779f2bd1464c5e2313 *tests/testthat/tests-methods.R prediction/po/0000755000176200001440000000000014607342136013036 5ustar liggesusersprediction/po/R-prediction.pot0000644000176200001440000000416014607342136016122 0ustar liggesusersmsgid "" msgstr "" "Project-Id-Version: prediction 0.3.15\n" "POT-Creation-Date: 2019-12-24 14:49\n" "PO-Revision-Date: YEAR-MO-DA HO:MI+ZONE\n" "Last-Translator: FULL NAME \n" "Language-Team: LANGUAGE \n" "MIME-Version: 1.0\n" "Content-Type: text/plain; charset=CHARSET\n" "Content-Transfer-Encoding: 8bit\n" msgid "Illegal factor levels for variable '" msgstr "" msgid "':" msgstr "" msgid "," msgstr "" msgid "A 'at' value for '" msgstr "" msgid "' is" msgstr "" msgid "Some 'at' values for '" msgstr "" msgid "' are" msgstr "" msgid "'at' contains unnamed list elements" msgstr "" msgid "(" msgstr "" msgid ")" msgstr "" msgid "" msgstr "" msgid "'find_data()' requires a formula call" msgstr "" msgid "'find_data()' cannot locate variable(s) used in 'subset'" msgstr "" msgid "'find_data.vgam()' requires the 'methods' package" msgstr "" msgid "prediction() for objects of class 'bigglm' only work when 'data' is specified" msgstr "" msgid "prediction() for objects of class 'biglm' only work when 'data' is specified" msgstr "" msgid "'type' is ignored for models of class '%s'" msgstr "" msgid "category %s not found" msgstr "" msgid "'data' is required for models of class '%s'" msgstr "" msgid "'data' is ignored for models of class '%s'" msgstr "" msgid "'prediction.mnp' only works when 'n.draws = 1'" msgstr "" msgid "Data frame with %d %s%swith modal prediction (of %d %s):" msgstr "" msgid "prediction" msgstr "" msgid "predictions" msgstr "" msgid "call" msgstr "" msgid "from\n %s" msgstr "" msgid "level" msgstr "" msgid "levels" msgstr "" msgid "Data frame with %d %s%swith average prediction: %s" msgstr "" msgid "%0." msgstr "" msgid "f" msgstr "" msgid "Data frame with %d %s%swith modal %s (of %d %s):" msgstr "" msgid "Data frame with %d %s%swith average %s:" msgstr "" msgid "Unrecognized variable name in 'at': " msgid_plural "Unrecognized variable names in 'at': " msgstr[0] "" msgstr[1] "" msgid "prediction" msgid_plural "predictions" msgstr[0] "" msgstr[1] "" msgid "level" msgid_plural "levels" msgstr[0] "" msgstr[1] "" prediction/.aspell/0000755000176200001440000000000014632050331013745 5ustar liggesusersprediction/.aspell/mydict.rds0000644000176200001440000000007214632046702015756 0ustar liggesusersb```b`a@&330psr,t8-9prediction/.aspell/defaults.R0000644000176200001440000000023314632050321015674 0ustar liggesusersRd_files <- vignettes <- R_files <- description <- list(encoding = "UTF-8", language = "en", dictionaries = c("en_stats", "mydict")) prediction/R/0000755000176200001440000000000014632046460012620 5ustar liggesusersprediction/R/prediction_tree.R0000644000176200001440000000500314631707106016120 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_hxlr.R0000644000176200001440000000270114607342136016141 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_naiveBayes.R0000644000176200001440000000400414631707027017251 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_mclogit.R0000644000176200001440000000011214607342136016614 0ustar liggesusers#' @rdname prediction #' @export prediction.mclogit <- prediction.default prediction/R/prediction_rpart.R0000644000176200001440000000442214607342136016316 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_zeroinfl.R0000644000176200001440000000011214607342136017006 0ustar liggesusers#' @rdname prediction #' @export prediction.zeroinfl <- prediction.hurdle prediction/R/find_data.R0000644000176200001440000001147314631707201014656 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") } #' @rdname find_data #' @export find_data.glimQL <- function(model, env = parent.frame(), ...) { requireNamespace("methods", quietly = TRUE) methods::slot(model, "fm")$data } #' @rdname find_data #' @export find_data.glm <- find_data.default #' @rdname find_data #' @export find_data.hxlr <- find_data.default #' @rdname find_data #' @export find_data.lm <- find_data.default #' @rdname find_data #' @export find_data.mca <- function(model, env = parent.frame(), ...) { eval(model[["call"]][["df"]], envir = env) } #' @rdname find_data #' @importFrom stats model.frame #' @export find_data.merMod <- function(model, env = parent.frame(), ...) { model.frame(model) } #' @rdname find_data #' @export find_data.svyglm <- function(model, env = parent.frame(), ...) { dat <- model[["data"]] # handle subset if (!is.null(model[["call"]][["subset"]])) { subs <- try(eval(model[["call"]][["subset"]], dat), silent = TRUE) if (inherits(subs, "try-error")) { subs <- try(eval(model[["call"]][["subset"]], env), silent = TRUE) if (inherits(subs, "try-error")) { subs <- TRUE warning("'find_data()' cannot locate variable(s) used in 'subset'") } } dat <- dat[subs, , drop = FALSE] } # handle na.action if (!is.null(model[["na.action"]])) { dat <- dat[-model[["na.action"]], , drop = FALSE] } return(dat) } #' @rdname find_data #' @export find_data.train <- function(model, ...) { model[["trainingData"]] } #' @rdname find_data #' @export find_data.vgam <- function(model, env = parent.frame(), ...) { if (!requireNamespace("methods")) { stop("'find_data.vgam()' requires the 'methods' package") } dat <- methods::slot(model, "misc")[["dataname"]] get(dat, envir = env) } #' @rdname find_data #' @export find_data.vglm <- find_data.vgam prediction/R/print.R0000644000176200001440000000655514607342136014113 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_coxph.R0000644000176200001440000000364114607342136016311 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_bigglm.R0000644000176200001440000000325014631707077016433 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_svm.R0000644000176200001440000000624714607342136016002 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_vglm.R0000644000176200001440000000450314631707037016135 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_ksvm.R0000644000176200001440000000010714607342136016142 0ustar liggesusers#' @rdname prediction #' @export prediction.ksvm <- prediction.gausspr prediction/R/prediction_nnet.R0000644000176200001440000000442114607342136016131 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/seq_range.R0000644000176200001440000000116514607342136014713 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_gausspr.R0000644000176200001440000000450714607342136016656 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/R/prediction_truncreg.R0000644000176200001440000000217014607342136017015 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_ivreg.R0000644000176200001440000000245514607342136016306 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_ar.R0000644000176200001440000000322614607342136015571 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_gls.R0000644000176200001440000000265614607342136015762 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/mean_or_mode.R0000644000176200001440000000331314607342136015370 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_betareg.R0000644000176200001440000000304414607342136016576 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_princomp.R0000644000176200001440000000247114607342136017017 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/prediction_gam.R0000644000176200001440000000365114607342136015735 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/prediction_clm.R0000644000176200001440000000656114607342136015747 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/make_data_frame.R0000644000176200001440000000032714607342136016026 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_glmx.R0000644000176200001440000000272214607342136016136 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_hetglm.R0000644000176200001440000000271514607342136016451 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_merMod.R0000644000176200001440000000264514607342136016416 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_speedlm.R0000644000176200001440000000241314607342136016615 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_gee.R0000644000176200001440000000123614607342136015726 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/prediction_fda.R0000644000176200001440000000443414607342136015723 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_glimQL.R0000644000176200001440000000367514607342136016364 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_mlogit.R0000644000176200001440000000342714631707142016464 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_lda.R0000644000176200001440000000413214631707152015724 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/prediction_glm.R0000644000176200001440000000775214607342136015756 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_selection.R0000644000176200001440000000265614607342136017162 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_mca.R0000644000176200001440000000215314607342136015725 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_Arima.R0000644000176200001440000000165214607342136016221 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/prediction_nls.R0000644000176200001440000000253614607342136015766 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_plm.R0000644000176200001440000000243514607342136015760 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_loess.R0000644000176200001440000000263014607342136016312 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_lme.R0000644000176200001440000000242614607342136015745 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_speedglm.R0000644000176200001440000000267614607342136016777 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/prediction_train.R0000644000176200001440000000252014607342136016300 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_earth.R0000644000176200001440000000442414607342136016273 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_lqs.R0000644000176200001440000000252314607342136015765 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_biglm.R0000644000176200001440000000321314607342136016255 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_crch.R0000644000176200001440000000266514607342136016114 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_mnp.R0000644000176200001440000000523514607342136015763 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/utils.R0000644000176200001440000000035714607342136014111 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/build_datalist.R0000644000176200001440000001437214607342136015737 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` if (inherits(data, "data.table")) { dat <- data[, names(at), with = FALSE] } else { dat <- data[names(at)] } # drop non-numeric variables from `dat` and `at` not_numeric <- !sapply(dat, class) %in% c("character", "factor", "ordered", "logical") at <- at[names(at) %in% names(dat)[not_numeric]] if (inherits(dat, "data.table")) { dat <- dat[, which(not_numeric), with = FALSE] } else { dat <- dat[, not_numeric, drop = FALSE] } if (length(dat) > 0 & length(at) > 0) { # calculate variable ranges limits <- do.call(rbind, lapply(dat, range, na.rm = TRUE)) rownames(limits) <- names(dat) # check ranges for (i in seq_along(at)) { out <- (at[[i]] < limits[names(at)[i],1]) | (at[[i]] > limits[names(at)[i],2]) if (any( out ) ) { datarange <- paste0("outside observed data range (", limits[names(at)[i],1], ",", limits[names(at)[i],2], ")!") warning(ngettext(sum(out), paste0("A 'at' value for '", names(at)[i], "' is ", datarange), paste0("Some 'at' values for '", names(at)[i], "' are ", datarange))) } } } } check_at_names <- function(namevec, at) { if (is.null(namevec)) { return() } if (is.null(names(at)) || any(names(at) == "")) { stop("'at' contains unnamed list elements") } b <- !names(at) %in% namevec if (any(b)) { e <- ngettext(sum(b), "Unrecognized variable name in 'at': ", "Unrecognized variable names in 'at': ") stop(paste0(e, paste0("(", which(b), ") ", gsub("", "", names(at)[b]), collapse = ", "))) } } # data.frame builder, given specified `at` values ## returns the `at` combination as a data frame set_data_to_at <- function(data, at = NULL) { # expand `at` combinations if (inherits(at, "data.frame")) { expanded <- at } else { expanded <- expand.grid(at, KEEP.OUT.ATTRS = FALSE) } e <- split(expanded, unique(expanded)) data_out <- lapply(e, function(atvals) { dat <- data for (i in seq_along(atvals)) { is_factor <- inherits(dat[[names(atvals)[i]]], "factor") if (is_factor) { levs <- levels(dat[[names(atvals)[i]]]) if (inherits(dat, "data.table")) { dat[, names(atvals)[i]] <- factor(atvals[[i]], levels = levs) } else { dat[names(atvals)[i]] <- factor(atvals[[i]], levels = levs) } } else{ if (inherits(dat, "data.table")) { dat[, names(atvals)[i]] <- atvals[[i]] } else { dat[names(atvals)[i]] <- atvals[[i]] } } } structure(dat, at = as.list(atvals)) }) return(list(data = data_out, at = expanded)) } prediction/R/prediction_mars.R0000644000176200001440000000263114607342136016130 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_glimML.R0000644000176200001440000000367514607342136016360 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_ppr.R0000644000176200001440000000253314607342136015770 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_arima0.R0000644000176200001440000000010414607342136016330 0ustar liggesusers#' @rdname prediction #' @export prediction.arima0 <- prediction.ar prediction/R/margex.R0000644000176200001440000000553514631706552014242 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{https://www.stata-press.com/data/r14/margex.dta} #' @usage data("margex") #' @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_hurdle.R0000644000176200001440000000261514607342136016453 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_polr.R0000644000176200001440000000011014607342136016130 0ustar liggesusers#' @rdname prediction #' @export prediction.polr <- prediction.multinom prediction/R/summary.R0000644000176200001440000000417314607342136014446 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_polyreg.R0000644000176200001440000000262314607342136016650 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_multinom.R0000644000176200001440000000442714607342136017037 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_lm.R0000644000176200001440000000662514607342136015605 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_qda.R0000644000176200001440000000403514631707114015731 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_vgam.R0000644000176200001440000000365014631707050016117 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_rq.R0000644000176200001440000000260614607342136015612 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_survreg.R0000644000176200001440000000275314607342136016670 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_glmnet.R0000644000176200001440000000274114607342136016456 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_svyglm.R0000644000176200001440000000277114607342136016514 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_bruto.R0000644000176200001440000000262114607342136016320 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_bigFastLm.R0000644000176200001440000000226414631707015017036 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_kqr.R0000644000176200001440000000226314607342136015764 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_mnlogit.R0000644000176200001440000000422714631707132016640 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_knnreg.R0000644000176200001440000000217314607342136016453 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_rlm.R0000644000176200001440000000010614607342136015753 0ustar liggesusers#' @rdname prediction #' @export prediction.rlm <- prediction.default prediction/R/prediction.R0000644000176200001440000002313314632046460015105 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}} #' \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 by Xu and Long 2005 \doi{10.1177/1536867X0500500405}. #' #' @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 #' if (requireNamespace("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/data/0000755000176200001440000000000014607342136013331 5ustar liggesusersprediction/data/margex.rda0000644000176200001440000004430414607342136015311 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/NAMESPACE0000644000176200001440000000544414631707203013643 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,glimQL) 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,bigglm) 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,lda) 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,mlogit) S3method(prediction,mnlogit) S3method(prediction,mnp) S3method(prediction,multinom) S3method(prediction,naiveBayes) S3method(prediction,nls) S3method(prediction,nnet) S3method(prediction,plm) S3method(prediction,polr) S3method(prediction,polyreg) S3method(prediction,ppr) S3method(prediction,princomp) S3method(prediction,qda) 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,tree) S3method(prediction,truncreg) S3method(prediction,vgam) S3method(prediction,vglm) 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/LICENSE0000644000176200001440000000006314607342136013424 0ustar liggesusersYEAR: 2016-2018 COPYRIGHT HOLDER: Thomas J. Leeper prediction/NEWS.md0000644000176200001440000002247514631707321013526 0ustar liggesusers## prediction 0.3.18 * under new maintainership * various cosmetic/CRAN check updates ## prediction 0.3.15 * `build_datalist()` now works correctly with data.table datasets. (#34, #35, h/t Dan Schrage) * `build_datalist()` dropped factor levels when replacing a factor variable. (#39, h/t Tomasz Żółtak) * `find_data()` now respects `subset` and `na.actions` arguments for `svyglm()` models. (#37, h/t Tomasz Żółtak) ## prediction 0.3.13 * Fixed a bug in `prediction_glm` with the `data` argument (Issue #32). ## prediction 0.3.12 * Remove mnlogit dependency, as it has been removed from CRAN. ## prediction 0.3.11 * Remove bigFastLm dependency, as it has been removed from CRAN. ## prediction 0.3.10 * Added tests for `find_data()` and `prediction.lm()` to check for correct behavior in the presence of missing data (`na.action`) and `subset` arguments. (#28) ## prediction 0.3.8 * Provisional support for variances of average predictions for GLMs. (#17) * Added an example dataset, `margex`, borrowed from Stata's identically named data. ## prediction 0.3.7 * `summary(prediction(...))` now reports variances of average predictions, along with test statistics, p-values, and confidence intervals, where supported. (#17) * Added a function `prediction_summary()` which simply calls `summary(prediction(...))`. * All methods now return additional attributes. ## prediction 0.3.6 * Small fixes for failing CRAN checks. (#25) * Remove `prediction.bigglm()` method (from **biglm**) due to failing tests. (#25) ## prediction 0.3.5 * Fixed a bug that required specifying `stats::poly()` rather than just `poly()` in model formulae. (#22) ## prediction 0.3.4 * Added `prediction.glmnet()` method for "glmnet" objects from **glmnet**. (#1) ## prediction 0.3.3 * `prediction.merMod()` gains an `re.form` argument to pass forward to `predict.merMod()`. ## prediction 0.3.2 * Fix typo in "speedglm" that was overwriting "glm" method. ## prediction 0.3.0 * CRAN release. ## prediction 0.2.11 * Added `prediction.glmML()` method for "glimML" objects from **aod**. (#1) * Added `prediction.glmQL()` method for "glimQL" objects from **aod**. (#1) * Added `prediction.truncreg()` method for "truncreg" objects from **truncreg**. (#1) * Noted implicit support for "tobit" objects from **AER**. (#1) ## prediction 0.2.10 * Added `prediction.bruto()` method for "bruto" objects from **mda**. (#1) * Added `prediction.fda()` method for "fda" objects from **mda**. (#1) * Added `prediction.mars()` method for "mars" objects from **mda**. (#1) * Added `prediction.mda()` method for "mda" objects from **mda**. (#1) * Added `prediction.polyreg()` method for "polyreg" objects from **mda**. (#1) ## prediction 0.2.9 * Added `prediction.speedglm()` and `prediction.speedlm()` methods for "speedglm" and "speedlm" objects from **speedglm**. (#1) * Added `prediction.bigLm()` method for "bigLm" objects from **bigFastlm**. (#1) * Added `prediction.biglm()` and `prediction.bigglm()` methods for "biglm" and "bigglm" objects from **biglm**, including those based by `"ffdf"` from **ff**. (#1) ## prediction 0.2.8 * Changed internal behavior of `build_datalist()`. The function now returns an an `at_specification` attribute, which is a data frame representation of the `at` argument. ## prediction 0.2.6 * Due to a change in gam_1.15, `prediction.gam()` is now `prediction.Gam()` for "Gam" objects from **gam**. (#1) ## prediction 0.2.6 * Added `prediction.train()` method for "train" objects from **caret**. (#1) ## prediction 0.2.5 * The `at` argument in `build_datalist()` now accepts a data frame of combinations for limiting the set of levels. ## prediction 0.2.3 * Most `prediction()` methods gain a (experimental) `calculate_se` argument, which regulates whether to calculate standard errors for predictions. Setting to `FALSE` can improve performance if they are not needed. ## prediction 0.2.3 * `build_datalist()` gains an `as.data.frame` argument, which - if `TRUE` - returns a stacked data frame rather than a list. This argument is now used internally in most `prediction()` functions in an effort to improve performance. (#18) ## prediction 0.2.2 * Expanded test suite scope and fixed a few small bugs. * Added a `summary.prediction()` method to interact with the average predicted values that are printed when `at != NULL`. ## prediction 0.2.1 * Added `prediction.knnreg()` method for "knnreg" objects from **caret**. (#1) * Added `prediction.gausspr()` method for "gausspr" objects from **kernlab**. (#1) * Added `prediction.ksvm()` method for "ksvm" objects from **kernlab**. (#1) * Added `prediction.kqr()` method for "kqr" objects from **kernlab**. (#1) * Added `prediction.earth()` method for "earth" objects from **earth**. (#1) * Added `prediction.rpart()` method for "rpart" objects from **rpart**. (#1) ## prediction 0.2.0 * CRAN Release. * Added `mean_or_mode.data.frame()` and `median_or_mode.data.frame()` methods. ## prediction 0.1.17 * Added `prediction.zeroinfl()` method for "zeroinfl" objects from **pscl**. (#1) * Added `prediction.hurdle()` method for "hurdle" objects from **pscl**. (#1) * Added `prediction.lme()` method for "lme" and "nlme" objects from **nlme**. (#1) * Documented `prediction.merMod()`. ## prediction 0.1.16 * Added `prediction.plm()` method for "plm" objects from **plm**. (#1) ## prediction 0.1.15 * Expanded test suite considerably and updated `CONTRIBUTING.md` to reflect expected test-driven development. * A few small code tweaks and bug fixes resulting from the updated test suite. ## prediction 0.1.14 * Added `prediction.mnp()` method for "mnp" objects from **MNP**. (#1) * Added `prediction.mnlogit()` method for "mnlogit" objects from **mnlogit**. (#1) * Added `prediction.gee()` method for "gee" objects from **gee**. (#1) * Added `prediction.lqs()` method for "lqs" objects from **MASS**. (#1) * Added `prediction.mca()` method for "mca" objects from **MASS**. (#1) * Noted (built-in) support for "brglm" objects from **brglm** via the `prediction.glm()` method. (#1) ## prediction 0.1.13 * Added a `category` argument to `prediction()` methods for models of multilevel outcomes (e.g., ordered probit, etc.) to be dictate which level is expressed as the `"fitted"` column. (#14) * Added an `at` argument to `prediction()` methods. (#13) * Made `mean_or_mode()` and `median_or_mode()` S3 generics. * Fixed a bug in `mean_or_mode()` and `median_or_mode()` where incorrect factor levels were being returned. ## prediction 0.1.12 * Added `prediction.princomp()` method for "princomp" objects from **stats**. (#1) * Added `prediction.ppr()` method for "ppr" objects from **stats**. (#1) * Added `prediction.naiveBayes()` method for "naiveBayes" objects from **e1071**. (#1) * Added `prediction.rlm()` method for "rlm" objects from **MASS**. (#1) * Added `prediction.qda()` method for "qda" objects from **MASS**. (#1) * Added `prediction.lda()` method for "lda" objects from **MASS**. (#1) * `find_data()` now respects the `subset` argument in an original model call. (#15) * `find_data()` now respects the `na.action` argument in an original model call. (#15) * `find_data()` now gracefully fails when a model is specified without a formula. (#16) * `prediction()` methods no longer add a "fit" or "se.fit" class to any columns. Fitted values are identifiable by the column name only. ## prediction 0.1.11 * `build_datalist()` now returns `at` value combinations as a list. ## prediction 0.1.10 * Added `prediction.nnet()` method for "nnet" and "multinom" objects from **nnet**. (#1) ## prediction 0.1.9 * `prediction()` methods now return the value of `data` as part of the response data frame. (#8, h/t Ben Whalley) * Slight change to `find_data()` methods for `"crch"` and `"hxlr"`. (#5) * Added `prediction.glmx()` and `prediction.hetglm()` methods for "glmx" and "hetglm" objects from **glmx**. (#1) * Added `prediction.betareg()` method for "betareg" objects from **betareg**. (#1) * Added `prediction.rq()` method for "rq" objects from **quantreg**. (#1) * Added `prediction.gam()` method for "gam" objects from **gam**. (#1) * Expanded basic test suite. ## prediction 0.1.8 * Added `prediction()` and `find_data()` methods for `"crch"` `"hxlr"` objects from **crch**. (#4, h/t Carl Ganz) ## prediction 0.1.7 * Added `prediction()` and `find_data()` methods for `"merMod"` objects from **lme4**. (#1) ## prediction 0.1.6 * Moved the `seq_range()` function from **margins** to **prediction**. * Moved the `build_datalist()` function from **margins** to **prediction**. This will simplify the ability to calculate arbitrary predictions. ## prediction 0.1.5 * Added `prediction.svm()` method for objects of class `"svm"` from **e1071**. (#1) * Fixed a bug in `prediction.polr()` when attempting to pass a `type` argument, which is always ignored. A warning is now issued when attempting to override this. ## prediction 0.1.4 * Added `mean_or_mode()` and `median_or_mode()` functions, which provide a simple way to aggregate a variable of factor or numeric type. (#3) * Added `prediction()` methods for various time-series model classes: "ar", "arima0", and "Arima". ## prediction 0.1.3 * `find_data()` is now a generic, methods for "lm", "glm", and "svyglm" classes. (#2, h/t Carl Ganz) ## prediction 0.1.2 * Added support for "svyglm" class from the **survey** package. (#1) * Added tentative support for "clm" class from the **ordinal** package. (#1) ## prediction 0.1.0 * Initial package released. prediction/README.md0000644000176200001440000001635014631706642013707 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`](https://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://ci.appveyor.com/api/projects/status/a4tebeoa98cq07gy/branch/master?svg=true)](https://ci.appveyor.com/project/leeper/prediction/branch/master) [![codecov.io](https://app.codecov.io/github/leeper/prediction?branch=master)](https://app.codecov.io/github/leeper/prediction?branch=master) [![Project Status: Active - The project has reached a stable, usable state and is being actively developed.](https://www.repostatus.org/badges/latest/active.svg)](https://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/build/0000755000176200001440000000000014632050331013506 5ustar liggesusersprediction/build/partial.rdb0000644000176200001440000000007414632050331015634 0ustar liggesusersb```b`a 00 FN ͚Z d@$/7prediction/man/0000755000176200001440000000000014607342771013200 5ustar liggesusersprediction/man/margex.Rd0000644000176200001440000000537414631706747014767 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{https://www.stata-press.com/data/r14/margex.dta} } \usage{ data("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/figures/0000755000176200001440000000000014607342136014637 5ustar liggesusersprediction/man/figures/logo.svg0000644000176200001440000005531314607342136016327 0ustar liggesusers image/svg+xml prediction ^ prediction/man/figures/logo.png0000644000176200001440000002564614607342136016322 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\Ք. 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 file or main package documentation page for a complete listing. License: MIT + file LICENSE Version: 0.3.18 Authors@R: c(person("Thomas J.", "Leeper", role = c("aut"), comment = c(ORCID = "0000-0003-4097-6326")), person("Carl", "Ganz", role = "ctb"), person("Vincent", "Arel-Bundock", role = "ctb", comment = c(ORCID = "0000-0003-2042-7063")), person("Ben","Bolker",email="bolker@mcmaster.ca", role=c("ctb","cre"), comment=c(ORCID="0000-0002-2127-0443")) ) URL: https://github.com/bbolker/prediction BugReports: https://github.com/bbolker/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, 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: 7.3.1 NeedsCompilation: no Packaged: 2024-06-11 13:27:53 UTC; bolker Author: Thomas J. Leeper [aut] (), Carl Ganz [ctb], Vincent Arel-Bundock [ctb] (), Ben Bolker [ctb, cre] () Maintainer: Ben Bolker Repository: CRAN Date/Publication: 2024-06-11 15:20:02 UTC