fbrPoisglm=function (x, y, weights = rep(1, nobs), start = NULL, etastart = NULL,
mustart = NULL, offset = rep(0, nobs), family = gaussian(),
control = list(), intercept = TRUE)
{
glm.control=
function (epsilon = 1e-08, maxit = 25, trace = FALSE, ...)
{
if (!is.numeric(epsilon) || epsilon <= 0)
stop("value of 'epsilon' must be > 0")
if (!is.numeric(maxit) || maxit < 0) ## allowing zero
stop("maximum number of iterations must be >= 0")
list(epsilon = epsilon, maxit = maxit, trace = trace)
}
control <- do.call("glm.control", control)
x <- as.matrix(x)
xnames <- dimnames(x)[[2L]]
ynames <- if (is.matrix(y))
rownames(y)
else names(y)
conv <- FALSE
nobs =n<- NROW(y)
nvars <- ncol(x)
EMPTY <- nvars == 0
if (is.null(weights))
weights <- rep.int(1, nobs)
if (is.null(offset))
offset <- rep.int(0, nobs)
variance <- family$variance
linkinv <- family$linkinv
if (!is.function(variance) || !is.function(linkinv))
stop("'family' argument seems not to be a valid family object",
call. = FALSE)
dev.resids <- family$dev.resids
aic <- family$aic
mu.eta <- family$mu.eta
unless.null <- function(x, if.null) if (is.null(x))
if.null
else x
valideta <- unless.null(family$valideta, function(eta) TRUE)
validmu <- unless.null(family$validmu, function(mu) TRUE)
if (is.null(mustart)) {
eval(family$initialize)
}
else {
mukeep <- mustart
eval(family$initialize)
mustart <- mukeep
}
if (EMPTY) {
eta <- rep.int(0, nobs) + offset
if (!valideta(eta))
stop("invalid linear predictor values in empty model",
call. = FALSE)
mu <- linkinv(eta)
if (!validmu(mu))
stop("invalid fitted means in empty model", call. = FALSE)
dev <- sum(dev.resids(y, mu, weights))
w <- ((weights * mu.eta(eta)^2)/variance(mu))^0.5
residuals <- (y - mu)/mu.eta(eta)
good <- rep(TRUE, length(residuals))
boundary <- conv <- TRUE
coef <- numeric()
iter <- 0L
}
else {
coefold <- NULL
eta <- if (!is.null(etastart))
etastart
else if (!is.null(start))
if (length(start) != nvars)
stop(gettextf("length of 'start' should equal %d and correspond to initial coefs for %s",
nvars, paste(deparse(xnames), collapse = ", ")),
domain = NA)
else {
coefold <- start
offset + as.vector(if (NCOL(x) == 1L)
x * start
else x %*% start)
}
else family$linkfun(mustart)
init.fit=lm.fit(x, eta, offset=offset)
coefold=init.fit$coefficients
coefold[is.na(coefold)]=0
rk=init.fit$rank
mu <- linkinv(eta)
if (!(validmu(mu) && valideta(eta)))
stop("cannot find valid starting values: please specify some",
call. = FALSE)
devold <- sum(dev.resids(y, mu, weights))
boundary <- conv <- FALSE
iter=1L
repeat{
good <- weights > 0
varmu <- variance(mu)[good]
if (any(is.na(varmu)))
stop("NAs in V(mu)")
if (any(varmu == 0))
stop("0s in V(mu)")
mu.eta.val <- mu.eta(eta)
if (any(is.na(mu.eta.val[good])))
stop("NAs in d(mu)/d(eta)")
good <- (weights > 0) & (mu.eta.val != 0)
if (all(!good)) {
conv <- FALSE
warning("no observations informative at iteration ",
iter)
break
}
w <- (sqrt((weights[good] * mu.eta.val[good]^2)/variance(mu)[good]))
W <- diag(w)
F <- t(x) %*% W %*% x
h <- x %*% solve(F) %*% t(x) %*% W
y.new <- y + diag(h)/2
z <- ((eta - offset)[good] + (y.new - mu)[good]/mu.eta.val[good])
ngoodobs <- as.integer(nobs - sum(!good))
fit <- lm.fit(x =x[good, , drop = FALSE] * w, y = z * w , singular.ok = TRUE, tol = min(1e-07, control$epsilon/1000))
if(fit$rank != rk){ ## rank should not change during iterations
fit$rank=fit$qr$rank=rk
fit$coefficients = qr.coef(fit$qr, z*w)
}
fit$coefficients[is.na(fit$coefficients)]=0
if(iter > control$maxit){ ## allows zero maxit
conv=FALSE
coef=coefold
dev=devold
break
}
if (any(!is.finite(fit$coefficients))) {
conv <- FALSE
warning(gettextf("non-finite coefficients at iteration %d",
iter), domain = NA)
break
}
if (nobs < fit$rank)
stop(gettextf("X matrix has rank %d, but only %d observations",
fit$rank, nobs), domain = NA)
#start[fit$qr$pivot] <- fit$coefficients
start <- fit$coefficients
eta <- drop(x %*% start)
mu <- linkinv(eta <- eta + offset)
dev <- sum(dev.resids(y.new, mu, weights))
if (control$trace)
cat("Deviance =", dev, "Iterations -", iter,
"\n")
boundary <- FALSE
if (!is.finite(dev)) {
if (is.null(coefold))
stop("no valid set of coefficients has been found: please supply starting values",
call. = FALSE)
warning("step size truncated due to divergence",
call. = FALSE)
ii <- 1
while (!is.finite(dev)) {
if (ii > control$maxit)
stop("inner loop 1; cannot correct step size",
call. = FALSE)
ii <- ii + 1
start <- (start + coefold)/2
eta <- drop(x %*% start)
mu <- linkinv(eta <- eta + offset)
dev <- sum(dev.resids(y.new, mu, weights))
}
boundary <- TRUE
if (control$trace)
cat("Step halved: new deviance =", dev, "\n")
}
if (!(valideta(eta) && validmu(mu))) {
if (is.null(coefold))
stop("no valid set of coefficients has been found: please supply starting values",
call. = FALSE)
warning("step size truncated: out of bounds",
call. = FALSE)
ii <- 1
while (!(valideta(eta) && validmu(mu))) {
if (ii > control$maxit)
stop("inner loop 2; cannot correct step size",
call. = FALSE)
ii <- ii + 1
start <- (start + coefold)/2
eta <- drop(x %*% start)
mu <- linkinv(eta <- eta + offset)
}
boundary <- TRUE
dev <- sum(dev.resids(y.new, mu, weights))
if (control$trace)
cat("Step halved: new deviance =", dev, "\n")
}
if (((dev - devold)/(0.1 + abs(dev)) >= control$epsilon) ) {
if (is.null(coefold))
stop("no valid set of coefficients has been found: please supply starting values",
call. = FALSE)
warning("step size truncated due to increasing deviance",
call. = FALSE)
ii <- 1
while ((dev - devold)/(0.1 + abs(dev)) > -control$epsilon) {
if (ii > control$maxit)
break
ii <- ii + 1
start <- (start + coefold)/2
eta <- drop(x %*% start)
mu <- linkinv(eta <- eta + offset)
dev <- sum(dev.resids(y.new, mu, weights))
}
if (ii > control$maxit)
warning("inner loop 3; cannot correct step size")
else if (control$trace)
cat("Step halved: new deviance =", dev, "\n")
}
if (abs(dev - devold)/(0.1 + abs(dev)) < control$epsilon) {
conv <- TRUE
coef <- start
break
}
else {
devold <- dev
coef <- coefold <- start
}
if (iter == control$maxit) break
iter = iter + 1L
}
if (!conv)
warning("glm.fit3: algorithm did not converge. Try increasing the maximum iterations",
call. = FALSE)
if (boundary)
warning("glm.fit3: algorithm stopped at boundary value",
call. = FALSE)
eps <- 10 * .Machine$double.eps
if (family$family == "binomial") {
if (any(mu > 1 - eps) || any(mu < eps))
warning("glm.fit3: fitted probabilities numerically 0 or 1 occurred",
call. = FALSE)
}
if (family$family == "poisson" || tolower(substr(family$family, 1L, 17L)) == "negative binomial") {
if (any(mu < eps))
warning("glm.fit3: fitted rates numerically 0 occurred",
call. = FALSE)
}
if (fit$rank < nvars)
coef[fit$qr$pivot][seq.int(fit$rank + 1, nvars)] <- NA
xxnames <- xnames[fit$qr$pivot]
residuals <- (y - mu)/mu.eta(eta)
fit$qr$qr <- as.matrix(fit$qr$qr)
nr <- min(sum(good), nvars)
if (nr < nvars) {
Rmat <- diag(nvars)
Rmat[1L:nr, 1L:nvars] <- fit$qr$qr[1L:nr, 1L:nvars]
}
else Rmat <- fit$qr$qr[1L:nvars, 1L:nvars]
Rmat <- as.matrix(Rmat)
Rmat[row(Rmat) > col(Rmat)] <- 0
names(coef) <- xnames
colnames(fit$qr$qr) <- xxnames
dimnames(Rmat) <- list(xxnames, xxnames)
}
names(residuals) <- ynames
names(mu) <- ynames
names(eta) <- ynames
wt <- rep.int(0, nobs)
wt[good] <- w^2
names(wt) <- ynames
names(weights) <- ynames
names(y) <- ynames
if (!EMPTY)
names(fit$effects) <- c(xxnames[seq_len(fit$rank)], rep.int("",
sum(good) - fit$rank))
wtdmu <- if (intercept)
sum(weights * y)/sum(weights)
else linkinv(offset)
nulldev <- sum(dev.resids(y, wtdmu, weights))
n.ok <- nobs - sum(weights == 0)
nulldf <- n.ok - as.integer(intercept)
rank <- if (EMPTY)
0
else fit$rank
resdf <- n.ok - rank
aic.model <- aic(y, n, mu, weights, dev) + 2 * rank
list(coefficients = coef, residuals = residuals, fitted.values = mu,
effects = if (!EMPTY) fit$effects, R = if (!EMPTY) Rmat,
rank = rank, qr = if (!EMPTY) structure(fit$qr[c("qr",
"rank", "qraux", "pivot", "tol")], class = "qr"),
family = family, linear.predictors = eta, deviance = dev,
aic = aic.model, null.deviance = nulldev, iter = iter,
weights = wt, prior.weights = weights, df.residual = resdf,
df.null = nulldf, y = y, converged = conv, boundary = boundary)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.