https://github.com/cran/MuMIn
Raw File
Tip revision: 24dee7a22a11c56a96d66345d9b41d48bee32d0f authored by Kamil BartoĊ„ on 23 September 2011, 12:18:05 UTC
version 1.3.10
Tip revision: 24dee7a
ext.R
# Extends: glmmML      #########################################################

`tTable.glmmML` <- function(model, ...) {
    coef <- model$coefficients
    se <- model$coef.sd
    ret <- cbind(coef, se, coef/se, signif(1 - pchisq((coef/se)^2,
        1)))
    dimnames(ret) <- list(names(coef), c("Estimate", "Std. Error",
        "z", "Pr(>|z|)"))
  return(ret)
}

`logLik.glmmML` <- function(object, ...) {
  ll <- (-object$deviance)/2
  n <- length(object$coefficients)
  attr(ll, "df") <- n + object$cluster.null.df - object$df.residual
  attr(ll, "nobs") <- n + object$cluster.null.df
  class(ll) <- "logLik"
  ll
}

`nobs.glmmML` <- function(object, ...) length(object$coefficients) +
	object$cluster.null.df

# This is merely to get rid of the annoying behaviour in summary.glmML.
# it does not do anything except for printing the model output.
`summary.glmmML` <- function(object, ...) identity(object)

# Extends: survival    #########################################################

# logLik for survival::coxph model
# https://stat.ethz.ch/pipermail/r-help/2006-December/122118.html
# originally by Charles C. Berry, mod. by KB: correction for the null model
`logLik.coxph` <- function(object,...) {
# Thx to Mathieu Basille:
    y <-  object$loglik[length(object$loglik)]
	#y <-  if(length(object$loglik) > 1)
	#	-1 * (object$loglik[1] - object$loglik[2]) else object$loglik
    class(y) <- "logLik"
	#attr(y,"nall") <-
	attr(y, "nobs") <- object$n
    attr(y,'df') <- if(is.null(object$coef)) 0 else sum(!is.na(object$coef))
    return(y)
}

`nobs.coxph` <- function(object, ...) object$n

# Extends: lme4        #########################################################

`nobs.mer` <- function(object, nall = TRUE, ...) {
	N <- object@dims[["n"]]
	p <- object@dims[["p"]]
	if (nall) return (N)
	REML <- object@dims[['REML']]
	N - REML * p
}

# Extends: nnet/spdep        #########################################################

`nobs.sarlm` <-
`nobs.spautolm` <-
`nobs.multinom` <-
function(object, ...) NROW(fitted(object))



# No longer needed
# Extends: nlme
`nobs.gls` <- function(object, nall = TRUE, ...) {
	p <- object$dims$p
	N <- object$dims$N
	if (nall) return (N)
	REML <- object$method == "REML"
	N - REML * p
}

`nobs.lme` <- function(object, nall = TRUE, ...) {
	N <- object$dims$N
	if (nall) return (N)
	p <- object$dims$ncol[object$dims$Q + 1]
	REML <- object$method == "REML"
	N - REML * p
}

# # p - the number of coefficients in the linear model.
# #N - the number of observations in the data,
# #Q - the number of grouping levels
# #ncol - the number of columns in the model matrix for each level of grouping from innermost to outermost
# #  (last two values are equal to the number of fixed effects and one).



#(limited) support for unmarked

logLik.unmarkedFit <- function(object, ...) {
  ll <- -object@negLogLike
  attr(ll, "df") <- length(object@opt$par)
  attr(ll, "nobs") <- unmarked::sampleSize(object)
  class(ll) <- "logLik"
  ll
}
#setMethod("logLik", "unmarkedFit", logLik.unmarkedFit)

formula.unmarkedFit <- function (x, ...) x@formula

getAllTerms.unmarkedFit <- function (x, intercept = FALSE, ...)  {
  f <- formula(x)
  t1 <- getAllTerms(f[[2]])
  int1 <- attr(t1, "intercept")
  if(intercept && int1) t1 <- c("Int", t1)
  t2 <- getAllTerms(f[-2])
  int2 <- attr(t2, "intercept")
  if(intercept && int2) t2 <- c("Int", t2)
  
  structure(c(sprintf("psi(%s)",t1), sprintf("p(%s)",t2)), 
            intercept=c(int1, int2),
			interceptLabel=c("psi(Int)", "p(Int)")[as.logical(c(int1, int2))]
			)
}

#srcc <- function() sys.source("clipboard", .GlobalEnv)

tTable.unmarkedFit <- function (model, ...) {
  do.call("rbind", lapply(model@estimates@estimates, function(y) {
    ret <- cbind(Estimate=y@estimates, SE=sqrt(diag(y@covMat)))
    rn <- rownames(ret)
    rn[rn=="(Intercept)"] <- "Int"
    rownames(ret) <- paste(y@short.name, "(", rn, ")", sep="")
    ret 
  }))
}

coefDf.unmarkedFit <- function(x) rep(NA, length(coef(x)))
nobs.unmarkedFit <- function(object, ...) unmarked::sampleSize(object)
back to top