Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Implement better printing for trending_model_fit objects #15

Open
TimTaylor opened this issue Mar 25, 2021 · 0 comments
Open

Implement better printing for trending_model_fit objects #15

TimTaylor opened this issue Mar 25, 2021 · 0 comments

Comments

@TimTaylor
Copy link
Contributor

trending_model_fit objects display really poorly and also there is a difference between the family argument being quoted or not.

library(incidence2)
library(trending)
library(outbreaks)

raw_dat <- ebola_sim_clean$linelist
dat <- incidence(raw_dat, date_index = date_of_onset, interval = 7, groups = gender)[1:20, ]
model1 <- glm_model(count ~ date_index, family = poisson)
fit(model1, dat)
#> $fitted_model
#> 
#> Call:  glm(formula = count ~ date_index, family = function (link = "log") 
#> {
#>     linktemp <- substitute(link)
#>     if (!is.character(linktemp)) 
#>         linktemp <- deparse(linktemp)
#>     okLinks <- c("log", "identity", "sqrt")
#>     family <- "poisson"
#>     if (linktemp %in% okLinks) 
#>         stats <- make.link(linktemp)
#>     else if (is.character(link)) {
#>         stats <- make.link(link)
#>         linktemp <- link
#>     }
#>     else {
#>         if (inherits(link, "link-glm")) {
#>             stats <- link
#>             if (!is.null(stats$name)) 
#>                 linktemp <- stats$name
#>         }
#>         else {
#>             stop(gettextf("link \"%s\" not available for %s family; available links are %s", 
#>                 linktemp, family, paste(sQuote(okLinks), collapse = ", ")), 
#>                 domain = NA)
#>         }
#>     }
#>     variance <- function(mu) mu
#>     validmu <- function(mu) all(is.finite(mu)) && all(mu > 0)
#>     dev.resids <- function(y, mu, wt) {
#>         r <- mu * wt
#>         p <- which(y > 0)
#>         r[p] <- (wt * (y * log(y/mu) - (y - mu)))[p]
#>         2 * r
#>     }
#>     aic <- function(y, n, mu, wt, dev) -2 * sum(dpois(y, mu, 
#>         log = TRUE) * wt)
#>     initialize <- expression({
#>         if (any(y < 0)) stop("negative values not allowed for the 'Poisson' family")
#>         n <- rep.int(1, nobs)
#>         mustart <- y + 0.1
#>     })
#>     simfun <- function(object, nsim) {
#>         wts <- object$prior.weights
#>         if (any(wts != 1)) 
#>             warning("ignoring prior weights")
#>         ftd <- fitted(object)
#>         rpois(nsim * length(ftd), ftd)
#>     }
#>     structure(list(family = family, link = linktemp, linkfun = stats$linkfun, 
#>         linkinv = stats$linkinv, variance = variance, dev.resids = dev.resids, 
#>         aic = aic, mu.eta = stats$mu.eta, initialize = initialize, 
#>         validmu = validmu, valideta = stats$valideta, simulate = simfun), 
#>         class = "family")
#> }, data = data)
#> 
#> Coefficients:
#> (Intercept)   date_index  
#>  -397.68342      0.02466  
#> 
#> Degrees of Freedom: 19 Total (i.e. Null);  18 Residual
#> Null Deviance:       58.31 
#> Residual Deviance: 17.13     AIC: 94.95
#> 
#> $predict
#> function (newdata, alpha = 0.05, add_pi = TRUE, simulate_pi = FALSE, 
#>     uncertain = TRUE) 
#> {
#>     if (missing(newdata)) {
#>         newdata <- data[all.vars(formula(model))]
#>     }
#>     result <- add_confidence_interval(model, newdata, alpha)
#>     if (add_pi) {
#>         if (simulate_pi) {
#>             result <- add_prediction_interval(model, result, 
#>                 alpha, simulate_pi, uncertain)
#>         }
#>         else {
#>             result <- add_prediction_interval(model, result, 
#>                 alpha, simulate_pi, uncertain)
#>         }
#>     }
#>     result
#> }
#> <bytecode: 0x55c0687160c0>
#> <environment: 0x55c068714bc0>
#> 
#> attr(,"class")
#> [1] "trending_model_fit" "list"
model2 <- glm_model(count ~ date_index, family = "poisson")
fit(model2, dat)
#> $fitted_model
#> 
#> Call:  glm(formula = count ~ date_index, family = "poisson", data = data)
#> 
#> Coefficients:
#> (Intercept)   date_index  
#>  -397.68342      0.02466  
#> 
#> Degrees of Freedom: 19 Total (i.e. Null);  18 Residual
#> Null Deviance:       58.31 
#> Residual Deviance: 17.13     AIC: 94.95
#> 
#> $predict
#> function (newdata, alpha = 0.05, add_pi = TRUE, simulate_pi = FALSE, 
#>     uncertain = TRUE) 
#> {
#>     if (missing(newdata)) {
#>         newdata <- data[all.vars(formula(model))]
#>     }
#>     result <- add_confidence_interval(model, newdata, alpha)
#>     if (add_pi) {
#>         if (simulate_pi) {
#>             result <- add_prediction_interval(model, result, 
#>                 alpha, simulate_pi, uncertain)
#>         }
#>         else {
#>             result <- add_prediction_interval(model, result, 
#>                 alpha, simulate_pi, uncertain)
#>         }
#>     }
#>     result
#> }
#> <bytecode: 0x55c0687160c0>
#> <environment: 0x55c0689214f0>
#> 
#> attr(,"class")
#> [1] "trending_model_fit" "list"

Created on 2021-03-25 by the reprex package (v1.0.0)

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Labels
None yet
Projects
None yet
Development

No branches or pull requests

1 participant